From 342f0308d35f7fef87f73a29af4e856f44c8a7e0 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 29 Dec 2018 22:30:07 +0000 Subject: [PATCH 01/40] The beginning of bignums is in place, tests still pass. --- src/arith/bignum.c | 14 ----- src/arith/bignum.h | 16 ----- src/arith/integer.c | 104 +++++++++++++++++++++++++++---- src/arith/integer.h | 6 +- src/arith/peano.c | 25 ++++---- src/arith/ratio.c | 25 ++++---- src/memory/conspage.c | 3 + src/memory/consspaceobject.h | 22 +------ src/ops/equal.c | 5 +- src/ops/read.c | 6 +- unit-tests/integer-allocation.sh | 4 +- 11 files changed, 134 insertions(+), 96 deletions(-) delete mode 100644 src/arith/bignum.c delete mode 100644 src/arith/bignum.h diff --git a/src/arith/bignum.c b/src/arith/bignum.c deleted file mode 100644 index a21a7df..0000000 --- a/src/arith/bignum.c +++ /dev/null @@ -1,14 +0,0 @@ -/* - * bignum.c - * - * Allocation of and operations on arbitrary precision integers. - * - * (c) 2018 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -/* - * Bignums generally follow Knuth, vol 2, 4.3. The word size is 64 bits, - * and words are stored in individual cons-space objects, comprising the - * word itself and a pointer to the next word in the number. - */ diff --git a/src/arith/bignum.h b/src/arith/bignum.h deleted file mode 100644 index 05c9073..0000000 --- a/src/arith/bignum.h +++ /dev/null @@ -1,16 +0,0 @@ -/** - * bignum.h - * - * functions for bignum cells. - * - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __bignum_h -#define __bignum_h - - - -#endif diff --git a/src/arith/integer.c b/src/arith/integer.c index 5239746..7b14d22 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -8,8 +8,10 @@ */ #define _GNU_SOURCE +#include #include #include +#include #include "conspage.h" #include "consspaceobject.h" @@ -17,31 +19,109 @@ /** * return the numeric value of this cell, as a C primitive double, not - * as a cons-space object. Cell may in principle be any kind of number, - * but only integers and reals are so far implemented. + * as a cons-space object. Cell may in principle be any kind of number. */ long double numeric_value( struct cons_pointer pointer ) { - long double result = NAN; - struct cons_space_object *cell = &pointer2cell( pointer ); + long double result = NAN; + struct cons_space_object *cell = &pointer2cell( pointer ); - if ( integerp( pointer ) ) { - result = cell->payload.integer.value * 1.0; - } else if ( realp( pointer ) ) { - result = cell->payload.real.value; + switch (cell->tag.value) { + case INTEGERTV: + result = 1.0; + while (cell->tag.value == INTEGERTV) { + result = (result * LONG_MAX * cell->payload.integer.value); + cell = &pointer2cell(cell->payload.integer.more); } + break; + case RATIOTV: + result = numeric_value(cell->payload.ratio.dividend) / + numeric_value(cell->payload.ratio.divisor); + break; + case REALTV: + result = cell->payload.real.value; + break; + // default is NAN + } - return result; + return result; } /** * Allocate an integer cell representing this value and return a cons pointer to it. */ -struct cons_pointer make_integer( int64_t value ) { - struct cons_pointer result = allocate_cell( INTEGERTAG ); +struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { + struct cons_pointer result = NIL; + + if (integerp(more) || nilp(more)) { + result = allocate_cell( INTEGERTAG ); struct cons_space_object *cell = &pointer2cell( result ); cell->payload.integer.value = value; + cell->payload.integer.more = more; debug_dump_object( result, DEBUG_ARITH ); + } - return result; + 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) { + struct cons_pointer result = NIL; + int64_t carry = 0; + + if (integerp(a) && integerp(b)) { + while (!nilp(a) || !nilp(b) || carry != 0) { + int64_t av = integerp(a) ? pointer2cell(a).payload.integer.value : 0; + int64_t bv = integerp(b) ? pointer2cell(b).payload.integer.value : 0; + + __int128_t rv = av + bv + carry; + + if (rv > LONG_MAX || rv < LONG_MIN) { + carry = llabs(rv / LONG_MAX); + rv = rv % LONG_MAX; + } else { + carry = 0; + } + + result = make_integer( rv, result); + a = pointer2cell(a).payload.integer.more; + b = pointer2cell(b).payload.integer.more; + } + } + + return result; +} + +/** + * 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; + int64_t carry = 0; + + if (integerp(a) && integerp(b)) { + while (!nilp(a) || ! nilp(b) || carry != 0) { + int64_t av = integerp(a) ? pointer2cell(a).payload.integer.value : 1; + int64_t bv = integerp(b) ? pointer2cell(b).payload.integer.value : 1; + + __int128_t rv = (av * bv) + carry; + + if (rv > LONG_MAX || rv < LONG_MIN) { + carry = llabs(rv / LONG_MAX); + rv = rv % LONG_MAX; + } else { + carry = 0; + } + + result = make_integer( rv, result); + a = pointer2cell(a).payload.integer.more; + b = pointer2cell(b).payload.integer.more; + } + } + + return result; } diff --git a/src/arith/integer.h b/src/arith/integer.h index 00b94a6..9f9b984 100644 --- a/src/arith/integer.h +++ b/src/arith/integer.h @@ -16,6 +16,10 @@ long double numeric_value( struct cons_pointer pointer ); /** * Allocate an integer cell representing this value and return a cons pointer to it. */ -struct cons_pointer make_integer( int64_t value ); +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 multiply_integers( struct cons_pointer a, struct cons_pointer b); #endif diff --git a/src/arith/peano.c b/src/arith/peano.c index a52f314..56c2190 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -152,8 +152,7 @@ struct cons_pointer add_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV: - result = make_integer( cell1.payload.integer.value + - cell2.payload.integer.value ); + result = add_integers( arg1, arg2 ); break; case RATIOTV: result = @@ -224,7 +223,7 @@ struct cons_pointer add_2( struct stack_frame *frame, 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 ); + struct cons_pointer result = make_integer( 0, NIL ); struct cons_pointer tmp; for ( int i = 0; @@ -285,8 +284,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV: - result = make_integer( cell1.payload.integer.value * - cell2.payload.integer.value ); + result = multiply_integers( arg1, arg2 ); break; case RATIOTV: result = @@ -361,7 +359,7 @@ 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 ); + struct cons_pointer result = make_integer( 1, NIL ); struct cons_pointer tmp; for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ) @@ -404,7 +402,8 @@ struct cons_pointer inverse( struct cons_pointer frame, result = arg; break; case INTEGERTV: - result = make_integer( 0 - to_long_int( arg ) ); + // TODO: bignums + result = make_integer( 0 - to_long_int( arg ), NIL ); break; case NILTV: result = TRUE; @@ -413,7 +412,7 @@ struct cons_pointer inverse( struct cons_pointer frame, result = make_ratio( frame, make_integer( 0 - to_long_int( cell.payload.ratio. - dividend ) ), + dividend ), NIL ), cell.payload.ratio.divisor ); break; case REALTV: @@ -453,12 +452,12 @@ struct cons_pointer lisp_subtract( struct break; case INTEGERTV: result = make_integer( cell0.payload.integer.value - - cell1.payload.integer.value ); + - cell1.payload.integer.value, NIL ); break; case RATIOTV:{ struct cons_pointer tmp = make_ratio( frame_pointer, frame->arg[0], - make_integer( 1 ) ); + make_integer( 1, NIL ) ); inc_ref( tmp ); result = subtract_ratio_ratio( frame_pointer, tmp, @@ -486,7 +485,7 @@ struct cons_pointer lisp_subtract( struct case INTEGERTV:{ struct cons_pointer tmp = make_ratio( frame_pointer, frame->arg[1], - make_integer( 1 ) ); + make_integer( 1, NIL ) ); inc_ref( tmp ); result = subtract_ratio_ratio( frame_pointer, frame->arg[0], @@ -564,7 +563,7 @@ struct cons_pointer lisp_divide( struct } break; case RATIOTV:{ - struct cons_pointer one = make_integer( 1 ); + struct cons_pointer one = make_integer( 1, NIL ); struct cons_pointer ratio = make_ratio( frame_pointer, frame->arg[0], one ); inc_ref( ratio ); @@ -592,7 +591,7 @@ struct cons_pointer lisp_divide( struct result = frame->arg[1]; break; case INTEGERTV:{ - struct cons_pointer one = make_integer( 1 ); + struct cons_pointer one = make_integer( 1, NIL ); inc_ref( one ); struct cons_pointer ratio = make_ratio( frame_pointer, frame->arg[1], one ); diff --git a/src/arith/ratio.c b/src/arith/ratio.c index 31dd0a2..7b587e1 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -68,11 +68,11 @@ struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, if ( gcd > 1 ) { if ( drrv / gcd == 1 ) { - result = make_integer( ddrv / gcd ); + result = make_integer( ddrv / gcd , NIL); } else { result = - make_ratio( frame_pointer, make_integer( ddrv / gcd ), - make_integer( drrv / gcd ) ); + make_ratio( frame_pointer, make_integer( ddrv / gcd , NIL), + make_integer( drrv / gcd , NIL) ); } } } else { @@ -106,6 +106,7 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, if ( ratiop( arg1 ) && ratiop( arg2 ) ) { struct cons_space_object cell1 = pointer2cell( arg1 ); struct cons_space_object cell2 = pointer2cell( arg2 ); + // TODO: to be entirely reworked for bignums. All vars must be lisp integers. int64_t dd1v = pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value, dd2v = @@ -122,13 +123,13 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, if ( dr1v == dr2v ) { r = make_ratio( frame_pointer, - make_integer( dd1v + dd2v ), + make_integer( dd1v + dd2v, NIL ), cell1.payload.ratio.divisor ); } else { - struct cons_pointer dd1vm = make_integer( dd1v * m1 ), - dr1vm = make_integer( dr1v * m1 ), - dd2vm = make_integer( dd2v * m2 ), - dr2vm = make_integer( dr2v * m2 ), + 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 ); @@ -173,7 +174,7 @@ struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, struct cons_pointer result; if ( integerp( intarg ) && ratiop( ratarg ) ) { - struct cons_pointer one = make_integer( 1 ), + struct cons_pointer one = make_integer( 1, NIL ), ratio = make_ratio( frame_pointer, intarg, one ); result = add_ratio_ratio( frame_pointer, ratio, ratarg ); @@ -243,8 +244,8 @@ 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 ), - make_integer( drrv ) ); + make_ratio( frame_pointer, make_integer( ddrv, NIL ), + make_integer( drrv , NIL) ); result = simplify_ratio( frame_pointer, unsimplified ); if ( !eq( unsimplified, result ) ) { @@ -271,7 +272,7 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, struct cons_pointer result; if ( integerp( intarg ) && ratiop( ratarg ) ) { - struct cons_pointer one = make_integer( 1 ), + struct cons_pointer one = make_integer( 1, NIL), ratio = make_ratio( frame_pointer, intarg, one ); result = multiply_ratio_ratio( frame_pointer, ratio, ratarg ); diff --git a/src/memory/conspage.c b/src/memory/conspage.c index eee6d2d..975c9da 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -150,6 +150,9 @@ void free_cell( struct cons_pointer pointer ) { case FUNCTIONTV: dec_ref( cell->payload.function.source ); break; + case INTEGERTV: + dec_ref( cell->payload.integer.more); + break; case LAMBDATV: case NLAMBDATV: dec_ref( cell->payload.lambda.args ); diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 523fdaa..0cf44a7 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -29,12 +29,6 @@ * tag values, all of which must be 4 bytes. Must not collide with vector space tag values */ -/** - * A word within a bignum - arbitrary precision integer. - */ -#define BIGNUMTAG "BIGN" -#define BIGNUMTV 1313294658 - /** * An ordinary cons cell: 1397641027 */ @@ -168,11 +162,6 @@ */ #define nilp(conspoint) (check_tag(conspoint,NILTAG)) -/** - * true if conspointer points to a cons cell, else false - */ -#define bignump(conspoint) (check_tag(conspoint,BIGNUMTAG)) - /** * true if conspointer points to a cons cell, else false */ @@ -289,16 +278,6 @@ struct stack_frame { int args; }; -/** - * payload of a bignum cell. Intentionally similar to an integer payload, but - * with a next pointer. - */ -struct bignum_payload { - int64_t value; - struct cons_pointer next; -}; - - /** * payload of a cons cell. */ @@ -348,6 +327,7 @@ struct free_payload { */ struct integer_payload { int64_t value; + struct cons_pointer more; }; /** diff --git a/src/ops/equal.c b/src/ops/equal.c index ebb085e..877a8cc 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -85,8 +85,9 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { break; case INTEGERTV: result = - cell_a->payload.integer.value == - cell_b->payload.integer.value; + (cell_a->payload.integer.value == + cell_b->payload.integer.value) && + equal(cell_a->payload.integer.more, cell_b->payload.integer.more); break; case REALTV: { diff --git a/src/ops/read.c b/src/ops/read.c index 69de893..2a8522c 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -220,13 +220,13 @@ struct cons_pointer read_number( struct stack_frame *frame, result = make_real( rv ); } else if ( dividend != 0 ) { result = - make_ratio( frame_pointer, make_integer( dividend ), - make_integer( accumulator ) ); + make_ratio( frame_pointer, make_integer( dividend, NIL ), + make_integer( accumulator, NIL ) ); } else { if ( negative ) { accumulator = 0 - accumulator; } - result = make_integer( accumulator ); + result = make_integer( accumulator, NIL ); } debug_print( L"read_number returning\n", DEBUG_IO ); diff --git a/unit-tests/integer-allocation.sh b/unit-tests/integer-allocation.sh index 5d07d90..ced92f2 100644 --- a/unit-tests/integer-allocation.sh +++ b/unit-tests/integer-allocation.sh @@ -1,8 +1,8 @@ #!/bin/bash value=354 -expected="Integer cell: value ${value}" -echo ${value} | target/psse -d 2>&1 | grep "${expected}" > /dev/null +expected="Integer cell: value ${value}," +echo ${value} | target/psse -v5 2>&1 | grep "${expected}" > /dev/null if [ $? -eq 0 ] then From 489f0080447c5399dacb1aa8110f867e80b9c21d Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 29 Dec 2018 23:44:28 +0000 Subject: [PATCH 02/40] Printing of bignums basically done, not tested. --- src/arith/integer.c | 198 ++++++++++++++++++++++++++------------- src/arith/integer.h | 9 +- src/arith/peano.c | 8 +- src/arith/ratio.c | 28 +++--- src/init.c | 44 ++++----- src/memory/conspage.c | 6 +- src/memory/dump.c | 8 +- src/memory/stack.c | 4 +- src/memory/vectorspace.c | 2 +- src/ops/equal.c | 11 ++- src/ops/intern.c | 4 +- src/ops/lispops.c | 30 +++--- src/ops/print.c | 48 +++++----- src/repl.c | 8 +- 14 files changed, 244 insertions(+), 164 deletions(-) diff --git a/src/arith/integer.c b/src/arith/integer.c index 7b14d22..be50013 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -12,116 +12,182 @@ #include #include #include +/* + * wide characters + */ +#include +#include #include "conspage.h" #include "consspaceobject.h" #include "debug.h" +/** + * hexadecimal digits for printing numbers. + */ +const wchar_t *hex_digits = L"0123456789ABCDEF"; + +/* + * Doctrine from here on in is that ALL integers are bignums, it's just + * that integers less than 65 bits are bignums of one cell only. + * + * TODO: I have no idea at all how I'm going to print bignums! + */ + /** * return the numeric value of this cell, as a C primitive double, not * as a cons-space object. Cell may in principle be any kind of number. */ long double numeric_value( struct cons_pointer pointer ) { - long double result = NAN; - struct cons_space_object *cell = &pointer2cell( pointer ); + long double result = NAN; + struct cons_space_object *cell = &pointer2cell( pointer ); - switch (cell->tag.value) { - case INTEGERTV: - result = 1.0; - while (cell->tag.value == INTEGERTV) { - result = (result * LONG_MAX * cell->payload.integer.value); - cell = &pointer2cell(cell->payload.integer.more); + switch ( cell->tag.value ) { + case INTEGERTV: + result = 1.0; + while ( cell->tag.value == INTEGERTV ) { + result = ( result * LONG_MAX * cell->payload.integer.value ); + cell = &pointer2cell( cell->payload.integer.more ); + } + break; + case RATIOTV: + result = numeric_value( cell->payload.ratio.dividend ) / + numeric_value( cell->payload.ratio.divisor ); + break; + case REALTV: + result = cell->payload.real.value; + break; + // default is NAN } - break; - case RATIOTV: - result = numeric_value(cell->payload.ratio.dividend) / - numeric_value(cell->payload.ratio.divisor); - break; - case REALTV: - result = cell->payload.real.value; - break; - // default is NAN - } - return result; + return result; } /** * Allocate an integer cell representing this value and return a cons pointer to it. */ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { - struct cons_pointer result = NIL; + struct cons_pointer result = NIL; - if (integerp(more) || nilp(more)) { - result = allocate_cell( INTEGERTAG ); - struct cons_space_object *cell = &pointer2cell( result ); - cell->payload.integer.value = value; - cell->payload.integer.more = more; + if ( integerp( more ) || nilp( more ) ) { + result = allocate_cell( INTEGERTAG ); + struct cons_space_object *cell = &pointer2cell( result ); + cell->payload.integer.value = value; + cell->payload.integer.more = more; - debug_dump_object( result, DEBUG_ARITH ); - } + debug_dump_object( result, DEBUG_ARITH ); + } - return result; + 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) { - struct cons_pointer result = NIL; - int64_t carry = 0; +struct cons_pointer add_integers( struct cons_pointer a, + struct cons_pointer b ) { + struct cons_pointer result = NIL; + int64_t carry = 0; - if (integerp(a) && integerp(b)) { - while (!nilp(a) || !nilp(b) || carry != 0) { - int64_t av = integerp(a) ? pointer2cell(a).payload.integer.value : 0; - int64_t bv = integerp(b) ? pointer2cell(b).payload.integer.value : 0; + if ( integerp( a ) && integerp( b ) ) { + while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { + int64_t av = + integerp( a ) ? pointer2cell( a ).payload.integer.value : 0; + int64_t bv = + integerp( b ) ? pointer2cell( b ).payload.integer.value : 0; - __int128_t rv = av + bv + carry; + __int128_t rv = av + bv + carry; - if (rv > LONG_MAX || rv < LONG_MIN) { - carry = llabs(rv / LONG_MAX); - rv = rv % LONG_MAX; - } else { - carry = 0; - } + if ( rv > LONG_MAX || rv < LONG_MIN ) { + carry = llabs( rv / LONG_MAX ); + rv = rv % LONG_MAX; + } else { + carry = 0; + } - result = make_integer( rv, result); - a = pointer2cell(a).payload.integer.more; - b = pointer2cell(b).payload.integer.more; + result = make_integer( rv, result ); + a = pointer2cell( a ).payload.integer.more; + b = pointer2cell( b ).payload.integer.more; + } } - } - return result; + return result; } /** * 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; - int64_t carry = 0; +struct cons_pointer multiply_integers( struct cons_pointer a, + struct cons_pointer b ) { + struct cons_pointer result = NIL; + int64_t carry = 0; - if (integerp(a) && integerp(b)) { - while (!nilp(a) || ! nilp(b) || carry != 0) { - int64_t av = integerp(a) ? pointer2cell(a).payload.integer.value : 1; - int64_t bv = integerp(b) ? pointer2cell(b).payload.integer.value : 1; + if ( integerp( a ) && integerp( b ) ) { + while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { + int64_t av = + integerp( a ) ? pointer2cell( a ).payload.integer.value : 1; + int64_t bv = + integerp( b ) ? pointer2cell( b ).payload.integer.value : 1; - __int128_t rv = (av * bv) + carry; + __int128_t rv = ( av * bv ) + carry; - if (rv > LONG_MAX || rv < LONG_MIN) { - carry = llabs(rv / LONG_MAX); - rv = rv % LONG_MAX; - } else { - carry = 0; - } + if ( rv > LONG_MAX || rv < LONG_MIN ) { + carry = llabs( rv / LONG_MAX ); + rv = rv % LONG_MAX; + } else { + carry = 0; + } - result = make_integer( rv, result); - a = pointer2cell(a).payload.integer.more; - b = pointer2cell(b).payload.integer.more; + result = make_integer( rv, result ); + a = pointer2cell( a ).payload.integer.more; + b = pointer2cell( b ).payload.integer.more; + } } - } - return result; + return result; +} + +/** + * 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. + */ +struct cons_pointer integer_to_string( struct cons_pointer int_pointer, + int base ) { + struct cons_pointer result = NIL; + struct cons_space_object integer = pointer2cell( int_pointer ); + int64_t accumulator = integer.payload.integer.value; + bool is_negative = accumulator < 0; + accumulator = llabs( accumulator ); + + while ( accumulator > 0 ) { + while ( accumulator > base ) { + result = make_string( hex_digits[accumulator % base], result ); + accumulator = accumulator / base; + } + + if ( integerp( integer.payload.integer.more ) ) { + integer = pointer2cell( integer.payload.integer.more ); + int64_t i = integer.payload.integer.value; + + /* TODO: I don't believe it's as simple as this! */ + accumulator += ( base * ( i % base ) ); + result = make_string( hex_digits[accumulator % base], result ); + accumulator += ( base * ( i / base ) ); + } + } + + if ( is_negative ) { + result = make_string( L'-', result ); + } + + return result; } diff --git a/src/arith/integer.h b/src/arith/integer.h index 9f9b984..1eda28f 100644 --- a/src/arith/integer.h +++ b/src/arith/integer.h @@ -18,8 +18,13 @@ long double numeric_value( struct cons_pointer pointer ); */ 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 ); #endif diff --git a/src/arith/peano.c b/src/arith/peano.c index 56c2190..3fb732a 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -411,8 +411,9 @@ struct cons_pointer inverse( struct cons_pointer frame, case RATIOTV: result = make_ratio( frame, make_integer( 0 - - to_long_int( cell.payload.ratio. - dividend ), NIL ), + to_long_int( cell.payload. + ratio.dividend ), + NIL ), cell.payload.ratio.divisor ); break; case REALTV: @@ -452,7 +453,8 @@ struct cons_pointer lisp_subtract( struct break; case INTEGERTV: result = make_integer( cell0.payload.integer.value - - cell1.payload.integer.value, NIL ); + - cell1.payload.integer.value, + NIL ); break; case RATIOTV:{ struct cons_pointer tmp = diff --git a/src/arith/ratio.c b/src/arith/ratio.c index 7b587e1..95c9a8f 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -61,18 +61,18 @@ struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, 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 ); + 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 ( gcd > 1 ) { if ( drrv / gcd == 1 ) { - result = make_integer( ddrv / gcd , NIL); + result = make_integer( ddrv / gcd, NIL ); } else { result = - make_ratio( frame_pointer, make_integer( ddrv / gcd , NIL), - make_integer( drrv / gcd , NIL) ); + make_ratio( frame_pointer, make_integer( ddrv / gcd, NIL ), + make_integer( drrv / gcd, NIL ) ); } } } else { @@ -106,7 +106,7 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, if ( ratiop( arg1 ) && ratiop( arg2 ) ) { struct cons_space_object cell1 = pointer2cell( arg1 ); struct cons_space_object cell2 = pointer2cell( arg2 ); - // TODO: to be entirely reworked for bignums. All vars must be lisp integers. + // TODO: to be entirely reworked for bignums. All vars must be lisp integers. int64_t dd1v = pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value, dd2v = @@ -203,10 +203,10 @@ struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg1, struct cons_pointer arg2 ) { struct cons_pointer i = make_ratio( frame_pointer, - pointer2cell( arg2 ).payload.ratio. - divisor, - pointer2cell( arg2 ).payload.ratio. - dividend ), result = + pointer2cell( arg2 ).payload. + ratio.divisor, + pointer2cell( arg2 ).payload. + ratio.dividend ), result = multiply_ratio_ratio( frame_pointer, arg1, i ); dec_ref( i ); @@ -245,7 +245,7 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str struct cons_pointer unsimplified = make_ratio( frame_pointer, make_integer( ddrv, NIL ), - make_integer( drrv , NIL) ); + make_integer( drrv, NIL ) ); result = simplify_ratio( frame_pointer, unsimplified ); if ( !eq( unsimplified, result ) ) { @@ -272,7 +272,7 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, struct cons_pointer result; if ( integerp( intarg ) && ratiop( ratarg ) ) { - struct cons_pointer one = make_integer( 1, NIL), + struct cons_pointer one = make_integer( 1, NIL ), ratio = make_ratio( frame_pointer, intarg, one ); result = multiply_ratio_ratio( frame_pointer, ratio, ratarg ); diff --git a/src/init.c b/src/init.c index 9cbe701..773afb5 100644 --- a/src/init.c +++ b/src/init.c @@ -30,35 +30,35 @@ void bind_function( wchar_t *name, struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ) ) { - struct cons_pointer n = c_string_to_lisp_symbol( name ); - inc_ref(n); + struct cons_pointer n = c_string_to_lisp_symbol( name ); + inc_ref( n ); - /* TODO: where a function is not compiled from source, we could cache - * the name on the source pointer. Would make stack frames potentially - * more readable and aid debugging generally. */ + /* TODO: where a function is not compiled from source, we could cache + * the name on the source pointer. Would make stack frames potentially + * more readable and aid debugging generally. */ deep_bind( n, make_function( NIL, executable ) ); - dec_ref(n); + dec_ref( n ); } void bind_special( wchar_t *name, struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ) ) { - struct cons_pointer n = c_string_to_lisp_symbol( name ); - inc_ref(n); + struct cons_pointer n = c_string_to_lisp_symbol( name ); + inc_ref( n ); - deep_bind( n, make_special( NIL, executable ) ); + deep_bind( n, make_special( NIL, executable ) ); - dec_ref(n); + dec_ref( n ); } -void bind_value( wchar_t *name, struct cons_pointer value) { - struct cons_pointer n = c_string_to_lisp_symbol( name ); - inc_ref(n); +void bind_value( wchar_t *name, struct cons_pointer value ) { + struct cons_pointer n = c_string_to_lisp_symbol( name ); + inc_ref( n ); - deep_bind( n, value ); + deep_bind( n, value ); - dec_ref(n); + dec_ref( n ); } int main( int argc, char *argv[] ) { @@ -107,8 +107,8 @@ int main( int argc, char *argv[] ) { /* * privileged variables (keywords) */ - bind_value( L"nil" , NIL ); - bind_value( L"t" , TRUE ); + bind_value( L"nil", NIL ); + bind_value( L"t", TRUE ); /* * primitive function operations @@ -153,14 +153,14 @@ int main( int argc, char *argv[] ) { bind_special( L"quote", &lisp_quote ); bind_special( L"set!", &lisp_set_shriek ); - debug_print(L"Initialised oblist\n", DEBUG_BOOTSTRAP); - debug_dump_object(oblist, DEBUG_BOOTSTRAP); + debug_print( L"Initialised oblist\n", DEBUG_BOOTSTRAP ); + debug_dump_object( oblist, DEBUG_BOOTSTRAP ); repl( stdin, stdout, stderr, show_prompt ); - debug_print(L"Freeing oblist\n", DEBUG_BOOTSTRAP); - dec_ref(oblist); - debug_dump_object(oblist, DEBUG_BOOTSTRAP); + debug_print( L"Freeing oblist\n", DEBUG_BOOTSTRAP ); + dec_ref( oblist ); + debug_dump_object( oblist, DEBUG_BOOTSTRAP ); if ( dump_at_end ) { diff --git a/src/memory/conspage.c b/src/memory/conspage.c index 975c9da..2aa8dce 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -151,7 +151,7 @@ void free_cell( struct cons_pointer pointer ) { dec_ref( cell->payload.function.source ); break; case INTEGERTV: - dec_ref( cell->payload.integer.more); + dec_ref( cell->payload.integer.more ); break; case LAMBDATV: case NLAMBDATV: @@ -179,8 +179,8 @@ void free_cell( struct cons_pointer pointer ) { switch ( vso->header.tag.value ) { case STACKFRAMETV: - free_stack_frame(get_stack_frame(pointer)); - break; + free_stack_frame( get_stack_frame( pointer ) ); + break; } free( ( void * ) cell->payload.vectorp.address ); diff --git a/src/memory/dump.c b/src/memory/dump.c index d3a53d3..6601e92 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -103,10 +103,10 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { case RATIOTV: fwprintf( output, L"\t\tRational cell: value %ld/%ld, count %u\n", - pointer2cell( cell.payload.ratio.dividend ).payload. - integer.value, - pointer2cell( cell.payload.ratio.divisor ).payload. - integer.value, cell.count ); + pointer2cell( cell.payload.ratio.dividend ). + payload.integer.value, + pointer2cell( cell.payload.ratio.divisor ). + payload.integer.value, cell.count ); break; case READTV: fwprintf( output, L"\t\tInput stream\n" ); diff --git a/src/memory/stack.c b/src/memory/stack.c index da4c17d..a1026b4 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -222,14 +222,14 @@ void free_stack_frame( struct stack_frame *frame ) { /* * TODO: later, push it back on the stack-frame freelist */ - debug_print(L"Entering free_stack_frame\n", DEBUG_ALLOC); + debug_print( L"Entering free_stack_frame\n", DEBUG_ALLOC ); for ( int i = 0; i < args_in_frame; i++ ) { dec_ref( frame->arg[i] ); } if ( !nilp( frame->more ) ) { dec_ref( frame->more ); } - debug_print(L"Leaving free_stack_frame\n", DEBUG_ALLOC); + debug_print( L"Leaving free_stack_frame\n", DEBUG_ALLOC ); } diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c index cf0b1d6..5ec14a8 100644 --- a/src/memory/vectorspace.c +++ b/src/memory/vectorspace.c @@ -67,7 +67,7 @@ struct cons_pointer make_vso( char *tag, uint64_t payload_size ) { struct vector_space_object *vso = malloc( padded ); if ( vso != NULL ) { - memset(vso, 0, padded); + memset( vso, 0, padded ); debug_printf( DEBUG_ALLOC, L"make_vso: about to write tag '%s' into vso at %p\n", tag, vso ); diff --git a/src/ops/equal.c b/src/ops/equal.c index 877a8cc..bade594 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -80,14 +80,15 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { && ( 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 ) ) ); + && 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); + ( cell_a->payload.integer.value == + cell_b->payload.integer.value ) && + equal( cell_a->payload.integer.more, + cell_b->payload.integer.more ); break; case REALTV: { diff --git a/src/ops/intern.c b/src/ops/intern.c index 29848a7..9d2387c 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -131,8 +131,8 @@ deep_bind( struct cons_pointer key, struct cons_pointer value ) { struct cons_pointer old = oblist; oblist = bind( key, value, oblist ); - inc_ref(oblist); - dec_ref(old); + inc_ref( oblist ); + dec_ref( old ); debug_print( L"Leaving deep_bind\n", DEBUG_BIND ); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index d94a2ff..c83287d 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -195,7 +195,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; debug_print( L"eval_lambda called\n", DEBUG_LAMBDA ); - debug_println(DEBUG_LAMBDA); + debug_println( DEBUG_LAMBDA ); struct cons_pointer new_env = env; struct cons_pointer names = cell.payload.lambda.args; @@ -213,7 +213,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, names = c_cdr( names ); } - inc_ref(new_env); + inc_ref( new_env ); /* TODO: if there's more than `args_in_frame` arguments, bind those too. */ } else if ( symbolp( names ) ) { @@ -233,7 +233,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, } new_env = bind( names, vals, new_env ); - inc_ref(new_env); + inc_ref( new_env ); } while ( !nilp( body ) ) { @@ -241,21 +241,22 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, body = c_cdr( body ); debug_print( L"In lambda: evaluating ", DEBUG_LAMBDA ); - debug_print_object(sexpr, DEBUG_LAMBDA); - debug_println( DEBUG_LAMBDA); + debug_print_object( sexpr, DEBUG_LAMBDA ); + debug_println( DEBUG_LAMBDA ); - /* if a result is not the terminal result in the lambda, it's a - * side effect, and needs to be GCed */ - if (!nilp(result)) dec_ref(result); + /* if a result is not the terminal result in the lambda, it's a + * side effect, and needs to be GCed */ + if ( !nilp( result ) ) + dec_ref( result ); result = eval_form( frame, frame_pointer, sexpr, new_env ); } - dec_ref(new_env); + dec_ref( new_env ); debug_print( L"eval_lambda returning: \n", DEBUG_LAMBDA ); - debug_print_object( result, DEBUG_LAMBDA); - debug_println(DEBUG_LAMBDA); + debug_print_object( result, DEBUG_LAMBDA ); + debug_println( DEBUG_LAMBDA ); return result; } @@ -352,9 +353,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, result = next_pointer; } else { result = - ( *fn_cell.payload.special. - executable ) ( get_stack_frame( next_pointer ), - next_pointer, env ); + ( *fn_cell.payload. + special.executable ) ( get_stack_frame + ( next_pointer ), + next_pointer, env ); debug_print( L"Special form returning: ", DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL ); debug_println( DEBUG_EVAL ); diff --git a/src/ops/print.c b/src/ops/print.c index 6c0c6e7..9138077 100644 --- a/src/ops/print.c +++ b/src/ops/print.c @@ -124,38 +124,42 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { case FUNCTIONTV: fwprintf( output, L"(Function)" ); break; - case INTEGERTV: - if ( print_use_colours ) { - fputws( L"\x1B[34m", output ); + case INTEGERTV:{ + struct cons_pointer s = integer_to_string( pointer, 10 ); + inc_ref( s ); + if ( print_use_colours ) { + fputws( L"\x1B[34m", output ); + } + print_string_contents( output, s ); + dec_ref( s ); } - fwprintf( output, L"%ld%", cell.payload.integer.value ); break; - case LAMBDATV: { - struct cons_pointer to_print = make_cons( c_string_to_lisp_symbol( L"lambda" ), - make_cons( cell.payload.lambda.args, - cell.payload. - lambda.body )); - inc_ref(to_print); + case LAMBDATV:{ + struct cons_pointer to_print = + make_cons( c_string_to_lisp_symbol( L"lambda" ), + make_cons( cell.payload.lambda.args, + cell.payload.lambda.body ) ); + inc_ref( to_print ); - print( output, to_print ); + print( output, to_print ); - dec_ref(to_print); - } + dec_ref( to_print ); + } break; case NILTV: fwprintf( output, L"nil" ); break; - case NLAMBDATV: { - struct cons_pointer to_print = make_cons( c_string_to_lisp_symbol( L"nlambda" ), - make_cons( cell.payload.lambda.args, - cell.payload. - lambda.body )); - inc_ref(to_print); + case NLAMBDATV:{ + struct cons_pointer to_print = + make_cons( c_string_to_lisp_symbol( L"nlambda" ), + make_cons( cell.payload.lambda.args, + cell.payload.lambda.body ) ); + inc_ref( to_print ); - print( output, to_print ); + print( output, to_print ); - dec_ref(to_print); - } + dec_ref( to_print ); + } break; case RATIOTV: print( output, cell.payload.ratio.dividend ); diff --git a/src/repl.c b/src/repl.c index d07df94..99f41f8 100644 --- a/src/repl.c +++ b/src/repl.c @@ -113,16 +113,16 @@ repl( FILE * in_stream, FILE * out_stream, FILE * error_stream, break; } else { struct cons_pointer val = repl_eval( input ); - inc_ref(val); + inc_ref( val ); repl_print( output_stream, val ); - dec_ref(val); + dec_ref( val ); } dec_ref( input ); } - dec_ref(input_stream); - dec_ref(output_stream); + dec_ref( input_stream ); + dec_ref( output_stream ); debug_print( L"Leaving repl\n", DEBUG_REPL ); } From 61573d85d914f9b5c3797fa7809ff81201e9c3b8 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 30 Dec 2018 11:10:14 +0000 Subject: [PATCH 03/40] /all-integers-are-bignums: broken, but I don't know why. --- src/arith/integer.c | 10 ++++++++++ src/arith/peano.c | 11 +++++------ src/memory/dump.c | 4 ++++ 3 files changed, 19 insertions(+), 6 deletions(-) diff --git a/src/arith/integer.c b/src/arith/integer.c index be50013..29e536e 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -125,6 +125,12 @@ struct cons_pointer multiply_integers( struct cons_pointer a, int64_t carry = 0; if ( integerp( a ) && integerp( b ) ) { + debug_print(L"multiply_integers: ", DEBUG_ARITH); + debug_print_object(a, DEBUG_ARITH); + debug_print(L" x ", DEBUG_ARITH); + debug_print_object(b, DEBUG_ARITH); + debug_println(DEBUG_ARITH); + while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { int64_t av = integerp( a ) ? pointer2cell( a ).payload.integer.value : 1; @@ -134,6 +140,7 @@ struct cons_pointer multiply_integers( struct cons_pointer a, __int128_t rv = ( av * bv ) + carry; if ( rv > LONG_MAX || rv < LONG_MIN ) { + debug_printf( DEBUG_ARITH, L"multiply_integers: 64 bit overflow; setting carry to %ld\n", carry); carry = llabs( rv / LONG_MAX ); rv = rv % LONG_MAX; } else { @@ -145,6 +152,9 @@ struct cons_pointer multiply_integers( struct cons_pointer a, b = pointer2cell( b ).payload.integer.more; } } + debug_print(L"multiply_integers returning: ", DEBUG_ARITH); + debug_print_object(result, DEBUG_ARITH); + debug_println(DEBUG_ARITH); return result; } diff --git a/src/arith/peano.c b/src/arith/peano.c index 3fb732a..2a9fb7f 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -284,7 +284,8 @@ struct cons_pointer multiply_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV: - result = multiply_integers( arg1, arg2 ); + result = make_integer(cell1.payload.integer.value * cell2.payload.integer.value, NIL); + //result = multiply_integers( arg1, arg2 ); break; case RATIOTV: result = @@ -411,9 +412,8 @@ struct cons_pointer inverse( struct cons_pointer frame, case RATIOTV: result = make_ratio( frame, make_integer( 0 - - to_long_int( cell.payload. - ratio.dividend ), - NIL ), + to_long_int( cell.payload.ratio. + dividend ), NIL ), cell.payload.ratio.divisor ); break; case REALTV: @@ -453,8 +453,7 @@ struct cons_pointer lisp_subtract( struct break; case INTEGERTV: result = make_integer( cell0.payload.integer.value - - cell1.payload.integer.value, - NIL ); + - cell1.payload.integer.value, NIL ); break; case RATIOTV:{ struct cons_pointer tmp = diff --git a/src/memory/dump.c b/src/memory/dump.c index 6601e92..24fd955 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -83,6 +83,10 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { fwprintf( output, L"\t\tInteger cell: value %ld, count %u\n", cell.payload.integer.value, cell.count ); + if (!nilp(cell.payload.integer.more)) { + fputws( L"\t\tBIGNUM! More at\n:", output); + dump_object(output, cell.payload.integer.more); + } break; case LAMBDATV: fwprintf( output, L"\t\tLambda cell;\n\t\t args: " ); From 47f4b4c7f79da807a6f45366398b28a9132403bd Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 30 Dec 2018 12:07:38 +0000 Subject: [PATCH 04/40] Bug was in integer_to_string; all tests now pass. --- src/arith/integer.c | 38 +++++++++++++++++++++++++++++++------- 1 file changed, 31 insertions(+), 7 deletions(-) diff --git a/src/arith/integer.c b/src/arith/integer.c index 29e536e..176b09e 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -25,7 +25,7 @@ /** * hexadecimal digits for printing numbers. */ -const wchar_t *hex_digits = L"0123456789ABCDEF"; +const wchar_t hex_digits[16] = L"0123456789ABCDEF"; /* * Doctrine from here on in is that ALL integers are bignums, it's just @@ -68,6 +68,7 @@ long double numeric_value( struct cons_pointer pointer ) { */ 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_ARITH); if ( integerp( more ) || nilp( more ) ) { result = allocate_cell( INTEGERTAG ); @@ -75,9 +76,10 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { cell->payload.integer.value = value; cell->payload.integer.more = more; - debug_dump_object( result, DEBUG_ARITH ); } + debug_print(L"make_integer: returning\n", DEBUG_ARITH); + debug_dump_object( result, DEBUG_ARITH ); return result; } @@ -87,11 +89,19 @@ 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 ) { + debug_print(L"Entering add_integers\n", DEBUG_ARITH); + struct cons_pointer result = NIL; int64_t carry = 0; if ( integerp( a ) && integerp( b ) ) { - while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { + while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { + debug_print(L"add_integers: ", DEBUG_ARITH); + debug_print_object(a, DEBUG_ARITH); + debug_print(L" x ", DEBUG_ARITH); + debug_print_object(b, DEBUG_ARITH); + debug_printf(DEBUG_ARITH, L"; carry = %ld\n", carry); + int64_t av = integerp( a ) ? pointer2cell( a ).payload.integer.value : 0; int64_t bv = @@ -100,6 +110,7 @@ struct cons_pointer add_integers( struct cons_pointer a, __int128_t rv = av + bv + carry; if ( rv > LONG_MAX || rv < LONG_MIN ) { + debug_printf( DEBUG_ARITH, L"add_integers: 64 bit overflow; setting carry to %ld\n", carry); carry = llabs( rv / LONG_MAX ); rv = rv % LONG_MAX; } else { @@ -111,6 +122,9 @@ struct cons_pointer add_integers( struct cons_pointer a, b = pointer2cell( b ).payload.integer.more; } } + debug_print(L"add_integers returning: ", DEBUG_ARITH); + debug_print_object(result, DEBUG_ARITH); + debug_println(DEBUG_ARITH); return result; } @@ -178,11 +192,20 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, bool is_negative = accumulator < 0; accumulator = llabs( accumulator ); + if (accumulator == 0) { + result = c_string_to_lisp_string( L"0"); + } else { while ( accumulator > 0 ) { - while ( accumulator > base ) { - result = make_string( hex_digits[accumulator % base], result ); + debug_printf(DEBUG_ARITH, L"integer_to_string: accumulator is %ld\n:", + accumulator); + do { + debug_printf(DEBUG_ARITH, L"integer_to_string: digit is %ld, hexadecimal is %lc\n:", + accumulator % base, hex_digits[accumulator % base]); + wint_t digit = (wint_t)hex_digits[accumulator % base]; + + result = make_string( (wint_t)hex_digits[accumulator % base], result ); accumulator = accumulator / base; - } + } while ( accumulator > base ); if ( integerp( integer.payload.integer.more ) ) { integer = pointer2cell( integer.payload.integer.more ); @@ -190,7 +213,7 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, /* TODO: I don't believe it's as simple as this! */ accumulator += ( base * ( i % base ) ); - result = make_string( hex_digits[accumulator % base], result ); + result = make_string( (wint_t)hex_digits[accumulator % base], result ); accumulator += ( base * ( i / base ) ); } } @@ -198,6 +221,7 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, if ( is_negative ) { result = make_string( L'-', result ); } + } return result; } From 02fe5669d8ccaa1907e48acce8d8506c10e49d08 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 30 Dec 2018 17:56:15 +0000 Subject: [PATCH 05/40] Complete reworking of the REPL which is good in itself, but not what I was meant to be working on. --- Makefile | 4 +- lisp/expt.lisp | 6 + lisp/types.lisp | 24 +++ src/arith/integer.c | 105 ++++++------ src/arith/peano.c | 12 +- src/arith/ratio.c | 16 +- src/init.c | 29 +++- src/memory/dump.c | 14 +- src/ops/equal.c | 4 +- src/ops/lispops.c | 268 +++++++++++++++++++++++++------ src/ops/lispops.h | 4 + src/ops/print.c | 4 + src/ops/print.h | 1 + src/repl.c | 108 ++----------- src/repl.h | 7 +- unit-tests/add.sh | 10 +- unit-tests/apply.sh | 2 +- unit-tests/complex-list.sh | 2 +- unit-tests/cond.sh | 4 +- unit-tests/empty-list.sh | 4 +- unit-tests/empty-string.sh | 2 +- unit-tests/eval-integer.sh | 2 +- unit-tests/eval-quote-sexpr.sh | 2 +- unit-tests/eval-quote-symbol.sh | 2 +- unit-tests/eval-real.sh | 3 +- unit-tests/eval-string.sh | 2 +- unit-tests/fred.sh | 2 +- unit-tests/integer.sh | 4 +- unit-tests/intepreter.sh | 2 +- unit-tests/lambda.sh | 5 +- unit-tests/many-args.sh | 2 +- unit-tests/multiply.sh | 4 +- unit-tests/nil.sh | 2 +- unit-tests/nlambda.sh | 2 +- unit-tests/progn.sh | 4 +- unit-tests/quote.sh | 2 +- unit-tests/quoted-list.sh | 2 +- unit-tests/ratio-addition.sh | 2 +- unit-tests/recursion.sh | 5 +- unit-tests/reverse.sh | 6 +- unit-tests/simple-list.sh | 2 +- unit-tests/string-with-spaces.sh | 2 +- unit-tests/varargs.sh | 7 +- 43 files changed, 415 insertions(+), 281 deletions(-) create mode 100644 lisp/expt.lisp create mode 100644 lisp/types.lisp diff --git a/Makefile b/Makefile index c368d50..4fe322f 100644 --- a/Makefile +++ b/Makefile @@ -15,13 +15,11 @@ INDENT_FLAGS := -nbad -bap -nbc -br -brf -brs -c33 -cd33 -ncdb -ce -ci4 -cli4 \ -d0 -di1 -nfc1 -i4 -ip0 -l75 -lp -npcs \ -npsl -nsc -nsob -nss -nut -prs -l79 -ts2 -VERSION := "0.0.2" - CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g -DDEBUG LDFLAGS := -lm $(TARGET): $(OBJS) Makefile - $(CC) $(LDFLAGS) $(OBJS) -DVERSION=$(VERSION) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS) + $(CC) $(LDFLAGS) $(OBJS) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS) doc: $(SRCS) Makefile Doxyfile doxygen diff --git a/lisp/expt.lisp b/lisp/expt.lisp new file mode 100644 index 0000000..db6a7b3 --- /dev/null +++ b/lisp/expt.lisp @@ -0,0 +1,6 @@ +(set! expt (lambda + (n x) + "Return the value of `n` raised to the `x`th power." + (cond + ((= x 1) n) + (t (* n (expt n (- x 1))))))) diff --git a/lisp/types.lisp b/lisp/types.lisp new file mode 100644 index 0000000..cba1ef6 --- /dev/null +++ b/lisp/types.lisp @@ -0,0 +1,24 @@ +(set! cons? (lambda (o) "True if o is a cons cell." (= (type o) "CONS") ) ) +(set! exception? (lambda (o) "True if o is an exception." (= (type o) "EXEP"))) +(set! free? (lambda (o) "Trus if o is a free cell - this should be impossible!" (= (type o) "FREE"))) +(set! function? (lambda (o) "True if o is a compiled function." (= (type o) "EXEP"))) +(set! integer? (lambda (o) "True if o is an integer." (= (type o) "INTR"))) +(set! lambda? (lambda (o) "True if o is an interpreted (source) function." (= (type o) "LMDA"))) +(set! nil? (lambda (o) "True if o is the canonical nil value." (= (type o) "NIL "))) +(set! nlambda? (lambda (o) "True if o is an interpreted (source) special form." (= (type o) "NLMD"))) +(set! rational? (lambda (o) "True if o is an rational number." (= (type o) "RTIO"))) +(set! read? (lambda (o) "True if o is a read stream." (= (type o) "READ") ) ) +(set! real? (lambda (o) "True if o is an real number." (= (type o) "REAL"))) +(set! special? (lambda (o) "True if o is a compiled special form." (= (type o) "SPFM") ) ) +(set! string? (lambda (o) "True if o is a string." (= (type o) "STRG") ) ) +(set! symbol? (lambda (o) "True if o is a symbol." (= (type o) "SYMB") ) ) +(set! true? (lambda (o) "True if o is the canonical true value." (= (type o) "TRUE") ) ) +(set! write? (lambda (o) "True if o is a write stream." (= (type o) "WRIT") ) ) + +(set! or (lambda values + "True if any of `values` are non-nil." + (cond ((car values) t) (t (apply 'or (cdr values)))))) + +(set! number? + (lambda (o) + "I don't yet have an `or` operator diff --git a/src/arith/integer.c b/src/arith/integer.c index 176b09e..0e74f7b 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -68,7 +68,7 @@ long double numeric_value( struct cons_pointer pointer ) { */ 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_ARITH); + debug_print( L"Entering make_integer\n", DEBUG_ARITH ); if ( integerp( more ) || nilp( more ) ) { result = allocate_cell( INTEGERTAG ); @@ -78,7 +78,7 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { } - debug_print(L"make_integer: returning\n", DEBUG_ARITH); + debug_print( L"make_integer: returning\n", DEBUG_ARITH ); debug_dump_object( result, DEBUG_ARITH ); return result; } @@ -89,18 +89,18 @@ 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 ) { - debug_print(L"Entering add_integers\n", DEBUG_ARITH); + debug_print( L"Entering add_integers\n", DEBUG_ARITH ); struct cons_pointer result = NIL; int64_t carry = 0; if ( integerp( a ) && integerp( b ) ) { - while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { - debug_print(L"add_integers: ", DEBUG_ARITH); - debug_print_object(a, DEBUG_ARITH); - debug_print(L" x ", DEBUG_ARITH); - debug_print_object(b, DEBUG_ARITH); - debug_printf(DEBUG_ARITH, L"; carry = %ld\n", carry); + while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { + debug_print( L"add_integers: ", DEBUG_ARITH ); + debug_print_object( a, DEBUG_ARITH ); + debug_print( L" x ", DEBUG_ARITH ); + debug_print_object( b, DEBUG_ARITH ); + debug_printf( DEBUG_ARITH, L"; carry = %ld\n", carry ); int64_t av = integerp( a ) ? pointer2cell( a ).payload.integer.value : 0; @@ -110,7 +110,9 @@ struct cons_pointer add_integers( struct cons_pointer a, __int128_t rv = av + bv + carry; if ( rv > LONG_MAX || rv < LONG_MIN ) { - debug_printf( DEBUG_ARITH, L"add_integers: 64 bit overflow; setting carry to %ld\n", carry); + debug_printf( DEBUG_ARITH, + L"add_integers: 64 bit overflow; setting carry to %ld\n", + carry ); carry = llabs( rv / LONG_MAX ); rv = rv % LONG_MAX; } else { @@ -122,9 +124,9 @@ struct cons_pointer add_integers( struct cons_pointer a, b = pointer2cell( b ).payload.integer.more; } } - debug_print(L"add_integers returning: ", DEBUG_ARITH); - debug_print_object(result, DEBUG_ARITH); - debug_println(DEBUG_ARITH); + debug_print( L"add_integers returning: ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); return result; } @@ -139,11 +141,11 @@ struct cons_pointer multiply_integers( struct cons_pointer a, int64_t carry = 0; if ( integerp( a ) && integerp( b ) ) { - debug_print(L"multiply_integers: ", DEBUG_ARITH); - debug_print_object(a, DEBUG_ARITH); - debug_print(L" x ", DEBUG_ARITH); - debug_print_object(b, DEBUG_ARITH); - debug_println(DEBUG_ARITH); + debug_print( L"multiply_integers: ", DEBUG_ARITH ); + debug_print_object( a, DEBUG_ARITH ); + debug_print( L" x ", DEBUG_ARITH ); + debug_print_object( b, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { int64_t av = @@ -154,7 +156,9 @@ struct cons_pointer multiply_integers( struct cons_pointer a, __int128_t rv = ( av * bv ) + carry; if ( rv > LONG_MAX || rv < LONG_MIN ) { - debug_printf( DEBUG_ARITH, L"multiply_integers: 64 bit overflow; setting carry to %ld\n", carry); + debug_printf( DEBUG_ARITH, + L"multiply_integers: 64 bit overflow; setting carry to %ld\n", + carry ); carry = llabs( rv / LONG_MAX ); rv = rv % LONG_MAX; } else { @@ -166,9 +170,9 @@ struct cons_pointer multiply_integers( struct cons_pointer a, b = pointer2cell( b ).payload.integer.more; } } - debug_print(L"multiply_integers returning: ", DEBUG_ARITH); - debug_print_object(result, DEBUG_ARITH); - debug_println(DEBUG_ARITH); + debug_print( L"multiply_integers returning: ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); return result; } @@ -192,36 +196,43 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, bool is_negative = accumulator < 0; accumulator = llabs( accumulator ); - if (accumulator == 0) { - result = c_string_to_lisp_string( L"0"); - } else { - while ( accumulator > 0 ) { - debug_printf(DEBUG_ARITH, L"integer_to_string: accumulator is %ld\n:", - accumulator); - do { - debug_printf(DEBUG_ARITH, L"integer_to_string: digit is %ld, hexadecimal is %lc\n:", - accumulator % base, hex_digits[accumulator % base]); - wint_t digit = (wint_t)hex_digits[accumulator % base]; + if ( accumulator == 0 ) { + result = c_string_to_lisp_string( L"0" ); + } else { + while ( accumulator > 0 ) { + debug_printf( DEBUG_ARITH, + L"integer_to_string: accumulator is %ld\n:", + accumulator ); + do { + debug_printf( DEBUG_ARITH, + L"integer_to_string: digit is %ld, hexadecimal is %lc\n:", + accumulator % base, + hex_digits[accumulator % base] ); + wint_t digit = ( wint_t ) hex_digits[accumulator % base]; - result = make_string( (wint_t)hex_digits[accumulator % base], result ); - accumulator = accumulator / base; - } while ( accumulator > base ); + result = + make_string( ( wint_t ) hex_digits[accumulator % base], + result ); + accumulator = accumulator / base; + } while ( accumulator > base ); - if ( integerp( integer.payload.integer.more ) ) { - integer = pointer2cell( integer.payload.integer.more ); - int64_t i = integer.payload.integer.value; + if ( integerp( integer.payload.integer.more ) ) { + integer = pointer2cell( integer.payload.integer.more ); + int64_t i = integer.payload.integer.value; - /* TODO: I don't believe it's as simple as this! */ - accumulator += ( base * ( i % base ) ); - result = make_string( (wint_t)hex_digits[accumulator % base], result ); - accumulator += ( base * ( i / base ) ); + /* TODO: I don't believe it's as simple as this! */ + accumulator += ( base * ( i % base ) ); + result = + make_string( ( wint_t ) hex_digits[accumulator % base], + result ); + accumulator += ( base * ( i / base ) ); + } + } + + if ( is_negative ) { + result = make_string( L'-', result ); } } - if ( is_negative ) { - result = make_string( L'-', result ); - } - } - return result; } diff --git a/src/arith/peano.c b/src/arith/peano.c index 2a9fb7f..3a24ed1 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -284,7 +284,9 @@ struct cons_pointer multiply_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV: - result = make_integer(cell1.payload.integer.value * cell2.payload.integer.value, NIL); + result = + make_integer( cell1.payload.integer.value * + cell2.payload.integer.value, NIL ); //result = multiply_integers( arg1, arg2 ); break; case RATIOTV: @@ -412,8 +414,9 @@ struct cons_pointer inverse( struct cons_pointer frame, case RATIOTV: result = make_ratio( frame, make_integer( 0 - - to_long_int( cell.payload.ratio. - dividend ), NIL ), + to_long_int( cell.payload. + ratio.dividend ), + NIL ), cell.payload.ratio.divisor ); break; case REALTV: @@ -453,7 +456,8 @@ struct cons_pointer lisp_subtract( struct break; case INTEGERTV: result = make_integer( cell0.payload.integer.value - - cell1.payload.integer.value, NIL ); + - cell1.payload.integer.value, + NIL ); break; case RATIOTV:{ struct cons_pointer tmp = diff --git a/src/arith/ratio.c b/src/arith/ratio.c index 95c9a8f..fd6a770 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -61,10 +61,10 @@ struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, 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 ); + 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 ( gcd > 1 ) { if ( drrv / gcd == 1 ) { @@ -203,10 +203,10 @@ struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg1, struct cons_pointer arg2 ) { struct cons_pointer i = make_ratio( frame_pointer, - pointer2cell( arg2 ).payload. - ratio.divisor, - pointer2cell( arg2 ).payload. - ratio.dividend ), result = + pointer2cell( arg2 ).payload.ratio. + divisor, + pointer2cell( arg2 ).payload.ratio. + dividend ), result = multiply_ratio_ratio( frame_pointer, arg1, i ); dec_ref( i ); diff --git a/src/init.c b/src/init.c index 773afb5..15fd8e4 100644 --- a/src/init.c +++ b/src/init.c @@ -62,12 +62,6 @@ void bind_value( wchar_t *name, struct cons_pointer value ) { } int main( int argc, char *argv[] ) { - /* - * attempt to set wide character acceptance on all streams - */ - fwide( stdin, 1 ); - fwide( stdout, 1 ); - fwide( stderr, 1 ); int option; bool dump_at_end = false; bool show_prompt = false; @@ -110,6 +104,26 @@ int main( int argc, char *argv[] ) { bind_value( L"nil", NIL ); bind_value( L"t", TRUE ); + /* + * standard input, output, error and sink streams + * attempt to set wide character acceptance on all streams + */ + FILE *sink = fopen( "/dev/null", "w" ); + fwide( stdin, 1 ); + fwide( stdout, 1 ); + fwide( stderr, 1 ); + fwide( sink, 1 ); + bind_value( L"*in*", make_read_stream( stdin ) ); + bind_value( L"*out*", make_write_stream( stdout ) ); + bind_value( L"*log*", make_write_stream( stderr ) ); + bind_value( L"*sink*", make_write_stream( sink ) ); + + /* + * the default prompt + */ + bind_value( L"*prompt*", + show_prompt ? c_string_to_lisp_symbol( L":: " ) : NIL ); + /* * primitive function operations */ @@ -126,6 +140,7 @@ int main( int argc, char *argv[] ) { bind_function( L"exception", &lisp_exception ); bind_function( L"multiply", &lisp_multiply ); bind_function( L"read", &lisp_read ); + bind_function( L"repl", &lisp_repl ); bind_function( L"oblist", &lisp_oblist ); bind_function( L"print", &lisp_print ); bind_function( L"progn", &lisp_progn ); @@ -156,7 +171,7 @@ int main( int argc, char *argv[] ) { debug_print( L"Initialised oblist\n", DEBUG_BOOTSTRAP ); debug_dump_object( oblist, DEBUG_BOOTSTRAP ); - repl( stdin, stdout, stderr, show_prompt ); + repl( show_prompt ); debug_print( L"Freeing oblist\n", DEBUG_BOOTSTRAP ); dec_ref( oblist ); diff --git a/src/memory/dump.c b/src/memory/dump.c index 24fd955..bd6587f 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -83,9 +83,9 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { fwprintf( output, L"\t\tInteger cell: value %ld, count %u\n", cell.payload.integer.value, cell.count ); - if (!nilp(cell.payload.integer.more)) { - fputws( L"\t\tBIGNUM! More at\n:", output); - dump_object(output, cell.payload.integer.more); + if ( !nilp( cell.payload.integer.more ) ) { + fputws( L"\t\tBIGNUM! More at\n:", output ); + dump_object( output, cell.payload.integer.more ); } break; case LAMBDATV: @@ -107,10 +107,10 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { case RATIOTV: fwprintf( output, L"\t\tRational cell: value %ld/%ld, count %u\n", - pointer2cell( cell.payload.ratio.dividend ). - payload.integer.value, - pointer2cell( cell.payload.ratio.divisor ). - payload.integer.value, cell.count ); + pointer2cell( cell.payload.ratio.dividend ).payload. + integer.value, + pointer2cell( cell.payload.ratio.divisor ).payload. + integer.value, cell.count ); break; case READTV: fwprintf( output, L"\t\tInput stream\n" ); diff --git a/src/ops/equal.c b/src/ops/equal.c index bade594..9eedd53 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -80,8 +80,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { && ( 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 ) ) ); + && end_of_string( cell_b->payload.string. + cdr ) ) ); break; case INTEGERTV: result = diff --git a/src/ops/lispops.c b/src/ops/lispops.c index c83287d..1913406 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -117,11 +117,16 @@ struct cons_pointer eval_forms( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer list, struct cons_pointer env ) { - /* TODO: refactor. This runs up the C stack. */ - return consp( list ) ? - make_cons( eval_form( frame, frame_pointer, c_car( list ), env ), - eval_forms( frame, frame_pointer, c_cdr( list ), - env ) ) : NIL; + struct cons_pointer result = NIL; + + while ( consp( list ) ) { + result = + make_cons( eval_form( frame, frame_pointer, c_car( list ), env ), + result ); + list = c_cdr( list ); + } + + return result; } /** @@ -220,7 +225,8 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, /* if `names` is a symbol, rather than a list of symbols, * then bind a list of the values of args to that symbol. */ /* TODO: eval all the things in frame->more */ - struct cons_pointer vals = frame->more; + struct cons_pointer vals = + eval_forms( frame, frame_pointer, frame->more, env ); for ( int i = args_in_frame - 1; i >= 0; i-- ) { struct cons_pointer val = @@ -353,10 +359,9 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, result = next_pointer; } else { result = - ( *fn_cell.payload. - special.executable ) ( get_stack_frame - ( next_pointer ), - next_pointer, env ); + ( *fn_cell.payload.special. + executable ) ( get_stack_frame( next_pointer ), + next_pointer, env ); debug_print( L"Special form returning: ", DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL ); debug_println( DEBUG_EVAL ); @@ -480,10 +485,9 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { -#ifdef DEBUG debug_print( L"Apply: ", DEBUG_EVAL ); - dump_frame( stderr, frame_pointer ); -#endif + debug_dump_object( frame_pointer, DEBUG_EVAL ); + set_reg( frame, 0, make_cons( frame->arg[0], frame->arg[1] ) ); set_reg( frame, 1, NIL ); @@ -612,17 +616,24 @@ struct cons_pointer lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; + struct cons_space_object cell = pointer2cell( frame->arg[0] ); - if ( consp( frame->arg[0] ) ) { - struct cons_space_object cell = pointer2cell( frame->arg[0] ); - result = cell.payload.cons.car; - } else if ( stringp( frame->arg[0] ) ) { - struct cons_space_object cell = pointer2cell( frame->arg[0] ); - result = make_string( cell.payload.string.character, NIL ); - } else { - struct cons_pointer message = - c_string_to_lisp_string( L"Attempt to take CAR of non sequence" ); - result = throw_exception( message, frame_pointer ); + switch ( cell.tag.value ) { + case CONSTV: + result = cell.payload.cons.car; + break; + case READTV: + result = make_string( fgetwc( cell.payload.stream.stream ), NIL ); + case STRINGTV: + result = make_string( cell.payload.string.character, NIL ); + break; + case NILTV: + break; + default: + result = + throw_exception( c_string_to_lisp_string + ( L"Attempt to take CAR of non sequence" ), + frame_pointer ); } return result; @@ -632,22 +643,33 @@ lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, * (cdr s_expr) * Returns the remainder of a sequence when the head is removed. Valid for cons cells, * strings, and TODO read streams and other things which can be considered as sequences. + * NOTE that if the argument is an input stream, the first character is removed AND + * DISCARDED. */ struct cons_pointer lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; + struct cons_space_object cell = pointer2cell( frame->arg[0] ); - if ( consp( frame->arg[0] ) ) { - struct cons_space_object cell = pointer2cell( frame->arg[0] ); - result = cell.payload.cons.cdr; - } else if ( stringp( frame->arg[0] ) ) { - struct cons_space_object cell = pointer2cell( frame->arg[0] ); - result = cell.payload.string.cdr; - } else { - struct cons_pointer message = - c_string_to_lisp_string( L"Attempt to take CDR of non sequence" ); - result = throw_exception( message, frame_pointer ); + switch ( cell.tag.value ) { + case CONSTV: + result = cell.payload.cons.cdr; + break; + case READTV: + fgetwc( cell.payload.stream.stream ); + result = frame->arg[0]; + break; + case STRINGTV: + result = cell.payload.string.cdr; + break; + case NILTV: + break; + default: + result = + throw_exception( c_string_to_lisp_string + ( L"Attempt to take CDR of non sequence" ), + frame_pointer ); } return result; @@ -683,6 +705,26 @@ lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, return equal( frame->arg[0], frame->arg[1] ) ? TRUE : NIL; } + +/** + * Resutn the current default input, or of `inputp` is false, output stream from + * this `env`ironment. + */ +struct cons_pointer get_default_stream( bool inputp, struct cons_pointer env ) { + struct cons_pointer result = NIL; + struct cons_pointer stream_name = + c_string_to_lisp_symbol( inputp ? L"*in*" : L"*out*" ); + + inc_ref( stream_name ); + + result = c_assoc( stream_name, env ); + + dec_ref( stream_name ); + + return result; +} + + /** * (read) * (read read-stream) @@ -696,15 +738,24 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, debug_print( L"entering lisp_read\n", DEBUG_IO ); #endif FILE *input = stdin; + struct cons_pointer in_stream = readp( frame->arg[0] ) ? + frame->arg[0] : get_default_stream( true, env ); - if ( readp( frame->arg[0] ) ) { - input = pointer2cell( frame->arg[0] ).payload.stream.stream; + if ( readp( in_stream ) ) { + debug_print( L"lisp_print: setting input stream\n", DEBUG_IO ); + debug_dump_object( in_stream, DEBUG_IO ); + input = pointer2cell( in_stream ).payload.stream.stream; + inc_ref( in_stream ); } struct cons_pointer result = read( frame, frame_pointer, input ); debug_print( L"lisp_read returning\n", DEBUG_IO ); debug_dump_object( result, DEBUG_IO ); + if ( readp( in_stream ) ) { + dec_ref( in_stream ); + } + return result; } @@ -757,12 +808,16 @@ lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, debug_print( L"Entering print\n", DEBUG_IO ); struct cons_pointer result = NIL; FILE *output = stdout; + struct cons_pointer out_stream = writep( frame->arg[1] ) ? + frame->arg[1] : get_default_stream( false, env ); - if ( writep( frame->arg[1] ) ) { + if ( writep( out_stream ) ) { debug_print( L"lisp_print: setting output stream\n", DEBUG_IO ); - debug_dump_object( frame->arg[1], DEBUG_IO ); - output = pointer2cell( frame->arg[1] ).payload.stream.stream; + debug_dump_object( out_stream, DEBUG_IO ); + output = pointer2cell( out_stream ).payload.stream.stream; + inc_ref( out_stream ); } + debug_print( L"lisp_print: about to print\n", DEBUG_IO ); debug_dump_object( frame->arg[0], DEBUG_IO ); @@ -771,6 +826,10 @@ lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, debug_print( L"lisp_print returning\n", DEBUG_IO ); debug_dump_object( result, DEBUG_IO ); + if ( writep( out_stream ) ) { + dec_ref( out_stream ); + } + return result; } @@ -787,6 +846,27 @@ lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, return c_type( frame->arg[0] ); } +/** + * Evaluate each of these forms in this `env`ironment over this `frame`, + * returning only the value of the last. + */ +struct cons_pointer +c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer forms, struct cons_pointer env ) { + struct cons_pointer result = NIL; + + while ( consp( forms ) ) { + struct cons_pointer r = result; + inc_ref( r ); + result = eval_form( frame, frame_pointer, c_car( forms ), env ); + dec_ref( r ); + + forms = c_cdr( forms ); + } + + return result; +} + /** * (progn forms...) @@ -803,17 +883,19 @@ lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - struct cons_pointer remaining = frame->more; struct cons_pointer result = NIL; for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) { + struct cons_pointer r = result; + inc_ref( r ); + result = eval_form( frame, frame_pointer, frame->arg[i], env ); + + dec_ref( r ); } - while ( consp( remaining ) ) { - result = eval_form( frame, frame_pointer, c_car( remaining ), env ); - - remaining = c_cdr( remaining ); + if ( consp( frame->more ) ) { + result = c_progn( frame, frame_pointer, frame->more, env ); } return result; @@ -846,15 +928,9 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, env ); if ( !nilp( result ) ) { - struct cons_pointer vals = - eval_forms( frame, frame_pointer, c_cdr( clause_pointer ), - env ); - - while ( consp( vals ) ) { - result = c_car( vals ); - vals = c_cdr( vals ); - } - + result = + c_progn( frame, frame_pointer, c_cdr( clause_pointer ), + env ); done = true; } } else if ( nilp( clause_pointer ) ) { @@ -915,3 +991,91 @@ lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, return exceptionp( message ) ? message : make_exception( message, frame->previous ); } + +/** + * (repl) + * (repl prompt) + * (repl prompt input_stream output_stream) + * + * Function: the read/eval/print loop. Returns the value of the last expression + * entered. + */ +struct cons_pointer lisp_repl( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer expr = NIL; + + /* TODO: bind *prompt*, *input*, *output* in the environment to the values + * of arguments 0, 1, and 2 respectively, but in each case only if the + * argument is not nil */ + + struct cons_pointer input = get_default_stream( true, env ); + struct cons_pointer output = get_default_stream( false, env ); + FILE *os = pointer2cell( output ).payload.stream.stream; + struct cons_pointer prompt_name = c_string_to_lisp_symbol( L"*prompt*" ); + struct cons_pointer old_oblist = oblist; + struct cons_pointer new_env = env; + + inc_ref( input ); + inc_ref( output ); + inc_ref( prompt_name ); + inc_ref( new_env ); + + /* TODO: this is subtly wrong. If we were evaluating + * (print (eval (read))) + * then the stack frame for read would have the stack frame for + * eval as parent, and it in turn would have the stack frame for + * print as parent. + */ + while ( readp( input ) && writep( output ) + && !feof( pointer2cell( input ).payload.stream.stream ) ) { + /* OK, here's a really subtle problem: because lists are immutable, anything + * bound in the oblist subsequent to this function being invoked isn't in the + * environment. So, for example, changes to *prompt* or *log* made in the oblist + * are not visible. So copy changes made in the oblist into the enviroment. + * TODO: the whole process of resolving symbol values needs to be revisited + * when we get onto namespaces. */ + struct cons_pointer cursor = oblist; + while ( !nilp( cursor ) && !eq( cursor, old_oblist ) ) { + debug_print + ( L"lisp_repl: copying new oblist binding into REPL environment:\n", + DEBUG_REPL ); + debug_print_object( c_car( cursor ), DEBUG_REPL ); + debug_println( DEBUG_REPL ); + + new_env = make_cons( c_car( cursor ), new_env ); + cursor = c_cdr( cursor ); + } + old_oblist = oblist; + + println( os ); + + struct cons_pointer prompt = c_assoc( prompt_name, new_env ); + if ( !nilp( prompt ) ) { + print( os, prompt ); + } + + expr = lisp_read( get_stack_frame( frame_pointer ), frame_pointer, + new_env ); + inc_ref( expr ); + + if ( exceptionp( expr ) + && feof( pointer2cell( input ).payload.stream.stream ) ) { + /* suppress printing end of stream exception */ + break; + } + + println( os ); + + print( os, eval_form( frame, frame_pointer, expr, new_env ) ); + + dec_ref( expr ); + } + + dec_ref( input ); + dec_ref( output ); + dec_ref( prompt_name ); + dec_ref( new_env ); + + return expr; +} diff --git a/src/ops/lispops.h b/src/ops/lispops.h index a1dee81..f9cd8ba 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -140,9 +140,13 @@ struct cons_pointer lisp_print( struct stack_frame *frame, struct cons_pointer lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); +struct cons_pointer lisp_repl( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); + /** * Function: Get the Lisp type of the single argument. * @param frame My stack frame. diff --git a/src/ops/print.c b/src/ops/print.c index 9138077..3feeb21 100644 --- a/src/ops/print.c +++ b/src/ops/print.c @@ -224,3 +224,7 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { return pointer; } + +void println( FILE * output ) { + fputws( L"\n", output ); +} diff --git a/src/ops/print.h b/src/ops/print.h index 1399db4..2751032 100644 --- a/src/ops/print.h +++ b/src/ops/print.h @@ -15,6 +15,7 @@ #define __print_h struct cons_pointer print( FILE * output, struct cons_pointer pointer ); +void println( FILE * output ); extern int print_use_colours; #endif diff --git a/src/repl.c b/src/repl.c index 99f41f8..0ea104d 100644 --- a/src/repl.c +++ b/src/repl.c @@ -11,118 +11,28 @@ #include #include -#include "conspage.h" #include "consspaceobject.h" #include "debug.h" #include "intern.h" #include "lispops.h" -#include "read.h" -#include "print.h" #include "stack.h" -/* TODO: this is subtly wrong. If we were evaluating - * (print (eval (read))) - * then the stack frame for read would have the stack frame for - * eval as parent, and it in turn would have the stack frame for - * print as parent. - */ - /** - * Dummy up a Lisp read call with its own stack frame. + * The read/eval/print loop. */ -struct cons_pointer repl_read( struct cons_pointer stream_pointer ) { - struct cons_pointer result = NIL; - debug_print( L"Entered repl_read\n", DEBUG_REPL ); - struct cons_pointer frame_pointer = - make_stack_frame( NIL, make_cons( stream_pointer, NIL ), oblist ); - debug_print( L"repl_read: got stack_frame pointer\n", DEBUG_REPL ); - debug_dump_object( frame_pointer, DEBUG_REPL ); +void repl( ) { + debug_print( L"Entered repl\n", DEBUG_REPL ); + + struct cons_pointer frame_pointer = make_stack_frame( NIL, NIL, oblist ); + if ( !nilp( frame_pointer ) ) { inc_ref( frame_pointer ); - result = - lisp_read( get_stack_frame( frame_pointer ), frame_pointer, - oblist ); + + lisp_repl( get_stack_frame( frame_pointer ), frame_pointer, oblist ); + dec_ref( frame_pointer ); } - debug_print( L"repl_read: returning\n", DEBUG_REPL ); - debug_dump_object( result, DEBUG_REPL ); - - return result; -} - -/** - * Dummy up a Lisp eval call with its own stack frame. - */ -struct cons_pointer repl_eval( struct cons_pointer input ) { - debug_print( L"Entered repl_eval\n", DEBUG_REPL ); - struct cons_pointer result = NIL; - - result = eval_form( NULL, NIL, input, oblist ); - - debug_print( L"repl_eval: returning\n", DEBUG_REPL ); - debug_dump_object( result, DEBUG_REPL ); - - return result; -} - -/** - * Dummy up a Lisp print call with its own stack frame. - */ -struct cons_pointer repl_print( struct cons_pointer stream_pointer, - struct cons_pointer value ) { - debug_print( L"Entered repl_print\n", DEBUG_REPL ); - debug_dump_object( value, DEBUG_REPL ); - struct cons_pointer result = - print( pointer2cell( stream_pointer ).payload.stream.stream, value ); - debug_print( L"repl_print: returning\n", DEBUG_REPL ); - debug_dump_object( result, DEBUG_REPL ); - - return result; -} - -/** - * The read/eval/print loop - * @param in_stream the stream to read from; - * @param out_stream the stream to write to; - * @param err_stream the stream to send errors to; - * @param show_prompt true if prompts should be shown. - */ -void -repl( FILE * in_stream, FILE * out_stream, FILE * error_stream, - bool show_prompt ) { - debug_print( L"Entered repl\n", DEBUG_REPL ); - struct cons_pointer input_stream = make_read_stream( in_stream ); - inc_ref( input_stream ); - - struct cons_pointer output_stream = make_write_stream( out_stream ); - inc_ref( output_stream ); - while ( !feof( pointer2cell( input_stream ).payload.stream.stream ) ) { - if ( show_prompt ) { - fwprintf( out_stream, L"\n:: " ); - } - - struct cons_pointer input = repl_read( input_stream ); - inc_ref( input ); - - if ( exceptionp( input ) ) { - /* suppress the end-of-stream exception */ - if ( !feof( pointer2cell( input_stream ).payload.stream.stream ) ) { - repl_print( output_stream, input ); - } - break; - } else { - struct cons_pointer val = repl_eval( input ); - inc_ref( val ); - repl_print( output_stream, val ); - dec_ref( val ); - } - - dec_ref( input ); - } - - dec_ref( input_stream ); - dec_ref( output_stream ); debug_print( L"Leaving repl\n", DEBUG_REPL ); } diff --git a/src/repl.h b/src/repl.h index 1a7b0e9..8ff8b19 100644 --- a/src/repl.h +++ b/src/repl.h @@ -20,13 +20,8 @@ extern "C" { /** * The read/eval/print loop - * @param in_stream the stream to read from; - * @param out_stream the stream to write to; - * @param err_stream the stream to send errors to; - * @param show_prompt true if prompts should be shown. */ - void repl( FILE * in_stream, FILE * out_stream, - FILE * error_stream, bool show_prompt ); + void repl( ); #ifdef __cplusplus } diff --git a/unit-tests/add.sh b/unit-tests/add.sh index 4516808..2802c3a 100644 --- a/unit-tests/add.sh +++ b/unit-tests/add.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='5' -actual=`echo "(add 2 3)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(add 2 3)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -12,7 +12,7 @@ else fi expected='5.5' -actual=`echo "(add 2.5 3)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(add 2.5 3)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -24,7 +24,7 @@ else fi expected='1/4' -actual=`echo "(+ 3/14 1/28)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(+ 3/14 1/28)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -36,7 +36,7 @@ fi # (+ integer ratio) should be ratio expected='25/4' -actual=`echo "(+ 6 1/4)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(+ 6 1/4)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -48,7 +48,7 @@ fi # (+ ratio integer) should be ratio expected='25/4' -actual=`echo "(+ 1/4 6)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(+ 1/4 6)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/apply.sh b/unit-tests/apply.sh index 3483fb0..811fdae 100644 --- a/unit-tests/apply.sh +++ b/unit-tests/apply.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='1' -actual=`echo "(apply 'add '(1))"| target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(apply 'add '(1))"| target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/complex-list.sh b/unit-tests/complex-list.sh index d3728d8..5bb5e9c 100644 --- a/unit-tests/complex-list.sh +++ b/unit-tests/complex-list.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='(1 2 3 ("Fred") nil 77354)' -actual=`echo "'(1 2 3 (\"Fred\") () 77354)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "'(1 2 3 (\"Fred\") () 77354)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/cond.sh b/unit-tests/cond.sh index 227f9b3..ab2e2f0 100644 --- a/unit-tests/cond.sh +++ b/unit-tests/cond.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='5' -actual=`echo "(cond ((equal 2 2) 5))" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(cond ((equal 2 2) 5))" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -12,7 +12,7 @@ else fi expected='"should"' -actual=`echo "(cond ((equal 2 3) \"shouldn't\")(t \"should\"))" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(cond ((equal 2 3) \"shouldn't\")(t \"should\"))" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/empty-list.sh b/unit-tests/empty-list.sh index 1e24452..8f0f702 100644 --- a/unit-tests/empty-list.sh +++ b/unit-tests/empty-list.sh @@ -1,5 +1,5 @@ #!/bin/bash -# +# # File: empty-list.sh.bash # Author: simon # @@ -7,7 +7,7 @@ # expected=nil -actual=`echo "'()" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "'()" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/empty-string.sh b/unit-tests/empty-string.sh index 340fd1b..a1e5baa 100644 --- a/unit-tests/empty-string.sh +++ b/unit-tests/empty-string.sh @@ -1,7 +1,7 @@ #!/bin/bash expected="\"\"" -actual=`echo '""' | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo '""' | target/psse | tail -1` if [ "$expected" = "$actual" ] then diff --git a/unit-tests/eval-integer.sh b/unit-tests/eval-integer.sh index addc133..1aadb39 100644 --- a/unit-tests/eval-integer.sh +++ b/unit-tests/eval-integer.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='5' -actual=`echo "(eval 5)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(eval 5)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/eval-quote-sexpr.sh b/unit-tests/eval-quote-sexpr.sh index eea16ec..d83bbe8 100644 --- a/unit-tests/eval-quote-sexpr.sh +++ b/unit-tests/eval-quote-sexpr.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='5' -actual=`echo "(eval '(add 2 3))" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(eval '(add 2 3))" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/eval-quote-symbol.sh b/unit-tests/eval-quote-symbol.sh index 5eca83d..253ce32 100644 --- a/unit-tests/eval-quote-symbol.sh +++ b/unit-tests/eval-quote-symbol.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='(Special form)' -actual=`echo "(eval 'cond)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(eval 'cond)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/eval-real.sh b/unit-tests/eval-real.sh index 8832719..3aa16d7 100644 --- a/unit-tests/eval-real.sh +++ b/unit-tests/eval-real.sh @@ -5,12 +5,11 @@ expected='5.05' actual=`echo "(eval 5.05)" |\ target/psse 2> /dev/null |\ sed 's/0*$//' |\ - head -2 |\ tail -1` +# one part in a million is close enough... outcome=`echo "sqrt((${expected} - ${actual})^2) < 0.0000001" | bc` - if [ "${outcome}" = "1" ] then echo "OK" diff --git a/unit-tests/eval-string.sh b/unit-tests/eval-string.sh index 4b8dc8e..90f6f2c 100644 --- a/unit-tests/eval-string.sh +++ b/unit-tests/eval-string.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='"5"' -actual=`echo '(eval "5")' | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo '(eval "5")' | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/fred.sh b/unit-tests/fred.sh index 427c60d..8e3d513 100644 --- a/unit-tests/fred.sh +++ b/unit-tests/fred.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='"Fred"' -actual=`echo ${expected} | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo ${expected} | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/integer.sh b/unit-tests/integer.sh index 41b2da3..18ae66e 100644 --- a/unit-tests/integer.sh +++ b/unit-tests/integer.sh @@ -1,7 +1,7 @@ #!/bin/bash -expected="354" -actual=`echo ${expected} | target/psse 2> /dev/null | head -2 | tail -1` +expected='354' +actual=`echo ${expected} | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/intepreter.sh b/unit-tests/intepreter.sh index 9eb2a06..6f23fc9 100644 --- a/unit-tests/intepreter.sh +++ b/unit-tests/intepreter.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='6' -actual=`echo "(apply '(lambda (x y z) (/ (* y z) x)) '(2 3 4))" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(apply '(lambda (x y z) (/ (* y z) x)) '(2 3 4))" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/lambda.sh b/unit-tests/lambda.sh index c1197e0..b7f1707 100644 --- a/unit-tests/lambda.sh +++ b/unit-tests/lambda.sh @@ -1,10 +1,11 @@ #!/bin/bash -expected='(lambda (l) l)(1 2 3 4 5 6 7 8 9 10)' -actual=`target/psse 2>/dev/null </dev/null < /dev/null | head -2 | tail -1` +actual=`echo "(+ 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/multiply.sh b/unit-tests/multiply.sh index 0675a6f..94b19f6 100644 --- a/unit-tests/multiply.sh +++ b/unit-tests/multiply.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='6' -actual=`echo "(multiply 2 3)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(multiply 2 3)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -12,7 +12,7 @@ else fi expected='7.5' -actual=`echo "(multiply 2.5 3)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(multiply 2.5 3)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/nil.sh b/unit-tests/nil.sh index de4ef57..fcbf530 100644 --- a/unit-tests/nil.sh +++ b/unit-tests/nil.sh @@ -1,7 +1,7 @@ #!/bin/bash expected=nil -actual=`echo 'nil' | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo 'nil' | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/nlambda.sh b/unit-tests/nlambda.sh index f267527..68f0447 100644 --- a/unit-tests/nlambda.sh +++ b/unit-tests/nlambda.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='a' -actual=`echo "((nlambda (x) x) a)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "((nlambda (x) x) a)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/progn.sh b/unit-tests/progn.sh index 017646b..352c87a 100644 --- a/unit-tests/progn.sh +++ b/unit-tests/progn.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='5' -actual=`echo "(progn (add 2 3))" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(progn (add 2 3))" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -12,7 +12,7 @@ else fi expected='"foo"' -actual=`echo "(progn (add 2.5 3) \"foo\")" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(progn (add 2.5 3) \"foo\")" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/quote.sh b/unit-tests/quote.sh index bded011..78d4ce5 100644 --- a/unit-tests/quote.sh +++ b/unit-tests/quote.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='Fred' -actual=`echo "'Fred" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "'Fred" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/quoted-list.sh b/unit-tests/quoted-list.sh index 24480c6..f69cd75 100644 --- a/unit-tests/quoted-list.sh +++ b/unit-tests/quoted-list.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='(123 (4 (5 nil)) Fred)' -actual=`echo "'(123 (4 (5 ())) Fred)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "'(123 (4 (5 ())) Fred)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/ratio-addition.sh b/unit-tests/ratio-addition.sh index f57d0b0..ba93c5d 100644 --- a/unit-tests/ratio-addition.sh +++ b/unit-tests/ratio-addition.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='1/4' -actual=`echo "(+ 3/14 1/28)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(+ 3/14 1/28)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/recursion.sh b/unit-tests/recursion.sh index a49154b..407265e 100644 --- a/unit-tests/recursion.sh +++ b/unit-tests/recursion.sh @@ -1,7 +1,7 @@ #!/bin/bash -expected='nil3628800' -actual=`target/psse 2>/dev/null </dev/null </dev/null < /dev/null | head -2 | tail -1` +actual=`echo '(reverse "The quick brown fox jumped over the lazy dog")' | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -12,7 +12,7 @@ else fi expected='(1024 512 256 128 64 32 16 8 4 2)' -actual=`echo "(reverse '(2 4 8 16 32 64 128 256 512 1024))" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(reverse '(2 4 8 16 32 64 128 256 512 1024))" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -23,7 +23,7 @@ else fi expected='esrever' -actual=`echo "(reverse 'reverse)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(reverse 'reverse)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/simple-list.sh b/unit-tests/simple-list.sh index 60492b9..daf3db2 100644 --- a/unit-tests/simple-list.sh +++ b/unit-tests/simple-list.sh @@ -1,7 +1,7 @@ #!/bin/bash expected="(1 2 3)" -actual=`echo "'(1 2 3)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "'(1 2 3)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/string-with-spaces.sh b/unit-tests/string-with-spaces.sh index 384cc9f..0f0f6d0 100644 --- a/unit-tests/string-with-spaces.sh +++ b/unit-tests/string-with-spaces.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='"Strings should be able to include spaces (and other stuff)!"' -actual=`echo ${expected} | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo ${expected} | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/varargs.sh b/unit-tests/varargs.sh index 6c31163..27bac3e 100644 --- a/unit-tests/varargs.sh +++ b/unit-tests/varargs.sh @@ -1,10 +1,7 @@ #!/bin/bash -expected='(lambda l l)(1 2 3 4 5 6 7 8 9 10)' -actual=`target/psse 2>/dev/null < Date: Sun, 30 Dec 2018 19:07:07 +0000 Subject: [PATCH 06/40] Not really making progress. --- lisp/not-working-yet.lisp | 6 ++++ lisp/types.lisp | 7 ----- src/init.c | 1 + src/ops/lispops.c | 60 ++++++++++++++++++++++++++++++++------- src/ops/lispops.h | 4 +++ src/ops/read.c | 7 +++-- 6 files changed, 66 insertions(+), 19 deletions(-) create mode 100644 lisp/not-working-yet.lisp diff --git a/lisp/not-working-yet.lisp b/lisp/not-working-yet.lisp new file mode 100644 index 0000000..0f3a8c2 --- /dev/null +++ b/lisp/not-working-yet.lisp @@ -0,0 +1,6 @@ +(set! or (lambda values + "True if any of `values` are non-nil." + (cond + ((nil? values) nil) + ((car values) t) + (t (eval (cons 'or (cdr values))))))) diff --git a/lisp/types.lisp b/lisp/types.lisp index cba1ef6..7f7bf8c 100644 --- a/lisp/types.lisp +++ b/lisp/types.lisp @@ -15,10 +15,3 @@ (set! true? (lambda (o) "True if o is the canonical true value." (= (type o) "TRUE") ) ) (set! write? (lambda (o) "True if o is a write stream." (= (type o) "WRIT") ) ) -(set! or (lambda values - "True if any of `values` are non-nil." - (cond ((car values) t) (t (apply 'or (cdr values)))))) - -(set! number? - (lambda (o) - "I don't yet have an `or` operator diff --git a/src/init.c b/src/init.c index 15fd8e4..f446dc4 100644 --- a/src/init.c +++ b/src/init.c @@ -146,6 +146,7 @@ int main( int argc, char *argv[] ) { bind_function( L"progn", &lisp_progn ); bind_function( L"reverse", &lisp_reverse ); bind_function( L"set", &lisp_set ); + bind_function( L"source", &lisp_source ); bind_function( L"subtract", &lisp_subtract ); bind_function( L"throw", &lisp_exception ); bind_function( L"type", &lisp_type ); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 1913406..476cf46 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -1035,18 +1035,21 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, * are not visible. So copy changes made in the oblist into the enviroment. * TODO: the whole process of resolving symbol values needs to be revisited * when we get onto namespaces. */ - struct cons_pointer cursor = oblist; - while ( !nilp( cursor ) && !eq( cursor, old_oblist ) ) { - debug_print - ( L"lisp_repl: copying new oblist binding into REPL environment:\n", - DEBUG_REPL ); - debug_print_object( c_car( cursor ), DEBUG_REPL ); - debug_println( DEBUG_REPL ); + if ( !eq( oblist, old_oblist ) ) { + struct cons_pointer cursor = oblist; - new_env = make_cons( c_car( cursor ), new_env ); - cursor = c_cdr( cursor ); + while ( !nilp( cursor ) && !eq( cursor, old_oblist ) ) { + debug_print + ( L"lisp_repl: copying new oblist binding into REPL environment:\n", + DEBUG_REPL ); + debug_print_object( c_car( cursor ), DEBUG_REPL ); + debug_println( DEBUG_REPL ); + + new_env = make_cons( c_car( cursor ), new_env ); + cursor = c_cdr( cursor ); + } + old_oblist = oblist; } - old_oblist = oblist; println( os ); @@ -1079,3 +1082,40 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, return expr; } + +/** + * (source object) + * + * Function. + * Return the source code of the object, if it is an executable + * and has source code. + */ +struct cons_pointer lisp_source( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + struct cons_space_object cell = pointer2cell( frame->arg[0] ); + + switch ( cell.tag.value ) { + case FUNCTIONTV: + result = cell.payload.function.source; + break; + case SPECIALTV: + result = cell.payload.special.source; + break; + case LAMBDATV: + result = make_cons( c_string_to_lisp_symbol( L"lambda" ), + make_cons( cell.payload.lambda.args, + cell.payload.lambda.body ) ); + break; + case NLAMBDATV: + result = make_cons( c_string_to_lisp_symbol( L"nlambda" ), + make_cons( cell.payload.lambda.args, + cell.payload.lambda.body ) ); + break; + } + // TODO: suffers from premature GC, and I can't see why! + inc_ref( result ); + + return result; +} diff --git a/src/ops/lispops.h b/src/ops/lispops.h index f9cd8ba..7868c4b 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -197,3 +197,7 @@ struct cons_pointer throw_exception( struct cons_pointer message, struct cons_pointer lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); + +struct cons_pointer lisp_source( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); diff --git a/src/ops/read.c b/src/ops/read.c index 2a8522c..410a27f 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -275,6 +275,9 @@ struct cons_pointer read_string( FILE * input, wint_t initial ) { result = make_string( initial, NIL ); break; case '"': + /* making a string of the null character means we can have an empty + * string. Just returning NIL here would make an empty string + * impossible. */ result = make_string( '\0', NIL ); break; default: @@ -302,9 +305,9 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) { break; case ')': /* - * unquoted strings may not include right-parenthesis + * symbols may not include right-parenthesis */ - result = make_symbol( '\0', NIL ); + result = NIL; /* * push back the character read */ From 72ab4af20e4bc1baf1b0e58b08a01b21b7a60a36 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 31 Dec 2018 14:43:47 +0000 Subject: [PATCH 07/40] Seem to have fixed the 'oblist getting lost' problem. --- lisp/fact.lisp | 1 + src/ops/lispops.c | 7 +++++-- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/lisp/fact.lisp b/lisp/fact.lisp index de1f12b..968ea73 100644 --- a/lisp/fact.lisp +++ b/lisp/fact.lisp @@ -1,5 +1,6 @@ (set! fact (lambda (n) + "Compute the factorial of `n`, expected to be an integer." (cond ((= n 1) 1) (t (* n (fact (- n 1))))))) diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 476cf46..d20dbf9 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -1015,11 +1015,11 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, struct cons_pointer prompt_name = c_string_to_lisp_symbol( L"*prompt*" ); struct cons_pointer old_oblist = oblist; struct cons_pointer new_env = env; + inc_ref(env); inc_ref( input ); inc_ref( output ); inc_ref( prompt_name ); - inc_ref( new_env ); /* TODO: this is subtly wrong. If we were evaluating * (print (eval (read))) @@ -1039,6 +1039,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, struct cons_pointer cursor = oblist; while ( !nilp( cursor ) && !eq( cursor, old_oblist ) ) { + struct cons_pointer old_new_env = new_env; debug_print ( L"lisp_repl: copying new oblist binding into REPL environment:\n", DEBUG_REPL ); @@ -1046,6 +1047,8 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, debug_println( DEBUG_REPL ); new_env = make_cons( c_car( cursor ), new_env ); + inc_ref( new_env); + dec_ref( old_new_env); cursor = c_cdr( cursor ); } old_oblist = oblist; @@ -1078,7 +1081,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, dec_ref( input ); dec_ref( output ); dec_ref( prompt_name ); - dec_ref( new_env ); + dec_ref( env ); return expr; } From cad703f21862b578dbaf0e30ada6e7b475a4b16c Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 31 Dec 2018 16:11:55 +0000 Subject: [PATCH 08/40] Now safely detecting (but not dealing with) integer overflow. --- src/arith/integer.c | 53 ++++++++++++++++++++++++++++++++------------- src/ops/lispops.c | 13 ++++++----- src/ops/read.c | 4 +++- 3 files changed, 48 insertions(+), 22 deletions(-) diff --git a/src/arith/integer.c b/src/arith/integer.c index 0e74f7b..d916c99 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -12,6 +12,12 @@ #include #include #include +/* safe_iop, as available in the Ubuntu repository, is this one: + * https://code.google.com/archive/p/safe-iop/wikis/README.wiki + * which is installed as `libsafe-iop-dev`. There is an alternate + * implementation here: https://github.com/redpig/safe-iop/ + * which shares the same version number but is not compatible. */ +#include /* * wide characters */ @@ -107,16 +113,18 @@ struct cons_pointer add_integers( struct cons_pointer a, int64_t bv = integerp( b ) ? pointer2cell( b ).payload.integer.value : 0; - __int128_t rv = av + bv + carry; + int64_t rv = 0; - if ( rv > LONG_MAX || rv < LONG_MIN ) { + if ( safe_add( &rv, av, bv ) ) { + carry = 0; + } else { + // TODO: we're correctly detecting overflow, but not yet correctly + // handling it. debug_printf( DEBUG_ARITH, L"add_integers: 64 bit overflow; setting carry to %ld\n", carry ); carry = llabs( rv / LONG_MAX ); rv = rv % LONG_MAX; - } else { - carry = 0; } result = make_integer( rv, result ); @@ -153,16 +161,18 @@ struct cons_pointer multiply_integers( struct cons_pointer a, int64_t bv = integerp( b ) ? pointer2cell( b ).payload.integer.value : 1; - __int128_t rv = ( av * bv ) + carry; + int64_t rv = 0; - if ( rv > LONG_MAX || rv < LONG_MIN ) { + if ( safe_mul( &rv, av, bv ) ) { + carry = 0; + } else { + // TODO: we're correctly detecting overflow, but not yet correctly + // handling it. debug_printf( DEBUG_ARITH, L"multiply_integers: 64 bit overflow; setting carry to %ld\n", carry ); carry = llabs( rv / LONG_MAX ); rv = rv % LONG_MAX; - } else { - carry = 0; } result = make_integer( rv, result ); @@ -177,6 +187,19 @@ struct cons_pointer multiply_integers( struct cons_pointer a, return result; } +/** + * don't use; private to integer_to_string, and somewaht dodgy. + */ +struct cons_pointer integer_to_string_add_digit( int digit, int digits, + struct cons_pointer tail ) { + digits++; + wint_t character = ( wint_t ) hex_digits[digit]; + return ( digits % 3 == 0 ) ? + make_string( L',', make_string( character, + tail ) ) : + make_string( character, tail ); +} + /** * The general principle of printing a bignum is that you print the least * significant digit in whatever base you're dealing with, divide through @@ -195,24 +218,24 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, int64_t accumulator = integer.payload.integer.value; bool is_negative = accumulator < 0; accumulator = llabs( accumulator ); + int digits = 0; if ( accumulator == 0 ) { result = c_string_to_lisp_string( L"0" ); } else { while ( accumulator > 0 ) { - debug_printf( DEBUG_ARITH, + debug_printf( DEBUG_IO, L"integer_to_string: accumulator is %ld\n:", accumulator ); do { - debug_printf( DEBUG_ARITH, + debug_printf( DEBUG_IO, L"integer_to_string: digit is %ld, hexadecimal is %lc\n:", accumulator % base, hex_digits[accumulator % base] ); - wint_t digit = ( wint_t ) hex_digits[accumulator % base]; result = - make_string( ( wint_t ) hex_digits[accumulator % base], - result ); + integer_to_string_add_digit( accumulator % base, digits++, + result ); accumulator = accumulator / base; } while ( accumulator > base ); @@ -223,8 +246,8 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, /* TODO: I don't believe it's as simple as this! */ accumulator += ( base * ( i % base ) ); result = - make_string( ( wint_t ) hex_digits[accumulator % base], - result ); + integer_to_string_add_digit( accumulator % base, digits++, + result ); accumulator += ( base * ( i / base ) ); } } diff --git a/src/ops/lispops.c b/src/ops/lispops.c index d20dbf9..d66af71 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -359,9 +359,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, result = next_pointer; } else { result = - ( *fn_cell.payload.special. - executable ) ( get_stack_frame( next_pointer ), - next_pointer, env ); + ( *fn_cell.payload. + special.executable ) ( get_stack_frame + ( next_pointer ), + next_pointer, env ); debug_print( L"Special form returning: ", DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL ); debug_println( DEBUG_EVAL ); @@ -1015,7 +1016,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, struct cons_pointer prompt_name = c_string_to_lisp_symbol( L"*prompt*" ); struct cons_pointer old_oblist = oblist; struct cons_pointer new_env = env; - inc_ref(env); + inc_ref( env ); inc_ref( input ); inc_ref( output ); @@ -1047,8 +1048,8 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, debug_println( DEBUG_REPL ); new_env = make_cons( c_car( cursor ), new_env ); - inc_ref( new_env); - dec_ref( old_new_env); + inc_ref( new_env ); + dec_ref( old_new_env ); cursor = c_cdr( cursor ); } old_oblist = oblist; diff --git a/src/ops/read.c b/src/ops/read.c index 410a27f..c83fc24 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -175,7 +175,7 @@ struct cons_pointer read_number( struct stack_frame *frame, initial ); for ( c = initial; iswdigit( c ) - || c == btowc( '.' ) || c == btowc( '/' ); c = fgetwc( input ) ) { + || c == L'.' || c == L'/' || c == L','; c = fgetwc( input ) ) { if ( c == btowc( '.' ) ) { if ( seen_period || dividend != 0 ) { return throw_exception( c_string_to_lisp_string @@ -194,6 +194,8 @@ struct cons_pointer read_number( struct stack_frame *frame, accumulator = 0; } + } else if ( c == L',' ) { + // silently ignore it. } else { accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' ); From e5f40032e960b3c182b9c66db502f5329d3cbb5b Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 31 Dec 2018 16:11:55 +0000 Subject: [PATCH 09/40] Now safely detecting (but not dealing with) integer overflow. Also printing and reading integers with comma separators. --- src/arith/integer.c | 53 ++++++++++++++++++++++++++++++++------------- src/ops/lispops.c | 13 ++++++----- src/ops/read.c | 4 +++- 3 files changed, 48 insertions(+), 22 deletions(-) diff --git a/src/arith/integer.c b/src/arith/integer.c index 0e74f7b..d916c99 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -12,6 +12,12 @@ #include #include #include +/* safe_iop, as available in the Ubuntu repository, is this one: + * https://code.google.com/archive/p/safe-iop/wikis/README.wiki + * which is installed as `libsafe-iop-dev`. There is an alternate + * implementation here: https://github.com/redpig/safe-iop/ + * which shares the same version number but is not compatible. */ +#include /* * wide characters */ @@ -107,16 +113,18 @@ struct cons_pointer add_integers( struct cons_pointer a, int64_t bv = integerp( b ) ? pointer2cell( b ).payload.integer.value : 0; - __int128_t rv = av + bv + carry; + int64_t rv = 0; - if ( rv > LONG_MAX || rv < LONG_MIN ) { + if ( safe_add( &rv, av, bv ) ) { + carry = 0; + } else { + // TODO: we're correctly detecting overflow, but not yet correctly + // handling it. debug_printf( DEBUG_ARITH, L"add_integers: 64 bit overflow; setting carry to %ld\n", carry ); carry = llabs( rv / LONG_MAX ); rv = rv % LONG_MAX; - } else { - carry = 0; } result = make_integer( rv, result ); @@ -153,16 +161,18 @@ struct cons_pointer multiply_integers( struct cons_pointer a, int64_t bv = integerp( b ) ? pointer2cell( b ).payload.integer.value : 1; - __int128_t rv = ( av * bv ) + carry; + int64_t rv = 0; - if ( rv > LONG_MAX || rv < LONG_MIN ) { + if ( safe_mul( &rv, av, bv ) ) { + carry = 0; + } else { + // TODO: we're correctly detecting overflow, but not yet correctly + // handling it. debug_printf( DEBUG_ARITH, L"multiply_integers: 64 bit overflow; setting carry to %ld\n", carry ); carry = llabs( rv / LONG_MAX ); rv = rv % LONG_MAX; - } else { - carry = 0; } result = make_integer( rv, result ); @@ -177,6 +187,19 @@ struct cons_pointer multiply_integers( struct cons_pointer a, return result; } +/** + * don't use; private to integer_to_string, and somewaht dodgy. + */ +struct cons_pointer integer_to_string_add_digit( int digit, int digits, + struct cons_pointer tail ) { + digits++; + wint_t character = ( wint_t ) hex_digits[digit]; + return ( digits % 3 == 0 ) ? + make_string( L',', make_string( character, + tail ) ) : + make_string( character, tail ); +} + /** * The general principle of printing a bignum is that you print the least * significant digit in whatever base you're dealing with, divide through @@ -195,24 +218,24 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, int64_t accumulator = integer.payload.integer.value; bool is_negative = accumulator < 0; accumulator = llabs( accumulator ); + int digits = 0; if ( accumulator == 0 ) { result = c_string_to_lisp_string( L"0" ); } else { while ( accumulator > 0 ) { - debug_printf( DEBUG_ARITH, + debug_printf( DEBUG_IO, L"integer_to_string: accumulator is %ld\n:", accumulator ); do { - debug_printf( DEBUG_ARITH, + debug_printf( DEBUG_IO, L"integer_to_string: digit is %ld, hexadecimal is %lc\n:", accumulator % base, hex_digits[accumulator % base] ); - wint_t digit = ( wint_t ) hex_digits[accumulator % base]; result = - make_string( ( wint_t ) hex_digits[accumulator % base], - result ); + integer_to_string_add_digit( accumulator % base, digits++, + result ); accumulator = accumulator / base; } while ( accumulator > base ); @@ -223,8 +246,8 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, /* TODO: I don't believe it's as simple as this! */ accumulator += ( base * ( i % base ) ); result = - make_string( ( wint_t ) hex_digits[accumulator % base], - result ); + integer_to_string_add_digit( accumulator % base, digits++, + result ); accumulator += ( base * ( i / base ) ); } } diff --git a/src/ops/lispops.c b/src/ops/lispops.c index d20dbf9..d66af71 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -359,9 +359,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, result = next_pointer; } else { result = - ( *fn_cell.payload.special. - executable ) ( get_stack_frame( next_pointer ), - next_pointer, env ); + ( *fn_cell.payload. + special.executable ) ( get_stack_frame + ( next_pointer ), + next_pointer, env ); debug_print( L"Special form returning: ", DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL ); debug_println( DEBUG_EVAL ); @@ -1015,7 +1016,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, struct cons_pointer prompt_name = c_string_to_lisp_symbol( L"*prompt*" ); struct cons_pointer old_oblist = oblist; struct cons_pointer new_env = env; - inc_ref(env); + inc_ref( env ); inc_ref( input ); inc_ref( output ); @@ -1047,8 +1048,8 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, debug_println( DEBUG_REPL ); new_env = make_cons( c_car( cursor ), new_env ); - inc_ref( new_env); - dec_ref( old_new_env); + inc_ref( new_env ); + dec_ref( old_new_env ); cursor = c_cdr( cursor ); } old_oblist = oblist; diff --git a/src/ops/read.c b/src/ops/read.c index 410a27f..c83fc24 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -175,7 +175,7 @@ struct cons_pointer read_number( struct stack_frame *frame, initial ); for ( c = initial; iswdigit( c ) - || c == btowc( '.' ) || c == btowc( '/' ); c = fgetwc( input ) ) { + || c == L'.' || c == L'/' || c == L','; c = fgetwc( input ) ) { if ( c == btowc( '.' ) ) { if ( seen_period || dividend != 0 ) { return throw_exception( c_string_to_lisp_string @@ -194,6 +194,8 @@ struct cons_pointer read_number( struct stack_frame *frame, accumulator = 0; } + } else if ( c == L',' ) { + // silently ignore it. } else { accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' ); From a02d286ad536923c1201bf06687f5bd6b0147432 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 31 Dec 2018 16:18:39 +0000 Subject: [PATCH 10/40] Spotted a bug in car of a stream, and fixed it. --- src/ops/lispops.c | 1 + 1 file changed, 1 insertion(+) diff --git a/src/ops/lispops.c b/src/ops/lispops.c index d66af71..9ab797a 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -625,6 +625,7 @@ lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, break; case READTV: result = make_string( fgetwc( cell.payload.stream.stream ), NIL ); + break; case STRINGTV: result = make_string( cell.payload.string.character, NIL ); break; From 6d2cf313cb8d162defb541b6c116aba09943f46c Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 31 Dec 2018 16:24:38 +0000 Subject: [PATCH 11/40] Very small fix to formatting integers. --- src/arith/integer.c | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/arith/integer.c b/src/arith/integer.c index d916c99..ec242bd 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -251,6 +251,14 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, accumulator += ( base * ( i / 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. */ + struct cons_pointer tmp = result; + result = pointer2cell(result).payload.string.cdr; + dec_ref(tmp); + } if ( is_negative ) { result = make_string( L'-', result ); From 87007362f3dc7cf51b2faa35a911feaeff38e21b Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 31 Dec 2018 16:29:11 +0000 Subject: [PATCH 12/40] Fixed unit tests which were failing because of the change in formatting integers --- unit-tests/complex-list.sh | 2 +- unit-tests/recursion.sh | 2 +- unit-tests/reverse.sh | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/unit-tests/complex-list.sh b/unit-tests/complex-list.sh index 5bb5e9c..3e84d79 100644 --- a/unit-tests/complex-list.sh +++ b/unit-tests/complex-list.sh @@ -1,6 +1,6 @@ #!/bin/bash -expected='(1 2 3 ("Fred") nil 77354)' +expected='(1 2 3 ("Fred") nil 77,354)' actual=`echo "'(1 2 3 (\"Fred\") () 77354)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] diff --git a/unit-tests/recursion.sh b/unit-tests/recursion.sh index 407265e..6b5be2d 100644 --- a/unit-tests/recursion.sh +++ b/unit-tests/recursion.sh @@ -1,6 +1,6 @@ #!/bin/bash -expected='nil 3628800' +expected='nil 3,628,800' output=`target/psse 2>/dev/null < Date: Tue, 1 Jan 2019 15:04:44 +0000 Subject: [PATCH 13/40] This isn't working, but it's VERY promising. --- Makefile | 2 + lisp/fact.lisp | 2 +- notes/bignums.md | 7 ++++ src/arith/integer.c | 96 ++++++++++++++++++++++++++++++++------------- src/arith/peano.c | 12 +++--- 5 files changed, 84 insertions(+), 35 deletions(-) create mode 100644 notes/bignums.md diff --git a/Makefile b/Makefile index 4fe322f..7179c91 100644 --- a/Makefile +++ b/Makefile @@ -18,6 +18,8 @@ INDENT_FLAGS := -nbad -bap -nbc -br -brf -brs -c33 -cd33 -ncdb -ce -ci4 -cli4 \ CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g -DDEBUG LDFLAGS := -lm +all: $(TARGET) + $(TARGET): $(OBJS) Makefile $(CC) $(LDFLAGS) $(OBJS) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS) diff --git a/lisp/fact.lisp b/lisp/fact.lisp index 968ea73..7df7246 100644 --- a/lisp/fact.lisp +++ b/lisp/fact.lisp @@ -4,4 +4,4 @@ (cond ((= n 1) 1) (t (* n (fact (- n 1))))))) -(fact 20) +(fact 21) diff --git a/notes/bignums.md b/notes/bignums.md new file mode 100644 index 0000000..ea4b0b3 --- /dev/null +++ b/notes/bignums.md @@ -0,0 +1,7 @@ +# All integers are potentially bignums + +Each integer comprises at least one cell of type INTR, holding a signed 64 bit integer with a value in the range 0 ... MAX-INTEGER, where the actual value of MAX-INTEGER does not need to be the same as the C language LONG\_MAX, provided that it is less than this. It seems to me that a convenient number would be the largest number less than LONG\_MAX which has all bits set + +LONG\_MAX is 0x7FFFFFFFFFFFFFFF, so the number we're looking for is 0xFFFFFFFFFFFFFFF, which is 1,152,921,504,606,846,975, which is 2^60 - 1. This means we can use bit masking with 0xFFFFFFFFFFFFFFF to extract the part of **int64_t** which will fit in a single cell. + +It also means that if we multiply two **int64_t**s into an **__int128_t**, we can then right-shift by 60 places to get the carry. \ No newline at end of file diff --git a/src/arith/integer.c b/src/arith/integer.c index ec242bd..f7bb77d 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -28,6 +28,11 @@ #include "consspaceobject.h" #include "debug.h" +/* + * The maximum value we will allow in an integer cell. + */ +#define MAX_INTEGER ((__int128_t)0xFFFFFFFFFFFFFFF) + /** * hexadecimal digits for printing numbers. */ @@ -98,36 +103,48 @@ struct cons_pointer add_integers( struct cons_pointer a, debug_print( L"Entering add_integers\n", DEBUG_ARITH ); struct cons_pointer result = NIL; - int64_t carry = 0; + 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" x ", DEBUG_ARITH ); + debug_print_object( b, DEBUG_ARITH ); + debug_printf( DEBUG_ARITH, L"; carry = %ld\n", carry ); + while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { - debug_print( L"add_integers: ", DEBUG_ARITH ); - debug_print_object( a, DEBUG_ARITH ); - debug_print( L" x ", DEBUG_ARITH ); - debug_print_object( b, DEBUG_ARITH ); - debug_printf( DEBUG_ARITH, L"; carry = %ld\n", carry ); + __int128_t av = + (__int128_t)integerp( a ) ? pointer2cell( a ).payload.integer.value : 0; + __int128_t bv = + (__int128_t)integerp( b ) ? pointer2cell( b ).payload.integer.value : 0; - int64_t av = - integerp( a ) ? pointer2cell( a ).payload.integer.value : 0; - int64_t bv = - integerp( b ) ? pointer2cell( b ).payload.integer.value : 0; + __int128_t rv = av + bv + carry; - int64_t rv = 0; - - if ( safe_add( &rv, av, bv ) ) { + 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"add_integers: 64 bit overflow; setting carry to %ld\n", - carry ); - carry = llabs( rv / LONG_MAX ); - rv = rv % LONG_MAX; + (int64_t)carry ); + rv = rv & MAX_INTEGER; + } + + struct cons_pointer tail = make_integer( (int64_t)(rv << 64), 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; } - result = make_integer( rv, result ); a = pointer2cell( a ).payload.integer.more; b = pointer2cell( b ).payload.integer.more; } @@ -146,7 +163,8 @@ struct cons_pointer add_integers( struct cons_pointer a, struct cons_pointer multiply_integers( struct cons_pointer a, struct cons_pointer b ) { struct cons_pointer result = NIL; - int64_t carry = 0; + struct cons_pointer cursor = NIL; + __int128_t carry = 0; if ( integerp( a ) && integerp( b ) ) { debug_print( L"multiply_integers: ", DEBUG_ARITH ); @@ -156,30 +174,52 @@ struct cons_pointer multiply_integers( struct cons_pointer a, debug_println( DEBUG_ARITH ); while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { - int64_t av = - integerp( a ) ? pointer2cell( a ).payload.integer.value : 1; - int64_t bv = - integerp( b ) ? pointer2cell( b ).payload.integer.value : 1; + __int128_t av = + (__int128_t)integerp( a ) ? pointer2cell( a ).payload.integer.value : 0; + __int128_t bv = + (__int128_t)integerp( b ) ? pointer2cell( b ).payload.integer.value : 0; - int64_t rv = 0; + /* 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 ( safe_mul( &rv, av, bv ) ) { + 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", - carry ); - carry = llabs( rv / LONG_MAX ); - rv = rv % LONG_MAX; + (int64_t)carry ); + rv = rv & MAX_INTEGER; + } + + struct cons_pointer tail = make_integer( (int64_t)(rv << 64), 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; } - result = make_integer( rv, result ); a = pointer2cell( a ).payload.integer.more; b = pointer2cell( b ).payload.integer.more; } } + debug_print( L"multiply_integers returning: ", DEBUG_ARITH ); debug_print_object( result, DEBUG_ARITH ); debug_println( DEBUG_ARITH ); diff --git a/src/arith/peano.c b/src/arith/peano.c index 3a24ed1..f34d632 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -284,10 +284,10 @@ struct cons_pointer multiply_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV: - result = - make_integer( cell1.payload.integer.value * - cell2.payload.integer.value, NIL ); - //result = multiply_integers( arg1, arg2 ); +// result = +// make_integer( cell1.payload.integer.value * +// cell2.payload.integer.value, NIL ); + result = multiply_integers( arg1, arg2 ); break; case RATIOTV: result = @@ -301,7 +301,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame, break; default: result = throw_exception( c_string_to_lisp_string - ( L"Cannot multiply: not a number" ), + ( L"Cannot multiply: argument 2 is not a number" ), frame_pointer ); break; } @@ -327,7 +327,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame, break; default: result = throw_exception( c_string_to_lisp_string - ( L"Cannot multiply: not a number" ), + ( L"Cannot multiply: argument 1 is not a number" ), frame_pointer ); } break; From d9d789fdd02455e9034e9c8cbc4070ff2971077f Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 3 Jan 2019 11:21:08 +0000 Subject: [PATCH 14/40] Now creating the correct internal bignum representation add_integers returns an integer which by inspection of the internal representation is correct, but the print representation is not correct. --- lisp/expt.lisp | 2 ++ notes/bignums.md | 4 +-- src/arith/integer.c | 58 +++++++++++++++++++++++++------------------- src/ops/read.c | 3 +++ unit-tests/bignum.sh | 14 +++++++++++ 5 files changed, 54 insertions(+), 27 deletions(-) create mode 100644 unit-tests/bignum.sh diff --git a/lisp/expt.lisp b/lisp/expt.lisp index db6a7b3..af1fff1 100644 --- a/lisp/expt.lisp +++ b/lisp/expt.lisp @@ -4,3 +4,5 @@ (cond ((= x 1) n) (t (* n (expt n (- x 1))))))) + +(expt 2 65) diff --git a/notes/bignums.md b/notes/bignums.md index ea4b0b3..f77653c 100644 --- a/notes/bignums.md +++ b/notes/bignums.md @@ -2,6 +2,6 @@ Each integer comprises at least one cell of type INTR, holding a signed 64 bit integer with a value in the range 0 ... MAX-INTEGER, where the actual value of MAX-INTEGER does not need to be the same as the C language LONG\_MAX, provided that it is less than this. It seems to me that a convenient number would be the largest number less than LONG\_MAX which has all bits set -LONG\_MAX is 0x7FFFFFFFFFFFFFFF, so the number we're looking for is 0xFFFFFFFFFFFFFFF, which is 1,152,921,504,606,846,975, which is 2^60 - 1. This means we can use bit masking with 0xFFFFFFFFFFFFFFF to extract the part of **int64_t** which will fit in a single cell. +LONG\_MAX is 0x7FFFFFFFFFFFFFFF, so the number we're looking for is 0x0FFFFFFFFFFFFFFF, which is 1,152,921,504,606,846,975, which is 2^60 - 1. This means we can use bit masking with 0xFFFFFFFFFFFFFFF to extract the part of **int64_t** which will fit in a single cell. -It also means that if we multiply two **int64_t**s into an **__int128_t**, we can then right-shift by 60 places to get the carry. \ No newline at end of file +It also means that if we multiply two **int64_t**s into an **__int128_t**, we can then right-shift by 60 places to get the carry. diff --git a/src/arith/integer.c b/src/arith/integer.c index f7bb77d..957b6bb 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -31,7 +31,7 @@ /* * The maximum value we will allow in an integer cell. */ -#define MAX_INTEGER ((__int128_t)0xFFFFFFFFFFFFFFF) +#define MAX_INTEGER ((__int128_t)0x0fffffffffffffffL) /** * hexadecimal digits for printing numbers. @@ -109,9 +109,9 @@ struct cons_pointer add_integers( struct cons_pointer a, if ( integerp( a ) && integerp( b ) ) { debug_print( L"add_integers: ", DEBUG_ARITH ); debug_print_object( a, DEBUG_ARITH ); - debug_print( L" x ", DEBUG_ARITH ); + debug_print( L" + ", DEBUG_ARITH ); debug_print_object( b, DEBUG_ARITH ); - debug_printf( DEBUG_ARITH, L"; carry = %ld\n", carry ); + debug_println( DEBUG_ARITH); while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { __int128_t av = @@ -133,16 +133,20 @@ struct cons_pointer add_integers( struct cons_pointer a, rv = rv & MAX_INTEGER; } - struct cons_pointer tail = make_integer( (int64_t)(rv << 64), NIL); + 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; + 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; @@ -150,7 +154,7 @@ struct cons_pointer add_integers( struct cons_pointer a, } } debug_print( L"add_integers returning: ", DEBUG_ARITH ); - debug_print_object( result, DEBUG_ARITH ); + debug_dump_object( result, DEBUG_ARITH ); debug_println( DEBUG_ARITH ); return result; @@ -167,10 +171,10 @@ struct cons_pointer multiply_integers( struct cons_pointer a, __int128_t carry = 0; if ( integerp( a ) && integerp( b ) ) { - debug_print( L"multiply_integers: ", DEBUG_ARITH ); - debug_print_object( a, DEBUG_ARITH ); - debug_print( L" x ", DEBUG_ARITH ); - debug_print_object( b, DEBUG_ARITH ); + 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 ) { @@ -196,19 +200,19 @@ struct cons_pointer multiply_integers( struct cons_pointer a, debug_printf( DEBUG_ARITH, L"multiply_integers: 64 bit overflow; setting carry to %ld\n", (int64_t)carry ); - rv = rv & MAX_INTEGER; + rv &= MAX_INTEGER; // <<< PROBLEM IS HERE! } - struct cons_pointer tail = make_integer( (int64_t)(rv << 64), NIL); + 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; + 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) ) { @@ -220,8 +224,8 @@ struct cons_pointer multiply_integers( struct cons_pointer a, } } - debug_print( L"multiply_integers returning: ", DEBUG_ARITH ); - debug_print_object( result, DEBUG_ARITH ); + debug_print( L"multiply_integers returning:\n", DEBUG_ARITH ); + debug_dump_object( result, DEBUG_ARITH ); debug_println( DEBUG_ARITH ); return result; @@ -260,7 +264,11 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, accumulator = llabs( accumulator ); int digits = 0; - if ( accumulator == 0 ) { + if ( accumulator == 0 && !nilp(integer.payload.integer.more) ) { + accumulator = MAX_INTEGER; + } + + if ( accumulator == 0) { result = c_string_to_lisp_string( L"0" ); } else { while ( accumulator > 0 ) { @@ -291,7 +299,7 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, accumulator += ( base * ( i / 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. */ diff --git a/src/ops/read.c b/src/ops/read.c index c83fc24..cc035a1 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -161,6 +161,9 @@ struct cons_pointer read_number( struct stack_frame *frame, wint_t initial, bool seen_period ) { debug_print( L"entering read_number\n", DEBUG_IO ); struct cons_pointer result = NIL; + + /* TODO: accumulator and dividend cannot be `int64_t`s, otherwise we cannot + * read bignums. They will have to be Lisp integers. */ int64_t accumulator = 0; int64_t dividend = 0; int places_of_decimals = 0; diff --git a/unit-tests/bignum.sh b/unit-tests/bignum.sh new file mode 100644 index 0000000..aa29143 --- /dev/null +++ b/unit-tests/bignum.sh @@ -0,0 +1,14 @@ +#!/bin/bash + +expected='1,152,921,504,606,846,976' +# 1,152,921,504,606,846,975 is the largest single cell positive integer; +# consequently 1,152,921,504,606,846,976 is the first two cell positive integer. +actual=`echo '(+ 1,152,921,504,606,846,975 1)' | target/psse -v 68 2>bignum.log | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi From 9b6a37ebb5ae6e2a3411fed9552d8b525c7afb78 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 4 Jan 2019 10:39:48 +0000 Subject: [PATCH 15/40] Now successfully reading/printing 2 cell bignums Something is wrong with n-cell bignums, but let's make haste slowly. --- src/arith/integer.c | 117 +++++++++++++++++++++----------------------- src/arith/peano.c | 111 +++++++++++++++++++++-------------------- src/arith/peano.h | 62 +++++++++++++++-------- src/arith/ratio.c | 10 +--- 4 files changed, 157 insertions(+), 143 deletions(-) diff --git a/src/arith/integer.c b/src/arith/integer.c index 957b6bb..d6162ea 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -111,13 +111,15 @@ struct cons_pointer add_integers( struct cons_pointer a, debug_print_object( a, DEBUG_ARITH ); debug_print( L" + ", DEBUG_ARITH ); debug_print_object( b, DEBUG_ARITH ); - debug_println( 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; + ( __int128_t ) integerp( a ) ? pointer2cell( a ). + payload.integer.value : 0; __int128_t bv = - (__int128_t)integerp( b ) ? pointer2cell( b ).payload.integer.value : 0; + ( __int128_t ) integerp( b ) ? pointer2cell( b ). + payload.integer.value : 0; __int128_t rv = av + bv + carry; @@ -126,27 +128,27 @@ struct cons_pointer add_integers( struct cons_pointer a, } else { // TODO: we're correctly detecting overflow, but not yet correctly // handling it. - carry = rv >> 60; + carry = rv >> 60; debug_printf( DEBUG_ARITH, L"add_integers: 64 bit overflow; setting carry to %ld\n", - (int64_t)carry ); + ( int64_t ) carry ); rv = rv & MAX_INTEGER; } - struct cons_pointer tail = make_integer( (int64_t)rv, NIL); + struct cons_pointer tail = make_integer( ( int64_t ) rv, NIL ); - if (nilp(cursor)) { - cursor = tail; + 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; + 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; + if ( nilp( result ) ) { + result = cursor; } a = pointer2cell( a ).payload.integer.more; @@ -179,9 +181,11 @@ struct cons_pointer multiply_integers( struct cons_pointer a, while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { __int128_t av = - (__int128_t)integerp( a ) ? pointer2cell( a ).payload.integer.value : 0; + ( __int128_t ) integerp( a ) ? pointer2cell( a ). + payload.integer.value : 1; __int128_t bv = - (__int128_t)integerp( b ) ? pointer2cell( b ).payload.integer.value : 0; + ( __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 @@ -189,34 +193,34 @@ struct cons_pointer multiply_integers( struct cons_pointer a, * intellectually up to proving it this morning) adding the carry might * overflow `__int128_t`. Edge-case testing required. */ - __int128_t rv = (av * bv) + carry; + __int128_t rv = ( av * bv ) + carry; - if ( MAX_INTEGER >= rv ) { + if ( MAX_INTEGER >= rv ) { carry = 0; } else { // TODO: we're correctly detecting overflow, but not yet correctly // handling it. - carry = rv >> 60; + carry = rv >> 60; debug_printf( DEBUG_ARITH, L"multiply_integers: 64 bit overflow; setting carry to %ld\n", - (int64_t)carry ); - rv &= MAX_INTEGER; // <<< PROBLEM IS HERE! + ( int64_t ) carry ); + rv &= MAX_INTEGER; } - struct cons_pointer tail = make_integer( (int64_t)rv, NIL); + struct cons_pointer tail = make_integer( ( int64_t ) rv, NIL ); - if (nilp(cursor)) { - cursor = tail; + 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; - } + 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; + if ( nilp( result ) ) { + result = cursor; } a = pointer2cell( a ).payload.integer.more; @@ -259,25 +263,27 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, int base ) { struct cons_pointer result = NIL; struct cons_space_object integer = pointer2cell( int_pointer ); - int64_t accumulator = integer.payload.integer.value; - bool is_negative = accumulator < 0; - accumulator = llabs( accumulator ); + __int128_t accumulator = llabs( integer.payload.integer.value ); + bool is_negative = integer.payload.integer.value < 0; int digits = 0; - if ( accumulator == 0 && !nilp(integer.payload.integer.more) ) { - accumulator = MAX_INTEGER; - } - - if ( accumulator == 0) { + if ( accumulator == 0 && nilp( integer.payload.integer.more ) ) { result = c_string_to_lisp_string( L"0" ); } else { - while ( accumulator > 0 ) { + while ( accumulator > 0 || !nilp( integer.payload.integer.more ) ) { + if ( !nilp( integer.payload.integer.more ) ) { + integer = pointer2cell( integer.payload.integer.more ); + accumulator += + ( llabs( integer.payload.integer.value ) * + ( MAX_INTEGER + 1 ) ); + } + debug_printf( DEBUG_IO, L"integer_to_string: accumulator is %ld\n:", accumulator ); do { debug_printf( DEBUG_IO, - L"integer_to_string: digit is %ld, hexadecimal is %lc\n:", + L"integer_to_string: digit is %ld, hexadecimal is %c\n:", accumulator % base, hex_digits[accumulator % base] ); @@ -286,26 +292,15 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, result ); accumulator = accumulator / base; } while ( accumulator > base ); - - if ( integerp( integer.payload.integer.more ) ) { - integer = pointer2cell( integer.payload.integer.more ); - int64_t i = integer.payload.integer.value; - - /* TODO: I don't believe it's as simple as this! */ - accumulator += ( base * ( i % base ) ); - result = - integer_to_string_add_digit( accumulator % base, digits++, - result ); - accumulator += ( base * ( i / 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. */ - struct cons_pointer tmp = result; - result = pointer2cell(result).payload.string.cdr; - dec_ref(tmp); + 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. */ + struct cons_pointer tmp = result; + result = pointer2cell( result ).payload.string.cdr; + dec_ref( tmp ); } if ( is_negative ) { diff --git a/src/arith/peano.c b/src/arith/peano.c index f34d632..481f33e 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -105,6 +105,9 @@ int64_t to_long_int( struct cons_pointer arg ) { 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: @@ -252,9 +255,9 @@ struct cons_pointer lisp_add( struct stack_frame /** -* return a cons_pointer indicating a number which is the product of -* the numbers indicated by `arg1` and `arg2`. -*/ + * 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, @@ -284,9 +287,6 @@ struct cons_pointer multiply_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV: -// result = -// make_integer( cell1.payload.integer.value * -// cell2.payload.integer.value, NIL ); result = multiply_integers( arg1, arg2 ); break; case RATIOTV: @@ -351,7 +351,6 @@ struct cons_pointer multiply_2( struct stack_frame *frame, return result; } - /** * Multiply an indefinite number of numbers together * @param env the evaluation environment - ignored; @@ -393,10 +392,10 @@ struct cons_pointer lisp_multiply( struct /** * return a cons_pointer indicating a number which is the - * inverse of the number indicated by `arg`. + * 0 - the number indicated by `arg`. */ -struct cons_pointer inverse( struct cons_pointer frame, - struct cons_pointer arg ) { +struct cons_pointer negative( struct cons_pointer frame, + struct cons_pointer arg ) { struct cons_pointer result = NIL; struct cons_space_object cell = pointer2cell( arg ); @@ -405,18 +404,17 @@ struct cons_pointer inverse( struct cons_pointer frame, result = arg; break; case INTEGERTV: - // TODO: bignums - result = make_integer( 0 - to_long_int( arg ), NIL ); + result = + make_integer( 0 - cell.payload.integer.value, + cell.payload.integer.more ); break; case NILTV: result = TRUE; break; case RATIOTV: result = make_ratio( frame, - make_integer( 0 - - to_long_int( cell.payload. - ratio.dividend ), - NIL ), + negative( frame, + cell.payload.ratio.dividend ), cell.payload.ratio.divisor ); break; case REALTV: @@ -430,50 +428,48 @@ struct cons_pointer inverse( struct cons_pointer frame, return result; } - /** - * Subtract one number from another. - * @param env the evaluation environment - ignored; - * @param frame the stack frame. - * @return a pointer to an integer or real. + * return a cons_pointer indicating a number which is the result of + * subtracting the numbers indicated by `arg2` from that indicated by `arg1`, + * in the context of this `frame`. */ -struct cons_pointer lisp_subtract( struct - stack_frame - *frame, struct cons_pointer frame_pointer, struct - cons_pointer env ) { +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; - struct cons_space_object cell0 = pointer2cell( frame->arg[0] ); - struct cons_space_object cell1 = pointer2cell( frame->arg[1] ); - switch ( cell0.tag.value ) { + switch ( pointer2cell( arg1 ).tag.value ) { case EXCEPTIONTV: - result = frame->arg[0]; + result = arg1; break; case INTEGERTV: - switch ( cell1.tag.value ) { + switch ( pointer2cell( arg2 ).tag.value ) { case EXCEPTIONTV: - result = frame->arg[1]; + result = arg2; break; - case INTEGERTV: - result = make_integer( cell0.payload.integer.value - - cell1.payload.integer.value, - NIL ); + case INTEGERTV:{ + struct cons_pointer i = + negative( frame_pointer, arg2 ); + inc_ref( i ); + result = add_integers( arg1, i ); + dec_ref( i ); + } break; case RATIOTV:{ struct cons_pointer tmp = - make_ratio( frame_pointer, frame->arg[0], + make_ratio( frame_pointer, arg1, make_integer( 1, NIL ) ); inc_ref( tmp ); result = - subtract_ratio_ratio( frame_pointer, tmp, - frame->arg[1] ); + subtract_ratio_ratio( frame_pointer, tmp, arg2 ); dec_ref( tmp ); } break; case REALTV: result = - make_real( to_long_double( frame->arg[0] ) - - to_long_double( frame->arg[1] ) ); + make_real( to_long_double( arg1 ) - + to_long_double( arg2 ) ); break; default: result = throw_exception( c_string_to_lisp_string @@ -483,30 +479,27 @@ struct cons_pointer lisp_subtract( struct } break; case RATIOTV: - switch ( cell1.tag.value ) { + switch ( pointer2cell( arg2 ).tag.value ) { case EXCEPTIONTV: - result = frame->arg[1]; + result = arg2; break; case INTEGERTV:{ struct cons_pointer tmp = - make_ratio( frame_pointer, frame->arg[1], + make_ratio( frame_pointer, arg2, make_integer( 1, NIL ) ); inc_ref( tmp ); result = - subtract_ratio_ratio( frame_pointer, frame->arg[0], - tmp ); + subtract_ratio_ratio( frame_pointer, arg1, tmp ); dec_ref( tmp ); } break; case RATIOTV: - result = - subtract_ratio_ratio( frame_pointer, frame->arg[0], - frame->arg[1] ); + result = subtract_ratio_ratio( frame_pointer, arg1, arg2 ); break; case REALTV: result = - make_real( to_long_double( frame->arg[0] ) - - to_long_double( frame->arg[1] ) ); + make_real( to_long_double( arg1 ) - + to_long_double( arg2 ) ); break; default: result = throw_exception( c_string_to_lisp_string @@ -516,9 +509,8 @@ struct cons_pointer lisp_subtract( struct } 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] ) ); + result = exceptionp( arg2 ) ? arg2 : + make_real( to_long_double( arg1 ) - to_long_double( arg2 ) ); break; default: result = throw_exception( c_string_to_lisp_string @@ -532,6 +524,19 @@ struct cons_pointer lisp_subtract( struct return result; } +/** + * Subtract one number from another. + * @param env the evaluation environment - ignored; + * @param frame the stack frame. + * @return a pointer to an integer or real. + */ +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. * @param env the evaluation environment - ignored; diff --git a/src/arith/peano.h b/src/arith/peano.h index f1c21b4..0bd09d5 100644 --- a/src/arith/peano.h +++ b/src/arith/peano.h @@ -12,9 +12,17 @@ #ifndef PEANO_H #define PEANO_H -#ifdef __cplusplus -extern "C" { -#endif +bool zerop( struct cons_pointer arg ); + +struct cons_pointer negative( struct cons_pointer frame, + struct cons_pointer arg ); + +/** + * 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 ); /** * Add an indefinite number of numbers together @@ -22,9 +30,9 @@ extern "C" { * @param frame the stack frame. * @return a pointer to an integer or real. */ - struct cons_pointer - lisp_add( 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 ); /** * Multiply an indefinite number of numbers together @@ -32,10 +40,26 @@ extern "C" { * @param frame the stack frame. * @return a pointer to an integer or real. */ - struct cons_pointer - lisp_multiply( 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 ); + +/** + * 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 ); + +/** + * return a cons_pointer indicating a number which is the result of + * subtracting the numbers 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 ); /** * Subtract one number from another. @@ -43,10 +67,9 @@ extern "C" { * @param frame the stack frame. * @return a pointer to an integer or real. */ - struct cons_pointer - lisp_subtract( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer +lisp_subtract( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ); /** * Divide one number by another. @@ -54,11 +77,8 @@ extern "C" { * @param frame the stack frame. * @return a pointer to an integer or real. */ - struct cons_pointer - lisp_divide( 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 ); -#ifdef __cplusplus -} -#endif -#endif /* PEANO_H */ +#endif /* PEANO_H */ diff --git a/src/arith/ratio.c b/src/arith/ratio.c index fd6a770..f9dd0f4 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -17,17 +17,11 @@ #include "equal.h" #include "integer.h" #include "lispops.h" +#include "peano.h" #include "print.h" #include "ratio.h" -/* - * declared in peano.c, can't include piano.h here because - * circularity. TODO: refactor. - */ -struct cons_pointer inverse( struct cons_pointer frame_pointer, - struct cons_pointer arg ); - /** * return, as a int64_t, the greatest common divisor of `m` and `n`, */ @@ -297,7 +291,7 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg1, struct cons_pointer arg2 ) { - struct cons_pointer i = inverse( frame_pointer, arg2 ), + struct cons_pointer i = negative( frame_pointer, arg2 ), result = add_ratio_ratio( frame_pointer, arg1, i ); dec_ref( i ); From 67802a07b8f5b97502f1e7ae1102ccee5ce04b64 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 4 Jan 2019 10:39:48 +0000 Subject: [PATCH 16/40] Now successfully reading/printing 2 cell bignums Something is wrong with n-cell bignums, but let's make haste slowly. --- src/arith/integer.c | 117 +++++++++++++++++++++----------------------- src/arith/peano.c | 111 +++++++++++++++++++++-------------------- src/arith/peano.h | 62 +++++++++++++++-------- src/arith/ratio.c | 10 +--- src/ops/read.c | 66 +++++++++++++------------ 5 files changed, 192 insertions(+), 174 deletions(-) diff --git a/src/arith/integer.c b/src/arith/integer.c index 957b6bb..d6162ea 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -111,13 +111,15 @@ struct cons_pointer add_integers( struct cons_pointer a, debug_print_object( a, DEBUG_ARITH ); debug_print( L" + ", DEBUG_ARITH ); debug_print_object( b, DEBUG_ARITH ); - debug_println( 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; + ( __int128_t ) integerp( a ) ? pointer2cell( a ). + payload.integer.value : 0; __int128_t bv = - (__int128_t)integerp( b ) ? pointer2cell( b ).payload.integer.value : 0; + ( __int128_t ) integerp( b ) ? pointer2cell( b ). + payload.integer.value : 0; __int128_t rv = av + bv + carry; @@ -126,27 +128,27 @@ struct cons_pointer add_integers( struct cons_pointer a, } else { // TODO: we're correctly detecting overflow, but not yet correctly // handling it. - carry = rv >> 60; + carry = rv >> 60; debug_printf( DEBUG_ARITH, L"add_integers: 64 bit overflow; setting carry to %ld\n", - (int64_t)carry ); + ( int64_t ) carry ); rv = rv & MAX_INTEGER; } - struct cons_pointer tail = make_integer( (int64_t)rv, NIL); + struct cons_pointer tail = make_integer( ( int64_t ) rv, NIL ); - if (nilp(cursor)) { - cursor = tail; + 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; + 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; + if ( nilp( result ) ) { + result = cursor; } a = pointer2cell( a ).payload.integer.more; @@ -179,9 +181,11 @@ struct cons_pointer multiply_integers( struct cons_pointer a, while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { __int128_t av = - (__int128_t)integerp( a ) ? pointer2cell( a ).payload.integer.value : 0; + ( __int128_t ) integerp( a ) ? pointer2cell( a ). + payload.integer.value : 1; __int128_t bv = - (__int128_t)integerp( b ) ? pointer2cell( b ).payload.integer.value : 0; + ( __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 @@ -189,34 +193,34 @@ struct cons_pointer multiply_integers( struct cons_pointer a, * intellectually up to proving it this morning) adding the carry might * overflow `__int128_t`. Edge-case testing required. */ - __int128_t rv = (av * bv) + carry; + __int128_t rv = ( av * bv ) + carry; - if ( MAX_INTEGER >= rv ) { + if ( MAX_INTEGER >= rv ) { carry = 0; } else { // TODO: we're correctly detecting overflow, but not yet correctly // handling it. - carry = rv >> 60; + carry = rv >> 60; debug_printf( DEBUG_ARITH, L"multiply_integers: 64 bit overflow; setting carry to %ld\n", - (int64_t)carry ); - rv &= MAX_INTEGER; // <<< PROBLEM IS HERE! + ( int64_t ) carry ); + rv &= MAX_INTEGER; } - struct cons_pointer tail = make_integer( (int64_t)rv, NIL); + struct cons_pointer tail = make_integer( ( int64_t ) rv, NIL ); - if (nilp(cursor)) { - cursor = tail; + 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; - } + 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; + if ( nilp( result ) ) { + result = cursor; } a = pointer2cell( a ).payload.integer.more; @@ -259,25 +263,27 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, int base ) { struct cons_pointer result = NIL; struct cons_space_object integer = pointer2cell( int_pointer ); - int64_t accumulator = integer.payload.integer.value; - bool is_negative = accumulator < 0; - accumulator = llabs( accumulator ); + __int128_t accumulator = llabs( integer.payload.integer.value ); + bool is_negative = integer.payload.integer.value < 0; int digits = 0; - if ( accumulator == 0 && !nilp(integer.payload.integer.more) ) { - accumulator = MAX_INTEGER; - } - - if ( accumulator == 0) { + if ( accumulator == 0 && nilp( integer.payload.integer.more ) ) { result = c_string_to_lisp_string( L"0" ); } else { - while ( accumulator > 0 ) { + while ( accumulator > 0 || !nilp( integer.payload.integer.more ) ) { + if ( !nilp( integer.payload.integer.more ) ) { + integer = pointer2cell( integer.payload.integer.more ); + accumulator += + ( llabs( integer.payload.integer.value ) * + ( MAX_INTEGER + 1 ) ); + } + debug_printf( DEBUG_IO, L"integer_to_string: accumulator is %ld\n:", accumulator ); do { debug_printf( DEBUG_IO, - L"integer_to_string: digit is %ld, hexadecimal is %lc\n:", + L"integer_to_string: digit is %ld, hexadecimal is %c\n:", accumulator % base, hex_digits[accumulator % base] ); @@ -286,26 +292,15 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, result ); accumulator = accumulator / base; } while ( accumulator > base ); - - if ( integerp( integer.payload.integer.more ) ) { - integer = pointer2cell( integer.payload.integer.more ); - int64_t i = integer.payload.integer.value; - - /* TODO: I don't believe it's as simple as this! */ - accumulator += ( base * ( i % base ) ); - result = - integer_to_string_add_digit( accumulator % base, digits++, - result ); - accumulator += ( base * ( i / 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. */ - struct cons_pointer tmp = result; - result = pointer2cell(result).payload.string.cdr; - dec_ref(tmp); + 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. */ + struct cons_pointer tmp = result; + result = pointer2cell( result ).payload.string.cdr; + dec_ref( tmp ); } if ( is_negative ) { diff --git a/src/arith/peano.c b/src/arith/peano.c index f34d632..481f33e 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -105,6 +105,9 @@ int64_t to_long_int( struct cons_pointer arg ) { 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: @@ -252,9 +255,9 @@ struct cons_pointer lisp_add( struct stack_frame /** -* return a cons_pointer indicating a number which is the product of -* the numbers indicated by `arg1` and `arg2`. -*/ + * 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, @@ -284,9 +287,6 @@ struct cons_pointer multiply_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV: -// result = -// make_integer( cell1.payload.integer.value * -// cell2.payload.integer.value, NIL ); result = multiply_integers( arg1, arg2 ); break; case RATIOTV: @@ -351,7 +351,6 @@ struct cons_pointer multiply_2( struct stack_frame *frame, return result; } - /** * Multiply an indefinite number of numbers together * @param env the evaluation environment - ignored; @@ -393,10 +392,10 @@ struct cons_pointer lisp_multiply( struct /** * return a cons_pointer indicating a number which is the - * inverse of the number indicated by `arg`. + * 0 - the number indicated by `arg`. */ -struct cons_pointer inverse( struct cons_pointer frame, - struct cons_pointer arg ) { +struct cons_pointer negative( struct cons_pointer frame, + struct cons_pointer arg ) { struct cons_pointer result = NIL; struct cons_space_object cell = pointer2cell( arg ); @@ -405,18 +404,17 @@ struct cons_pointer inverse( struct cons_pointer frame, result = arg; break; case INTEGERTV: - // TODO: bignums - result = make_integer( 0 - to_long_int( arg ), NIL ); + result = + make_integer( 0 - cell.payload.integer.value, + cell.payload.integer.more ); break; case NILTV: result = TRUE; break; case RATIOTV: result = make_ratio( frame, - make_integer( 0 - - to_long_int( cell.payload. - ratio.dividend ), - NIL ), + negative( frame, + cell.payload.ratio.dividend ), cell.payload.ratio.divisor ); break; case REALTV: @@ -430,50 +428,48 @@ struct cons_pointer inverse( struct cons_pointer frame, return result; } - /** - * Subtract one number from another. - * @param env the evaluation environment - ignored; - * @param frame the stack frame. - * @return a pointer to an integer or real. + * return a cons_pointer indicating a number which is the result of + * subtracting the numbers indicated by `arg2` from that indicated by `arg1`, + * in the context of this `frame`. */ -struct cons_pointer lisp_subtract( struct - stack_frame - *frame, struct cons_pointer frame_pointer, struct - cons_pointer env ) { +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; - struct cons_space_object cell0 = pointer2cell( frame->arg[0] ); - struct cons_space_object cell1 = pointer2cell( frame->arg[1] ); - switch ( cell0.tag.value ) { + switch ( pointer2cell( arg1 ).tag.value ) { case EXCEPTIONTV: - result = frame->arg[0]; + result = arg1; break; case INTEGERTV: - switch ( cell1.tag.value ) { + switch ( pointer2cell( arg2 ).tag.value ) { case EXCEPTIONTV: - result = frame->arg[1]; + result = arg2; break; - case INTEGERTV: - result = make_integer( cell0.payload.integer.value - - cell1.payload.integer.value, - NIL ); + case INTEGERTV:{ + struct cons_pointer i = + negative( frame_pointer, arg2 ); + inc_ref( i ); + result = add_integers( arg1, i ); + dec_ref( i ); + } break; case RATIOTV:{ struct cons_pointer tmp = - make_ratio( frame_pointer, frame->arg[0], + make_ratio( frame_pointer, arg1, make_integer( 1, NIL ) ); inc_ref( tmp ); result = - subtract_ratio_ratio( frame_pointer, tmp, - frame->arg[1] ); + subtract_ratio_ratio( frame_pointer, tmp, arg2 ); dec_ref( tmp ); } break; case REALTV: result = - make_real( to_long_double( frame->arg[0] ) - - to_long_double( frame->arg[1] ) ); + make_real( to_long_double( arg1 ) - + to_long_double( arg2 ) ); break; default: result = throw_exception( c_string_to_lisp_string @@ -483,30 +479,27 @@ struct cons_pointer lisp_subtract( struct } break; case RATIOTV: - switch ( cell1.tag.value ) { + switch ( pointer2cell( arg2 ).tag.value ) { case EXCEPTIONTV: - result = frame->arg[1]; + result = arg2; break; case INTEGERTV:{ struct cons_pointer tmp = - make_ratio( frame_pointer, frame->arg[1], + make_ratio( frame_pointer, arg2, make_integer( 1, NIL ) ); inc_ref( tmp ); result = - subtract_ratio_ratio( frame_pointer, frame->arg[0], - tmp ); + subtract_ratio_ratio( frame_pointer, arg1, tmp ); dec_ref( tmp ); } break; case RATIOTV: - result = - subtract_ratio_ratio( frame_pointer, frame->arg[0], - frame->arg[1] ); + result = subtract_ratio_ratio( frame_pointer, arg1, arg2 ); break; case REALTV: result = - make_real( to_long_double( frame->arg[0] ) - - to_long_double( frame->arg[1] ) ); + make_real( to_long_double( arg1 ) - + to_long_double( arg2 ) ); break; default: result = throw_exception( c_string_to_lisp_string @@ -516,9 +509,8 @@ struct cons_pointer lisp_subtract( struct } 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] ) ); + result = exceptionp( arg2 ) ? arg2 : + make_real( to_long_double( arg1 ) - to_long_double( arg2 ) ); break; default: result = throw_exception( c_string_to_lisp_string @@ -532,6 +524,19 @@ struct cons_pointer lisp_subtract( struct return result; } +/** + * Subtract one number from another. + * @param env the evaluation environment - ignored; + * @param frame the stack frame. + * @return a pointer to an integer or real. + */ +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. * @param env the evaluation environment - ignored; diff --git a/src/arith/peano.h b/src/arith/peano.h index f1c21b4..0bd09d5 100644 --- a/src/arith/peano.h +++ b/src/arith/peano.h @@ -12,9 +12,17 @@ #ifndef PEANO_H #define PEANO_H -#ifdef __cplusplus -extern "C" { -#endif +bool zerop( struct cons_pointer arg ); + +struct cons_pointer negative( struct cons_pointer frame, + struct cons_pointer arg ); + +/** + * 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 ); /** * Add an indefinite number of numbers together @@ -22,9 +30,9 @@ extern "C" { * @param frame the stack frame. * @return a pointer to an integer or real. */ - struct cons_pointer - lisp_add( 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 ); /** * Multiply an indefinite number of numbers together @@ -32,10 +40,26 @@ extern "C" { * @param frame the stack frame. * @return a pointer to an integer or real. */ - struct cons_pointer - lisp_multiply( 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 ); + +/** + * 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 ); + +/** + * return a cons_pointer indicating a number which is the result of + * subtracting the numbers 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 ); /** * Subtract one number from another. @@ -43,10 +67,9 @@ extern "C" { * @param frame the stack frame. * @return a pointer to an integer or real. */ - struct cons_pointer - lisp_subtract( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer +lisp_subtract( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ); /** * Divide one number by another. @@ -54,11 +77,8 @@ extern "C" { * @param frame the stack frame. * @return a pointer to an integer or real. */ - struct cons_pointer - lisp_divide( 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 ); -#ifdef __cplusplus -} -#endif -#endif /* PEANO_H */ +#endif /* PEANO_H */ diff --git a/src/arith/ratio.c b/src/arith/ratio.c index fd6a770..f9dd0f4 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -17,17 +17,11 @@ #include "equal.h" #include "integer.h" #include "lispops.h" +#include "peano.h" #include "print.h" #include "ratio.h" -/* - * declared in peano.c, can't include piano.h here because - * circularity. TODO: refactor. - */ -struct cons_pointer inverse( struct cons_pointer frame_pointer, - struct cons_pointer arg ); - /** * return, as a int64_t, the greatest common divisor of `m` and `n`, */ @@ -297,7 +291,7 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg1, struct cons_pointer arg2 ) { - struct cons_pointer i = inverse( frame_pointer, arg2 ), + struct cons_pointer i = negative( frame_pointer, arg2 ), result = add_ratio_ratio( frame_pointer, arg1, i ); dec_ref( i ); diff --git a/src/ops/read.c b/src/ops/read.c index cc035a1..9074652 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -23,6 +23,7 @@ #include "integer.h" #include "intern.h" #include "lispops.h" +#include "peano.h" #include "print.h" #include "ratio.h" #include "read.h" @@ -152,25 +153,25 @@ struct cons_pointer read_continuation( struct stack_frame *frame, /** * read a number from this input stream, given this initial character. - * TODO: to be able to read bignums, we need to read the number from the - * input stream into a Lisp string, and then convert it to a number. + * TODO: Need to do a lot of inc_ref and dec_ref, to make sure the + * garbage is collected. */ struct cons_pointer read_number( struct stack_frame *frame, struct cons_pointer frame_pointer, FILE * input, wint_t initial, bool seen_period ) { debug_print( L"entering read_number\n", DEBUG_IO ); - struct cons_pointer result = NIL; - /* TODO: accumulator and dividend cannot be `int64_t`s, otherwise we cannot - * read bignums. They will have to be Lisp integers. */ - int64_t accumulator = 0; - int64_t dividend = 0; + struct cons_pointer result = make_integer( 0, NIL ); + /* TODO: we really need to be getting `base` from a privileged Lisp name - + * and it should be the same privileged name we use when writing numbers */ + struct cons_pointer base = make_integer( 10, NIL ); + struct cons_pointer dividend = NIL; int places_of_decimals = 0; wint_t c; - bool negative = initial == btowc( '-' ); + bool neg = initial == btowc( '-' ); - if ( negative ) { + if ( neg ) { initial = fgetwc( input ); } @@ -180,7 +181,7 @@ struct cons_pointer read_number( struct stack_frame *frame, for ( c = initial; iswdigit( c ) || c == L'.' || c == L'/' || c == L','; c = fgetwc( input ) ) { if ( c == btowc( '.' ) ) { - if ( seen_period || dividend != 0 ) { + if ( seen_period || !nilp( dividend ) ) { return throw_exception( c_string_to_lisp_string ( L"Malformed number: too many periods" ), frame_pointer ); @@ -188,23 +189,24 @@ struct cons_pointer read_number( struct stack_frame *frame, seen_period = true; } } else if ( c == btowc( '/' ) ) { - if ( seen_period || dividend > 0 ) { + if ( seen_period || !nilp( dividend ) ) { return throw_exception( c_string_to_lisp_string ( L"Malformed number: dividend of rational must be integer" ), frame_pointer ); } else { - dividend = negative ? 0 - accumulator : accumulator; + dividend = result; - accumulator = 0; + result = make_integer( 0, NIL ); } } else if ( c == L',' ) { // silently ignore it. } else { - accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' ); + result = add_integers( multiply_integers( result, base ), + make_integer( ( int ) c - ( int ) '0', + NIL ) ); debug_printf( DEBUG_IO, - L"Added character %c, accumulator now %ld\n", - c, accumulator ); + L"Added character %c, result now %ld\n", c, result ); if ( seen_period ) { places_of_decimals++; @@ -217,21 +219,23 @@ struct cons_pointer read_number( struct stack_frame *frame, */ ungetwc( c, input ); if ( seen_period ) { - long double rv = ( long double ) - ( accumulator / pow( 10, places_of_decimals ) ); - if ( negative ) { - rv = 0 - rv; - } - result = make_real( rv ); - } else if ( dividend != 0 ) { - result = - make_ratio( frame_pointer, make_integer( dividend, NIL ), - make_integer( accumulator, NIL ) ); - } else { - if ( negative ) { - accumulator = 0 - accumulator; - } - result = make_integer( accumulator, NIL ); + struct cons_pointer div = make_ratio( frame_pointer, result, + make_integer( powl + ( to_long_double + ( base ), + places_of_decimals ), + NIL ) ); + inc_ref( div ); + + result = make_real( to_long_double( div ) ); + + dec_ref( div ); + } else if ( integerp( dividend ) ) { + result = make_ratio( frame_pointer, dividend, result ); + } + + if ( neg ) { + result = negative( frame_pointer, result ); } debug_print( L"read_number returning\n", DEBUG_IO ); From 67443e1d462a5f7befe03b1aa38963e9725f9ce2 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 4 Jan 2019 11:04:55 +0000 Subject: [PATCH 17/40] OK, adding bignums works; multiplying bignums does not work. There's no evidence of a bug in reading/printing, because the only way I can currently get a number big enough to trigger the supposed bug is by multiplying, which doesn't work. --- src/arith/integer.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/arith/integer.c b/src/arith/integer.c index d6162ea..9b23001 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -79,7 +79,7 @@ long double numeric_value( struct cons_pointer pointer ) { */ 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_ARITH ); + debug_print( L"Entering make_integer\n", DEBUG_ALLOC ); if ( integerp( more ) || nilp( more ) ) { result = allocate_cell( INTEGERTAG ); @@ -89,8 +89,8 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { } - debug_print( L"make_integer: returning\n", DEBUG_ARITH ); - debug_dump_object( result, DEBUG_ARITH ); + debug_print( L"make_integer: returning\n", DEBUG_ALLOC ); + debug_dump_object( result, DEBUG_ALLOC ); return result; } From 396e214b5fb99c32fda2c260d96b68f8fb8cdfc8 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 4 Jan 2019 11:24:05 +0000 Subject: [PATCH 18/40] Increased maximum memory allocation --- lisp/fact.lisp | 2 +- src/memory/conspage.h | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/fact.lisp b/lisp/fact.lisp index 7df7246..86d452a 100644 --- a/lisp/fact.lisp +++ b/lisp/fact.lisp @@ -4,4 +4,4 @@ (cond ((= n 1) 1) (t (* n (fact (- n 1))))))) -(fact 21) +(fact 1000) diff --git a/src/memory/conspage.h b/src/memory/conspage.h index bc1361e..aff6f40 100644 --- a/src/memory/conspage.h +++ b/src/memory/conspage.h @@ -9,7 +9,7 @@ * to) is the maximum value of an unsigned 32 bit integer, which is to * say 4294967296. However, we'll start small. */ -#define CONSPAGESIZE 8 +#define CONSPAGESIZE 1024 /** * the number of cons pages we will initially allow for. For @@ -25,7 +25,7 @@ * of addressable memory, which is only slightly more than the * number of atoms in the universe. */ -#define NCONSPAGES 8 +#define NCONSPAGES 64 /** * a cons page is essentially just an array of cons space objects. It From d624c671cdbf55a8b475fcc385efca343a9cd664 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 5 Jan 2019 11:42:17 +0000 Subject: [PATCH 19/40] Major refactoring, all tests still pass Bignum issues not yet folly resolved. --- src/arith/integer.c | 159 +++++++++++++++++--------------------------- src/init.c | 1 + src/memory/dump.c | 1 + src/memory/dump.h | 1 - src/ops/lispops.c | 30 ++++++++- src/ops/lispops.h | 3 + 6 files changed, 96 insertions(+), 99 deletions(-) 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 ); From 7f93b04b725eed8932920917e3836eb99385fb23 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 17 Jan 2019 17:04:14 +0000 Subject: [PATCH 20/40] Various refactorings around bignum arithmetic --- src/arith/integer.c | 26 ++++++-- src/arith/peano.c | 7 +- src/debug.c | 23 +++++++ src/debug.h | 1 + src/ops/lispops.c | 3 +- src/ops/read.c | 159 ++++++++++++++++++++++++-------------------- 6 files changed, 134 insertions(+), 85 deletions(-) diff --git a/src/arith/integer.c b/src/arith/integer.c index 779a112..a5e2271 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -36,7 +36,7 @@ /** * hexadecimal digits for printing numbers. */ -const wchar_t hex_digits[16] = L"0123456789ABCDEF"; +const char * hex_digits = "0123456789ABCDEF"; /* * Doctrine from here on in is that ALL integers are bignums, it's just @@ -133,13 +133,24 @@ struct cons_pointer operate_on_integers( struct cons_pointer a, switch (op) { case '*': - rv = ( av * bv ) + carry; + rv = av * bv * ((carry == 0) ? 1 : carry); break; case '+': rv = av + bv + carry; break; } + debug_printf( DEBUG_ARITH, L"operate_on_integers: op = '%c'; av = ", op); + 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 ( MAX_INTEGER >= rv ) { carry = 0; } else { @@ -206,7 +217,7 @@ struct cons_pointer multiply_integers( struct cons_pointer a, struct cons_pointer integer_to_string_add_digit( int digit, int digits, struct cons_pointer tail ) { digits++; - wint_t character = ( wint_t ) hex_digits[digit]; + wint_t character = btowc(hex_digits[digit]); return ( digits % 3 == 0 ) ? make_string( L',', make_string( character, tail ) ) : @@ -247,13 +258,14 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, L"integer_to_string: accumulator is %ld\n:", accumulator ); do { + int offset = (int)(accumulator % base); debug_printf( DEBUG_IO, - L"integer_to_string: digit is %ld, hexadecimal is %C\n:", - accumulator % base, - btowc(hex_digits[accumulator % base] )); + L"integer_to_string: digit is %ld, hexadecimal is %c\n:", + offset, + hex_digits[offset] ); result = - integer_to_string_add_digit( accumulator % base, digits++, + integer_to_string_add_digit( offset, digits++, result ); accumulator = accumulator / base; } while ( accumulator > base ); diff --git a/src/arith/peano.c b/src/arith/peano.c index 481f33e..1dded80 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -41,7 +41,8 @@ bool zerop( struct cons_pointer arg ) { switch ( cell.tag.value ) { case INTEGERTV: - result = cell.payload.integer.value == 0; + result = cell.payload.integer.value == 0 && + nilp(cell.payload.integer.more); break; case RATIOTV: result = zerop( cell.payload.ratio.dividend ); @@ -134,9 +135,9 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_space_object cell2 = pointer2cell( arg2 ); debug_print( L"add_2( arg1 = ", DEBUG_ARITH ); - debug_print_object( arg1, DEBUG_ARITH ); + debug_dump_object( arg1, DEBUG_ARITH ); debug_print( L"; arg2 = ", DEBUG_ARITH ); - debug_print_object( arg2, DEBUG_ARITH ); + debug_dump_object( arg2, DEBUG_ARITH ); debug_print( L"\n", DEBUG_ARITH ); if ( zerop( arg1 ) ) { diff --git a/src/debug.c b/src/debug.c index eba31e8..392aa71 100644 --- a/src/debug.c +++ b/src/debug.c @@ -42,6 +42,29 @@ void debug_print( wchar_t *message, int level ) { #endif } +/** + * stolen from https://stackoverflow.com/questions/11656241/how-to-print-uint128-t-number-using-gcc + */ +void debug_print_128bit( __int128_t n, int level ) { + #ifdef DEBUG + if ( level & verbosity ) { + if (n == 0) { + fwprintf(stderr, L"0"); + } else { + char str[40] = {0}; // log10(1 << 128) + '\0' + char *s = str + sizeof(str) - 1; // start at the end + while (n != 0) { + if (s == str) return; // never happens + + *--s = "0123456789"[n % 10]; // save last digit + n /= 10; // drop it + } + fwprintf(stderr, L"%s", s); + } + } + #endif +} + /** * print a line feed to stderr, if `verbosity` matches `level`. * `verbosity is a set of flags, see debug_print.h; so you can diff --git a/src/debug.h b/src/debug.h index 72fa020..f961d6e 100644 --- a/src/debug.h +++ b/src/debug.h @@ -26,6 +26,7 @@ extern int verbosity; void debug_print( wchar_t *message, int level ); +void debug_print_128bit( __int128_t n, int level ); void debug_println( int level ); void debug_printf( int level, wchar_t *format, ... ); void debug_print_object( struct cons_pointer pointer, int level ); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index aba7a92..298ae1a 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -1133,7 +1133,6 @@ struct cons_pointer lisp_source( struct stack_frame *frame, 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 ); @@ -1150,5 +1149,5 @@ struct cons_pointer lisp_inspect( struct stack_frame *frame, struct cons_pointer dec_ref( out_stream ); } - return result; + return frame->arg[0]; } diff --git a/src/ops/read.c b/src/ops/read.c index 9074652..4f866d6 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -157,91 +157,104 @@ struct cons_pointer read_continuation( struct stack_frame *frame, * garbage is collected. */ struct cons_pointer read_number( struct stack_frame *frame, - struct cons_pointer frame_pointer, - FILE * input, - wint_t initial, bool seen_period ) { - debug_print( L"entering read_number\n", DEBUG_IO ); + struct cons_pointer frame_pointer, + FILE * input, + wint_t initial, bool seen_period ) { + debug_print( L"entering read_number\n", DEBUG_IO ); - struct cons_pointer result = make_integer( 0, NIL ); - /* TODO: we really need to be getting `base` from a privileged Lisp name - + struct cons_pointer result = make_integer( 0, NIL ); + /* TODO: we really need to be getting `base` from a privileged Lisp name - * and it should be the same privileged name we use when writing numbers */ - struct cons_pointer base = make_integer( 10, NIL ); - struct cons_pointer dividend = NIL; - int places_of_decimals = 0; - wint_t c; - bool neg = initial == btowc( '-' ); + struct cons_pointer base = make_integer( 10, NIL ); + struct cons_pointer dividend = NIL; + int places_of_decimals = 0; + wint_t c; + bool neg = initial == btowc( '-' ); - if ( neg ) { - initial = fgetwc( input ); + if ( neg ) { + initial = fgetwc( input ); + } + + debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial, + initial ); + + for ( c = initial; iswdigit( c ) + || c == L'.' || c == L'/' || c == L','; c = fgetwc( input ) ) { + switch (c) { + case L'.': + if ( seen_period || !nilp( dividend ) ) { + return throw_exception( c_string_to_lisp_string + ( L"Malformed number: too many periods" ), + frame_pointer ); + } else { + debug_print(L"read_number: decimal point seen\n", DEBUG_IO); + seen_period = true; + } + break; + case L'/': + if ( seen_period || !nilp( dividend ) ) { + return throw_exception( c_string_to_lisp_string + ( L"Malformed number: dividend of rational must be integer" ), + frame_pointer ); + } else { + debug_print(L"read_number: ratio slash seen\n", DEBUG_IO); + dividend = result; + + result = make_integer( 0, NIL ); + } + break; + case L',' : + // silently ignore it. + break; + default: + result = add_integers( multiply_integers( result, base ), + make_integer( ( int ) c - ( int ) '0', + NIL ) ); + + debug_printf( DEBUG_IO, + L"read_number: added character %c, result now ", c ); + debug_print_object( result, DEBUG_IO); + debug_print( L"\n", DEBUG_IO); + + if ( seen_period ) { + places_of_decimals++; + } } + } - debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial, - initial ); - - for ( c = initial; iswdigit( c ) - || c == L'.' || c == L'/' || c == L','; c = fgetwc( input ) ) { - if ( c == btowc( '.' ) ) { - if ( seen_period || !nilp( dividend ) ) { - return throw_exception( c_string_to_lisp_string - ( L"Malformed number: too many periods" ), - frame_pointer ); - } else { - seen_period = true; - } - } else if ( c == btowc( '/' ) ) { - if ( seen_period || !nilp( dividend ) ) { - return throw_exception( c_string_to_lisp_string - ( L"Malformed number: dividend of rational must be integer" ), - frame_pointer ); - } else { - dividend = result; - - result = make_integer( 0, NIL ); - } - } else if ( c == L',' ) { - // silently ignore it. - } else { - result = add_integers( multiply_integers( result, base ), - make_integer( ( int ) c - ( int ) '0', - NIL ) ); - - debug_printf( DEBUG_IO, - L"Added character %c, result now %ld\n", c, result ); - - if ( seen_period ) { - places_of_decimals++; - } - } - } - - /* + /* * push back the character read which was not a digit */ - ungetwc( c, input ); - if ( seen_period ) { - struct cons_pointer div = make_ratio( frame_pointer, result, - make_integer( powl - ( to_long_double - ( base ), - places_of_decimals ), - NIL ) ); - inc_ref( div ); + ungetwc( c, input ); - result = make_real( to_long_double( div ) ); + if ( seen_period ) { + debug_print(L"read_number: converting result to real\n", DEBUG_IO); + struct cons_pointer div = make_ratio( frame_pointer, result, + make_integer( powl + ( to_long_double + ( base ), + places_of_decimals ), + NIL ) ); + inc_ref( div ); - dec_ref( div ); - } else if ( integerp( dividend ) ) { - result = make_ratio( frame_pointer, dividend, result ); - } + result = make_real( to_long_double( div ) ); - if ( neg ) { - result = negative( frame_pointer, result ); - } + 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 ); + } - debug_print( L"read_number returning\n", DEBUG_IO ); - debug_dump_object( result, DEBUG_IO ); + if ( neg ) { + debug_print(L"read_number: converting result to negative\n", DEBUG_IO); - return result; + result = negative( frame_pointer, result ); + } + + debug_print( L"read_number returning\n", DEBUG_IO ); + debug_dump_object( result, DEBUG_IO ); + + return result; } /** From c209abb4f93b9d75a10d21cae6e1653ad89e1e46 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 18 Jan 2019 13:39:12 +0000 Subject: [PATCH 21/40] Added unit tests to establish that bignum addition and print work the bug must be in multiplication. --- src/debug.h | 14 ++-- src/memory/dump.c | 2 +- unit-tests/bignum-add.sh | 155 +++++++++++++++++++++++++++++++++++++ unit-tests/bignum-expt.sh | 135 ++++++++++++++++++++++++++++++++ unit-tests/bignum-print.sh | 57 ++++++++++++++ 5 files changed, 355 insertions(+), 8 deletions(-) create mode 100644 unit-tests/bignum-add.sh create mode 100644 unit-tests/bignum-expt.sh create mode 100644 unit-tests/bignum-print.sh diff --git a/src/debug.h b/src/debug.h index f961d6e..babbaea 100644 --- a/src/debug.h +++ b/src/debug.h @@ -14,14 +14,14 @@ #define __debug_print_h #define DEBUG_ALLOC 1 -#define DEBUG_STACK 2 -#define DEBUG_ARITH 4 -#define DEBUG_EVAL 8 -#define DEBUG_LAMBDA 16 -#define DEBUG_BOOTSTRAP 32 -#define DEBUG_IO 64 +#define DEBUG_ARITH 2 +#define DEBUG_BIND 4 +#define DEBUG_BOOTSTRAP 8 +#define DEBUG_EVAL 16 +#define DEBUG_IO 32 +#define DEBUG_LAMBDA 64 #define DEBUG_REPL 128 -#define DEBUG_BIND 256 +#define DEBUG_STACK 256 extern int verbosity; diff --git a/src/memory/dump.c b/src/memory/dump.c index a5faa87..fc9175d 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -84,7 +84,7 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { L"\t\tInteger cell: value %ld, count %u\n", cell.payload.integer.value, cell.count ); if ( !nilp( cell.payload.integer.more ) ) { - fputws( L"\t\tBIGNUM! More at\n:", output ); + fputws( L"\t\tBIGNUM! More at:\n", output ); dump_object( output, cell.payload.integer.more ); } break; diff --git a/unit-tests/bignum-add.sh b/unit-tests/bignum-add.sh new file mode 100644 index 0000000..678b766 --- /dev/null +++ b/unit-tests/bignum-add.sh @@ -0,0 +1,155 @@ +#!/bin/bash + +##################################################################### +# add two large numbers, not actally bignums to produce a smallnum +# (right on the boundary) +a=1152921504606846975 +b=1 +expected='1152921504606846976' +output=`echo "(+ $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "adding $a to $b: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking no bignum was created: " +grep -v 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + +##################################################################### +# add two numbers, not actally bignums to produce a bignum +# (just over the boundary) +a='1152921504606846976' +b=1 +expected='1152921504606846977' +output=`echo "(+ $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "adding $a to $b: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking a bignum was created: " +grep 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + +##################################################################### +# add a bignum and a smallnum to produce a bignum +# (just over the boundary) +a='1152921504606846977' +b=1 +expected='1152921504606846978' +output=`echo "(+ $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "adding $a to $b: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking a bignum was created: " +grep 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + +##################################################################### +# add a smallnum and a bignum to produce a bignum +# (just over the boundary) +a=1 +b=1152921504606846977 +expected='1152921504606846978' +output=`echo "(+ $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "adding $a to $b: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking a bignum was created: " +grep 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + +##################################################################### +# add two bignums to produce a bignum +a=10000000000000000000 +b=10000000000000000000 +expected='20000000000000000000' +output=`echo "(+ $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "adding $a to $b: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking a bignum was created: " +grep 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi diff --git a/unit-tests/bignum-expt.sh b/unit-tests/bignum-expt.sh new file mode 100644 index 0000000..ab9cb24 --- /dev/null +++ b/unit-tests/bignum-expt.sh @@ -0,0 +1,135 @@ +#!/bin/bash + +##################################################################### +# last 'smallnum' value: +# sbcl calculates (expt 2 59) => 576460752303423488 +expected='576460752303423488' + +output=`target/psse < 1152921504606846976 +expected='1152921504606846976' + +output=`target/psse < 2305843009213693952 +expected='2305843009213693952' + +output=`target/psse < 18446744073709551616 +expected='18446744073709551616' + +output=`target/psse < 36893488147419103232 +expected='36893488147419103232' + +output=`target/psse < Date: Fri, 18 Jan 2019 13:57:41 +0000 Subject: [PATCH 22/40] Bignum subtraction does NOT work Also subtraction of large numbers which are not beyond the bignum barrier does not work. --- unit-tests/bignum-subtract.sh | 116 ++++++++++++++++++++++++++++++++++ 1 file changed, 116 insertions(+) create mode 100644 unit-tests/bignum-subtract.sh diff --git a/unit-tests/bignum-subtract.sh b/unit-tests/bignum-subtract.sh new file mode 100644 index 0000000..9342913 --- /dev/null +++ b/unit-tests/bignum-subtract.sh @@ -0,0 +1,116 @@ +#!/bin/bash + +##################################################################### +# subtract a smallnum from a smallnum to produce a smallnum +# (right on the boundary) +a=1152921504606846976 +b=1 +expected='1152921504606846975' +output=`echo "(- $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "subtracting $b from $a: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking no bignum was created: " +grep -v 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + +##################################################################### +# subtract a smallnum from a bignum to produce a smallnum +# (just over the boundary) +a='1152921504606846977' +b=1 +expected='1152921504606846976' +output=`echo "(- $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "subtracting $b from $a: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +##################################################################### +# subtract a smallnum from a bignum to produce a smallnum +a='1152921504606846978' +b=1 +expected='1152921504606846977' +output=`echo "(- $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "subtracting $b from $a: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + + +##################################################################### +# subtract a bignum from a smallnum to produce a negstive smallnum +# (just over the boundary) +a=1 +b=1152921504606846977 +expected='-1152921504606846976' +output=`echo "(- $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "subtracting $b from $a: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +##################################################################### +# subtract a bignum from a bignum to produce a bignum +a=20000000000000000000 +b=10000000000000000000 +expected=10000000000000000000 +output=`echo "(- $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "subtracting $b from $a: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + From d8991e8823dec702a5da41938fc47ba453a75c9c Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 18 Jan 2019 14:09:26 +0000 Subject: [PATCH 23/40] H'mmm. But although two-cell bignums work, n-cell do not. Both add and print fail with numbers larger than 2^120 --- unit-tests/bignum-add.sh | 33 +++++++++++++++++++++++++++++++++ unit-tests/bignum-print.sh | 2 +- 2 files changed, 34 insertions(+), 1 deletion(-) diff --git a/unit-tests/bignum-add.sh b/unit-tests/bignum-add.sh index 678b766..a4244ee 100644 --- a/unit-tests/bignum-add.sh +++ b/unit-tests/bignum-add.sh @@ -153,3 +153,36 @@ else echo "Fail" exit 1 fi + +##################################################################### +# add a smallnum and a two-cell bignum to produce a three-cell bignum +# (just over the boundary) +a=1 +b=1329227995784915872903807060280344576 +expected='1329227995784915872903807060280344577' +output=`echo "(+ $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "adding $a to $b: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking a bignum was created: " +grep 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + +1329227995784915872903807060280344576 diff --git a/unit-tests/bignum-print.sh b/unit-tests/bignum-print.sh index c030f37..69d2d24 100644 --- a/unit-tests/bignum-print.sh +++ b/unit-tests/bignum-print.sh @@ -38,7 +38,7 @@ fi ##################################################################### # definitely a bignum -expected='2305843009213693952' +expected='1329227995784915872903807060280344577' output=`echo "(progn (print $expected) nil)" | target/psse` actual=`echo $output |\ From b433171fb643723a18b415605a84537aa990f8c8 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 18 Jan 2019 14:25:32 +0000 Subject: [PATCH 24/40] Problem is that reading bignums depends on multiplying bignums... Which doesn't work for the second digit into bignum territory - so it's fine at the boundary... --- unit-tests/bignum-add.sh | 1 - unit-tests/bignum-print.sh | 81 ++++++++++++++++++++++++++++++++++++-- 2 files changed, 77 insertions(+), 5 deletions(-) diff --git a/unit-tests/bignum-add.sh b/unit-tests/bignum-add.sh index a4244ee..280eca9 100644 --- a/unit-tests/bignum-add.sh +++ b/unit-tests/bignum-add.sh @@ -185,4 +185,3 @@ else exit 1 fi -1329227995784915872903807060280344576 diff --git a/unit-tests/bignum-print.sh b/unit-tests/bignum-print.sh index 69d2d24..5615871 100644 --- a/unit-tests/bignum-print.sh +++ b/unit-tests/bignum-print.sh @@ -3,7 +3,7 @@ ##################################################################### # large number, not actally a bignum expected='576460752303423488' -output=`echo "(progn (print $expected) nil)" | target/psse` +output=`echo "(progn (print $expected) nil)" | target/psse -v 2 2>psse.log` actual=`echo $output |\ sed 's/\,//g' |\ @@ -18,10 +18,22 @@ else exit 1 fi +echo -n "checking no bignum was created: " +grep -v 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + + + ##################################################################### # right on the boundary expected='1152921504606846976' -output=`echo "(progn (print $expected) nil)" | target/psse` +output=`echo "(progn (print $expected) nil)" | target/psse -v 2 2>psse.log` actual=`echo $output |\ sed 's/\,//g' |\ @@ -36,10 +48,71 @@ else exit 1 fi +echo -n "checking no bignum was created: " +grep -v 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + + + ##################################################################### # definitely a bignum -expected='1329227995784915872903807060280344577' -output=`echo "(progn (print $expected) nil)" | target/psse` +expected='1152921504606846977' +output=`echo "(progn (print $expected) nil)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + sed 's/\,//g' |\ + sed 's/[^0-9]*\([0-9]*\).*/\1/'` + +echo -n "printing $expected: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + + +echo -n "checking a bignum was created: " +grep 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + +##################################################################### +# Just on the three cell boundary +expected='1329227995784915872903807060280344576' +output=`echo "(progn (print $expected) nil)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + sed 's/\,//g' |\ + sed 's/[^0-9]*\([0-9]*\).*/\1/'` + +echo -n "printing $expected: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +exit 0 + +##################################################################### +# definitely a three cell bignum +expected='1329227995784915872903807060280344577' +output=`echo "(progn (print $expected) nil)" | target/psse -v 2 2>psse.log` actual=`echo $output |\ sed 's/\,//g' |\ From 46a41328235403602a4a41b2f41550b5759dc96e Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 18 Jan 2019 20:55:03 +0000 Subject: [PATCH 25/40] Made it easier to run individual unit tests --- src/arith/integer.c | 4 ++++ unit-tests/add.sh | 0 unit-tests/apply.sh | 0 unit-tests/bignum-add.sh | 0 unit-tests/bignum-expt.sh | 0 unit-tests/bignum-print.sh | 0 unit-tests/bignum-subtract.sh | 0 unit-tests/bignum.sh | 0 unit-tests/complex-list.sh | 0 unit-tests/cond.sh | 0 unit-tests/empty-list.sh | 0 unit-tests/empty-string.sh | 0 unit-tests/eval-integer.sh | 0 unit-tests/eval-quote-sexpr.sh | 0 unit-tests/eval-quote-symbol.sh | 0 unit-tests/eval-real.sh | 0 unit-tests/eval-string.sh | 0 unit-tests/fred.sh | 0 unit-tests/integer-allocation.sh | 0 unit-tests/integer.sh | 0 unit-tests/intepreter.sh | 0 unit-tests/lambda.sh | 0 unit-tests/many-args.sh | 0 unit-tests/multiply.sh | 0 unit-tests/nil.sh | 0 unit-tests/nlambda.sh | 0 unit-tests/progn.sh | 0 unit-tests/quote.sh | 0 unit-tests/quoted-list.sh | 0 unit-tests/ratio-addition.sh | 0 unit-tests/recursion.sh | 0 unit-tests/reverse.sh | 0 unit-tests/simple-list.sh | 0 unit-tests/string-allocation.sh | 0 unit-tests/string-with-spaces.sh | 0 unit-tests/varargs.sh | 0 36 files changed, 4 insertions(+) mode change 100644 => 100755 unit-tests/add.sh mode change 100644 => 100755 unit-tests/apply.sh mode change 100644 => 100755 unit-tests/bignum-add.sh mode change 100644 => 100755 unit-tests/bignum-expt.sh mode change 100644 => 100755 unit-tests/bignum-print.sh mode change 100644 => 100755 unit-tests/bignum-subtract.sh mode change 100644 => 100755 unit-tests/bignum.sh mode change 100644 => 100755 unit-tests/complex-list.sh mode change 100644 => 100755 unit-tests/cond.sh mode change 100644 => 100755 unit-tests/empty-list.sh mode change 100644 => 100755 unit-tests/empty-string.sh mode change 100644 => 100755 unit-tests/eval-integer.sh mode change 100644 => 100755 unit-tests/eval-quote-sexpr.sh mode change 100644 => 100755 unit-tests/eval-quote-symbol.sh mode change 100644 => 100755 unit-tests/eval-real.sh mode change 100644 => 100755 unit-tests/eval-string.sh mode change 100644 => 100755 unit-tests/fred.sh mode change 100644 => 100755 unit-tests/integer-allocation.sh mode change 100644 => 100755 unit-tests/integer.sh mode change 100644 => 100755 unit-tests/intepreter.sh mode change 100644 => 100755 unit-tests/lambda.sh mode change 100644 => 100755 unit-tests/many-args.sh mode change 100644 => 100755 unit-tests/multiply.sh mode change 100644 => 100755 unit-tests/nil.sh mode change 100644 => 100755 unit-tests/nlambda.sh mode change 100644 => 100755 unit-tests/progn.sh mode change 100644 => 100755 unit-tests/quote.sh mode change 100644 => 100755 unit-tests/quoted-list.sh mode change 100644 => 100755 unit-tests/ratio-addition.sh mode change 100644 => 100755 unit-tests/recursion.sh mode change 100644 => 100755 unit-tests/reverse.sh mode change 100644 => 100755 unit-tests/simple-list.sh mode change 100644 => 100755 unit-tests/string-allocation.sh mode change 100644 => 100755 unit-tests/string-with-spaces.sh mode change 100644 => 100755 unit-tests/varargs.sh diff --git a/src/arith/integer.c b/src/arith/integer.c index a5e2271..1fb22f1 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -101,6 +101,10 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { * integer arguments `a` and `b`, and return a pointer to the result. If * either `a` or `b` is not an integer, returns `NIL`. */ +/* TODO: there is a significant bug here, which manifests in multiply but + * may not manifest in add. The value in the least significant cell ends + * up significantly WRONG, but the value in the more significant cell + * ends up correct. */ struct cons_pointer operate_on_integers( struct cons_pointer a, struct cons_pointer b, char op) { diff --git a/unit-tests/add.sh b/unit-tests/add.sh old mode 100644 new mode 100755 diff --git a/unit-tests/apply.sh b/unit-tests/apply.sh old mode 100644 new mode 100755 diff --git a/unit-tests/bignum-add.sh b/unit-tests/bignum-add.sh old mode 100644 new mode 100755 diff --git a/unit-tests/bignum-expt.sh b/unit-tests/bignum-expt.sh old mode 100644 new mode 100755 diff --git a/unit-tests/bignum-print.sh b/unit-tests/bignum-print.sh old mode 100644 new mode 100755 diff --git a/unit-tests/bignum-subtract.sh b/unit-tests/bignum-subtract.sh old mode 100644 new mode 100755 diff --git a/unit-tests/bignum.sh b/unit-tests/bignum.sh old mode 100644 new mode 100755 diff --git a/unit-tests/complex-list.sh b/unit-tests/complex-list.sh old mode 100644 new mode 100755 diff --git a/unit-tests/cond.sh b/unit-tests/cond.sh old mode 100644 new mode 100755 diff --git a/unit-tests/empty-list.sh b/unit-tests/empty-list.sh old mode 100644 new mode 100755 diff --git a/unit-tests/empty-string.sh b/unit-tests/empty-string.sh old mode 100644 new mode 100755 diff --git a/unit-tests/eval-integer.sh b/unit-tests/eval-integer.sh old mode 100644 new mode 100755 diff --git a/unit-tests/eval-quote-sexpr.sh b/unit-tests/eval-quote-sexpr.sh old mode 100644 new mode 100755 diff --git a/unit-tests/eval-quote-symbol.sh b/unit-tests/eval-quote-symbol.sh old mode 100644 new mode 100755 diff --git a/unit-tests/eval-real.sh b/unit-tests/eval-real.sh old mode 100644 new mode 100755 diff --git a/unit-tests/eval-string.sh b/unit-tests/eval-string.sh old mode 100644 new mode 100755 diff --git a/unit-tests/fred.sh b/unit-tests/fred.sh old mode 100644 new mode 100755 diff --git a/unit-tests/integer-allocation.sh b/unit-tests/integer-allocation.sh old mode 100644 new mode 100755 diff --git a/unit-tests/integer.sh b/unit-tests/integer.sh old mode 100644 new mode 100755 diff --git a/unit-tests/intepreter.sh b/unit-tests/intepreter.sh old mode 100644 new mode 100755 diff --git a/unit-tests/lambda.sh b/unit-tests/lambda.sh old mode 100644 new mode 100755 diff --git a/unit-tests/many-args.sh b/unit-tests/many-args.sh old mode 100644 new mode 100755 diff --git a/unit-tests/multiply.sh b/unit-tests/multiply.sh old mode 100644 new mode 100755 diff --git a/unit-tests/nil.sh b/unit-tests/nil.sh old mode 100644 new mode 100755 diff --git a/unit-tests/nlambda.sh b/unit-tests/nlambda.sh old mode 100644 new mode 100755 diff --git a/unit-tests/progn.sh b/unit-tests/progn.sh old mode 100644 new mode 100755 diff --git a/unit-tests/quote.sh b/unit-tests/quote.sh old mode 100644 new mode 100755 diff --git a/unit-tests/quoted-list.sh b/unit-tests/quoted-list.sh old mode 100644 new mode 100755 diff --git a/unit-tests/ratio-addition.sh b/unit-tests/ratio-addition.sh old mode 100644 new mode 100755 diff --git a/unit-tests/recursion.sh b/unit-tests/recursion.sh old mode 100644 new mode 100755 diff --git a/unit-tests/reverse.sh b/unit-tests/reverse.sh old mode 100644 new mode 100755 diff --git a/unit-tests/simple-list.sh b/unit-tests/simple-list.sh old mode 100644 new mode 100755 diff --git a/unit-tests/string-allocation.sh b/unit-tests/string-allocation.sh old mode 100644 new mode 100755 diff --git a/unit-tests/string-with-spaces.sh b/unit-tests/string-with-spaces.sh old mode 100644 new mode 100755 diff --git a/unit-tests/varargs.sh b/unit-tests/varargs.sh old mode 100644 new mode 100755 From 000ae3c392a237eeff60a72156f5248866c05b96 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 19 Jan 2019 10:55:24 +0000 Subject: [PATCH 26/40] Not really a unit test, just trying to find where the problem is --- unit-tests/where-does-it-break.sh | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) create mode 100755 unit-tests/where-does-it-break.sh diff --git a/unit-tests/where-does-it-break.sh b/unit-tests/where-does-it-break.sh new file mode 100755 index 0000000..5c51aca --- /dev/null +++ b/unit-tests/where-does-it-break.sh @@ -0,0 +1,29 @@ +#!/bin/bash + +# Not really a unit test, but a check to see where bignum addition breaks + +broken=0 +i=1152921506900200000 +# we've already proven we can successfullu get up to here +increment=10000 + +while [ $broken -eq "0" ] +do + expr="(+ $i $increment)" + # Use sbcl as our reference implementation... + expected=`echo "$expr" | sbcl --noinform | grep -v '*'` + actual=`echo "$expr" | target/psse | tail -1 | sed 's/\,//g'` + + echo -n "adding $increment to $i: " + + if [ "${expected}" = "${actual}" ] + then + echo "OK" + else + echo "Fail: expected '${expected}', got '${actual}'" + broken=1 + exit 1 + fi + + i=$expected +done From 0f8bc990f24b9f7a8f6881d5f0b863c08a9afe1e Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 19 Jan 2019 16:24:59 +0000 Subject: [PATCH 27/40] Much investigation of bignum problems bignum multiply is still not working, but as bignum read and bignum divide depend on it, it's the problem to hit first. --- lisp/expt.lisp | 2 +- lisp/scratchpad.lisp | 48 +++++ lisp/scratchpad2.lisp | 84 +++++++++ src/arith/integer.c | 133 ++++++++------ src/arith/peano.c | 2 +- src/debug.c | 31 ++-- src/ops/read.c | 172 +++++++++--------- unit-tests/bignum-add.sh | 69 +++++-- ...does-it-break.sh => where-does-it-break.sh | 4 +- 9 files changed, 372 insertions(+), 173 deletions(-) create mode 100644 lisp/scratchpad.lisp create mode 100644 lisp/scratchpad2.lisp rename unit-tests/where-does-it-break.sh => where-does-it-break.sh (94%) diff --git a/lisp/expt.lisp b/lisp/expt.lisp index af1fff1..433b0ea 100644 --- a/lisp/expt.lisp +++ b/lisp/expt.lisp @@ -5,4 +5,4 @@ ((= x 1) n) (t (* n (expt n (- x 1))))))) -(expt 2 65) +(expt 2 60) diff --git a/lisp/scratchpad.lisp b/lisp/scratchpad.lisp new file mode 100644 index 0000000..494fe59 --- /dev/null +++ b/lisp/scratchpad.lisp @@ -0,0 +1,48 @@ +(set! i + (+ + 10000000000000000000 + 10000000000000000000 + 10000000000000000000 + 10000000000000000000 + 10000000000000000000 + 10000000000000000000 + 10000000000000000000 + 10000000000000000000 + 10000000000000000000 + 10000000000000000000)) + +(set! j (+ i i i i i i i i i i)) + +(set! k (+ j j j j j j j j j j)) + +(set! l (+ k k k k k k k k k k)) + +(set! m (+ l l l l l l l l l l)) + +(set! n (+ m m m m m m m m m m)) + +(set! o (+ n n n n n n n n n n)) + +(set! p (+ o o o o o o o o o o)) + +(set! q (+ p p p p p p p p p p)) + +(set! r (+ q q q q q q q q q q)) + +(set! s (+ r r r r r r r r r r)) + +(set! t (+ s s s s s s s s s s)) + +(set! u (+ t t t t t t t t t t)) + +(set! v (+ u u u u u u u u u u)) + +(set! x (+ v v v v v v v v v v)) + +(set! y (+ x x x x x x x x x x)) + +"we're OK to here: 10^36, which is below the 2^120 barrier so represented as two cells" +(inspect (set! z (+ y y y y y y y y y y))) + +"This blows up: 10^37, which is a three cell bignum." +(inspect (+ z z z z z z z z z z)) diff --git a/lisp/scratchpad2.lisp b/lisp/scratchpad2.lisp new file mode 100644 index 0000000..e608106 --- /dev/null +++ b/lisp/scratchpad2.lisp @@ -0,0 +1,84 @@ +"This demonstrates that although the print representation of three cell bignums blows up, the internal representation is sane" + +"We start by adding 8 copies of 2^60 - i.e. the first two-cell integer" + +(set! a + (+ + 1152921504606846976 + 1152921504606846976 + 1152921504606846976 + 1152921504606846976 + 1152921504606846976 + 1152921504606846976 + 1152921504606846976 + 1152921504606846976)) + +"Then repeatedly add eight copies of the previous generation" + +(set! b (+ a a a a a a a a)) + +(set! c (+ b b b b b b b b)) + +(set! d (+ c c c c c c c c)) + +(set! e (+ d d d d d d d d)) + +(set! f (+ e e e e e e e e)) + +(set! g (+ f f f f f f f f)) + +(set! h (+ g g g g g g g g)) + +(set! i (+ h h h h h h h h)) + +(set! j (+ i i i i i i i i)) + +(set! k (+ j j j j j j j j)) + +(set! l (+ k k k k k k k k)) + +(set! m (+ l l l l l l l l)) + +(set! n (+ m m m m m m m m)) + +(set! o (+ n n n n n n n n)) + +"p" +(set! p (+ o o o o o o o o)) + +"q" +(set! q (+ p p p p p p p p)) + +"r" +(set! r (+ q q q q q q q q)) + +"s" +(inspect + (set! s (+ r r r r r r r r))) + +"t - first three cell integer. Printing blows up here" +(inspect + (set! t (+ s s s s s s s s))) + +"u" +(inspect + (set! u (+ t t t t t t t t))) + +"v" +(inspect + (set! v (+ u u u u u u u u))) + +"w" +(inspect + (set! w (+ v v v v v v v v))) + +(inspect + (set! x (+ w w w w w w w w))) + +(inspect + (set! y (+ x x x x x x x x))) + +(inspect + (set! z (+ y y y y y y y y))) + +(inspect (+ z z z z z z z z)) diff --git a/src/arith/integer.c b/src/arith/integer.c index 1fb22f1..b5ed859 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -36,7 +36,7 @@ /** * hexadecimal digits for printing numbers. */ -const char * hex_digits = "0123456789ABCDEF"; +const char *hex_digits = "0123456789ABCDEF"; /* * Doctrine from here on in is that ALL integers are bignums, it's just @@ -95,6 +95,21 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { } +__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 : ( MAX_INTEGER + 1 ); + + __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, op = '%c', is_first_cell = %s; returning ", + val, op, is_first_cell ? "true" : "false" ); + debug_print_128bit( result, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); + + return result; +} + /** * internal workings of both `add_integers` and `multiply_integers` (and * possibly, later, other operations. Apply the operator `op` to the @@ -106,26 +121,22 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { * up significantly WRONG, but the value in the more significant cell * ends up correct. */ struct cons_pointer operate_on_integers( struct cons_pointer a, - struct cons_pointer b, - char op) { + struct cons_pointer b, char op ) { struct cons_pointer result = NIL; struct cons_pointer cursor = NIL; __int128_t carry = 0; + bool is_first_cell = true; if ( integerp( a ) && integerp( b ) ) { debug_print( L"operate_on_integers: \n", DEBUG_ARITH ); debug_dump_object( a, DEBUG_ARITH ); - debug_printf( DEBUG_ARITH, L" %c \n", op); + 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 : op == '*' ? 1 : 0; - __int128_t bv = - ( __int128_t ) integerp( b ) ? pointer2cell( b ). - payload.integer.value : op == '*' ? 1 : 0; + __int128_t av = cell_value( a, op, is_first_cell ); + __int128_t bv = cell_value( b, op, is_first_cell ); /* 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 @@ -135,57 +146,59 @@ struct cons_pointer operate_on_integers( struct cons_pointer a, */ __int128_t rv = NAN; - switch (op) { - case '*': - rv = av * bv * ((carry == 0) ? 1 : carry); - break; - case '+': - rv = av + bv + carry; - break; - } + switch ( op ) { + case '*': + rv = av * bv * ( ( carry == 0 ) ? 1 : carry ); + break; + case '+': + rv = av + bv + carry; + break; + } - debug_printf( DEBUG_ARITH, L"operate_on_integers: op = '%c'; av = ", op); - 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); + debug_printf( DEBUG_ARITH, + L"operate_on_integers: op = '%c'; av = ", op ); + 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 ( 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"operate_on_integers: 64 bit overflow; setting carry to %ld\n", - ( int64_t ) carry ); - 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; - cursor = 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; + is_first_cell = false; } } @@ -203,7 +216,7 @@ struct cons_pointer operate_on_integers( struct cons_pointer a, struct cons_pointer add_integers( struct cons_pointer a, struct cons_pointer b ) { - return operate_on_integers(a, b, '+'); + return operate_on_integers( a, b, '+' ); } /** @@ -212,7 +225,7 @@ struct cons_pointer add_integers( struct cons_pointer a, */ struct cons_pointer multiply_integers( struct cons_pointer a, struct cons_pointer b ) { - return operate_on_integers( a, b, '*'); + return operate_on_integers( a, b, '*' ); } /** @@ -221,7 +234,7 @@ struct cons_pointer multiply_integers( struct cons_pointer a, struct cons_pointer integer_to_string_add_digit( int digit, int digits, struct cons_pointer tail ) { digits++; - wint_t character = btowc(hex_digits[digit]); + wint_t character = btowc( hex_digits[digit] ); return ( digits % 3 == 0 ) ? make_string( L',', make_string( character, tail ) ) : @@ -239,6 +252,11 @@ struct cons_pointer integer_to_string_add_digit( int digit, int digits, * when we get to the last digit from one integer cell, we have potentially * to be looking to the next. H'mmmm. */ +/* + * TODO: this blows up when printing three-cell integers, but works fine + * for two-cell. What's happening is that when we cross the barrier we + * SHOULD print 2^120, but what we actually print is 2^117. H'mmm. + */ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, int base ) { struct cons_pointer result = NIL; @@ -253,24 +271,27 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, while ( accumulator > 0 || !nilp( integer.payload.integer.more ) ) { if ( !nilp( integer.payload.integer.more ) ) { integer = pointer2cell( integer.payload.integer.more ); - accumulator += + accumulator += integer.payload.integer.value == 0 ? + MAX_INTEGER : ( llabs( integer.payload.integer.value ) * ( MAX_INTEGER + 1 ) ); + debug_print + ( L"integer_to_string: crossing cell boundary, accumulator is: ", + DEBUG_IO ); + debug_print_128bit( accumulator, DEBUG_IO ); + debug_println( DEBUG_IO ); } - debug_printf( DEBUG_IO, - L"integer_to_string: accumulator is %ld\n:", - accumulator ); do { - int offset = (int)(accumulator % base); + int offset = ( int ) ( accumulator % base ); debug_printf( DEBUG_IO, - L"integer_to_string: digit is %ld, hexadecimal is %c\n:", - offset, - hex_digits[offset] ); + L"integer_to_string: digit is %ld, hexadecimal is %c, accumulator is: ", + offset, hex_digits[offset] ); + debug_print_128bit( accumulator, DEBUG_IO ); + debug_println( DEBUG_IO ); result = - integer_to_string_add_digit( offset, digits++, - result ); + integer_to_string_add_digit( offset, digits++, result ); accumulator = accumulator / base; } while ( accumulator > base ); } diff --git a/src/arith/peano.c b/src/arith/peano.c index 1dded80..0dc2ed0 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -42,7 +42,7 @@ bool zerop( struct cons_pointer arg ) { switch ( cell.tag.value ) { case INTEGERTV: result = cell.payload.integer.value == 0 && - nilp(cell.payload.integer.more); + nilp( cell.payload.integer.more ); break; case RATIOTV: result = zerop( cell.payload.ratio.dividend ); diff --git a/src/debug.c b/src/debug.c index 392aa71..d694827 100644 --- a/src/debug.c +++ b/src/debug.c @@ -46,23 +46,24 @@ void debug_print( wchar_t *message, int level ) { * stolen from https://stackoverflow.com/questions/11656241/how-to-print-uint128-t-number-using-gcc */ void debug_print_128bit( __int128_t n, int level ) { - #ifdef DEBUG - if ( level & verbosity ) { - if (n == 0) { - fwprintf(stderr, L"0"); - } else { - char str[40] = {0}; // log10(1 << 128) + '\0' - char *s = str + sizeof(str) - 1; // start at the end - while (n != 0) { - if (s == str) return; // never happens +#ifdef DEBUG + if ( level & verbosity ) { + if ( n == 0 ) { + fwprintf( stderr, L"0" ); + } else { + char str[40] = { 0 }; // log10(1 << 128) + '\0' + char *s = str + sizeof( str ) - 1; // start at the end + while ( n != 0 ) { + if ( s == str ) + return; // never happens - *--s = "0123456789"[n % 10]; // save last digit - n /= 10; // drop it - } - fwprintf(stderr, L"%s", s); + *--s = "0123456789"[n % 10]; // save last digit + n /= 10; // drop it + } + fwprintf( stderr, L"%s", s ); + } } - } - #endif +#endif } /** diff --git a/src/ops/read.c b/src/ops/read.c index 4f866d6..6e2a07f 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -157,104 +157,108 @@ struct cons_pointer read_continuation( struct stack_frame *frame, * garbage is collected. */ struct cons_pointer read_number( struct stack_frame *frame, - struct cons_pointer frame_pointer, - FILE * input, - wint_t initial, bool seen_period ) { - debug_print( L"entering read_number\n", DEBUG_IO ); + struct cons_pointer frame_pointer, + FILE * input, + wint_t initial, bool seen_period ) { + debug_print( L"entering read_number\n", DEBUG_IO ); - struct cons_pointer result = make_integer( 0, NIL ); - /* TODO: we really need to be getting `base` from a privileged Lisp name - + struct cons_pointer result = make_integer( 0, NIL ); + /* TODO: we really need to be getting `base` from a privileged Lisp name - * and it should be the same privileged name we use when writing numbers */ - struct cons_pointer base = make_integer( 10, NIL ); - struct cons_pointer dividend = NIL; - int places_of_decimals = 0; - wint_t c; - bool neg = initial == btowc( '-' ); + struct cons_pointer base = make_integer( 10, NIL ); + struct cons_pointer dividend = NIL; + int places_of_decimals = 0; + wint_t c; + bool neg = initial == btowc( '-' ); - if ( neg ) { - initial = fgetwc( input ); - } - - debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial, - initial ); - - for ( c = initial; iswdigit( c ) - || c == L'.' || c == L'/' || c == L','; c = fgetwc( input ) ) { - switch (c) { - case L'.': - if ( seen_period || !nilp( dividend ) ) { - return throw_exception( c_string_to_lisp_string - ( L"Malformed number: too many periods" ), - frame_pointer ); - } else { - debug_print(L"read_number: decimal point seen\n", DEBUG_IO); - seen_period = true; - } - break; - case L'/': - if ( seen_period || !nilp( dividend ) ) { - return throw_exception( c_string_to_lisp_string - ( L"Malformed number: dividend of rational must be integer" ), - frame_pointer ); - } else { - debug_print(L"read_number: ratio slash seen\n", DEBUG_IO); - dividend = result; - - result = make_integer( 0, NIL ); - } - break; - case L',' : - // silently ignore it. - break; - default: - result = add_integers( multiply_integers( result, base ), - make_integer( ( int ) c - ( int ) '0', - NIL ) ); - - debug_printf( DEBUG_IO, - L"read_number: added character %c, result now ", c ); - debug_print_object( result, DEBUG_IO); - debug_print( L"\n", DEBUG_IO); - - if ( seen_period ) { - places_of_decimals++; - } + if ( neg ) { + initial = fgetwc( input ); } - } - /* + debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial, + initial ); + + for ( c = initial; iswdigit( c ) + || c == L'.' || c == L'/' || c == L','; c = fgetwc( input ) ) { + switch ( c ) { + case L'.': + if ( seen_period || !nilp( dividend ) ) { + return throw_exception( c_string_to_lisp_string + ( L"Malformed number: too many periods" ), + frame_pointer ); + } else { + debug_print( L"read_number: decimal point seen\n", + DEBUG_IO ); + seen_period = true; + } + break; + case L'/': + if ( seen_period || !nilp( dividend ) ) { + return throw_exception( c_string_to_lisp_string + ( L"Malformed number: dividend of rational must be integer" ), + frame_pointer ); + } else { + debug_print( L"read_number: ratio slash seen\n", + DEBUG_IO ); + dividend = result; + + result = make_integer( 0, NIL ); + } + break; + case L',': + // silently ignore it. + break; + default: + result = add_integers( multiply_integers( result, base ), + make_integer( ( int ) c - ( int ) '0', + NIL ) ); + + debug_printf( DEBUG_IO, + L"read_number: added character %c, result now ", + c ); + debug_print_object( result, DEBUG_IO ); + debug_print( L"\n", DEBUG_IO ); + + if ( seen_period ) { + places_of_decimals++; + } + } + } + + /* * push back the character read which was not a digit */ - ungetwc( c, input ); + ungetwc( c, input ); - if ( seen_period ) { - debug_print(L"read_number: converting result to real\n", DEBUG_IO); - struct cons_pointer div = make_ratio( frame_pointer, result, - make_integer( powl - ( to_long_double - ( base ), - places_of_decimals ), - NIL ) ); - inc_ref( div ); + if ( seen_period ) { + debug_print( L"read_number: converting result to real\n", DEBUG_IO ); + struct cons_pointer div = make_ratio( frame_pointer, result, + make_integer( powl + ( to_long_double + ( base ), + places_of_decimals ), + NIL ) ); + inc_ref( div ); - result = make_real( to_long_double( div ) ); + result = make_real( to_long_double( div ) ); - 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 ); - } + 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 ); + } - if ( neg ) { - debug_print(L"read_number: converting result to negative\n", DEBUG_IO); + if ( neg ) { + debug_print( L"read_number: converting result to negative\n", + DEBUG_IO ); - result = negative( frame_pointer, result ); - } + result = negative( frame_pointer, result ); + } - debug_print( L"read_number returning\n", DEBUG_IO ); - debug_dump_object( result, DEBUG_IO ); + debug_print( L"read_number returning\n", DEBUG_IO ); + debug_dump_object( result, DEBUG_IO ); - return result; + return result; } /** diff --git a/unit-tests/bignum-add.sh b/unit-tests/bignum-add.sh index 280eca9..7bbb41e 100755 --- a/unit-tests/bignum-add.sh +++ b/unit-tests/bignum-add.sh @@ -5,12 +5,12 @@ # (right on the boundary) a=1152921504606846975 b=1 -expected='1152921504606846976' -output=`echo "(+ $a $b)" | target/psse -v 2 2>psse.log` +c=`echo "$a + $b" | bc` +expected='t' +output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log` actual=`echo $output |\ - tail -1 |\ - sed 's/\,//g'` + tail -1` echo -n "adding $a to $b: " if [ "${expected}" = "${actual}" ] @@ -36,8 +36,9 @@ fi # (just over the boundary) a='1152921504606846976' b=1 -expected='1152921504606846977' -output=`echo "(+ $a $b)" | target/psse -v 2 2>psse.log` +c=`echo "$a + $b" | bc` +expected='t' +output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log` actual=`echo $output |\ tail -1 |\ @@ -62,13 +63,15 @@ else exit 1 fi + ##################################################################### # add a bignum and a smallnum to produce a bignum # (just over the boundary) a='1152921504606846977' b=1 -expected='1152921504606846978' -output=`echo "(+ $a $b)" | target/psse -v 2 2>psse.log` +c=`echo "$a + $b" | bc` +expected='t' +output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log` actual=`echo $output |\ tail -1 |\ @@ -98,8 +101,9 @@ fi # (just over the boundary) a=1 b=1152921504606846977 -expected='1152921504606846978' -output=`echo "(+ $a $b)" | target/psse -v 2 2>psse.log` +c=`echo "$a + $b" | bc` +expected='t' +output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log` actual=`echo $output |\ tail -1 |\ @@ -124,12 +128,14 @@ else exit 1 fi + ##################################################################### # add two bignums to produce a bignum a=10000000000000000000 b=10000000000000000000 -expected='20000000000000000000' -output=`echo "(+ $a $b)" | target/psse -v 2 2>psse.log` +c=`echo "$a + $b" | bc` +expected='t' +output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log` actual=`echo $output |\ tail -1 |\ @@ -154,13 +160,15 @@ else exit 1 fi + ##################################################################### # add a smallnum and a two-cell bignum to produce a three-cell bignum # (just over the boundary) a=1 b=1329227995784915872903807060280344576 -expected='1329227995784915872903807060280344577' -output=`echo "(+ $a $b)" | target/psse -v 2 2>psse.log` +c=`echo "$a + $b" | bc` +expected='t' +output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log` actual=`echo $output |\ tail -1 |\ @@ -185,3 +193,36 @@ else exit 1 fi + +##################################################################### +# This currently fails: +# (= (+ 1 3064991081731777716716694054300618367237478244367204352) +# 3064991081731777716716694054300618367237478244367204353) +a=1 +b=3064991081731777716716694054300618367237478244367204352 +c=`echo "$a + $b" | bc` +expected='t' +output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "adding $a to $b: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking a bignum was created: " +grep 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi diff --git a/unit-tests/where-does-it-break.sh b/where-does-it-break.sh similarity index 94% rename from unit-tests/where-does-it-break.sh rename to where-does-it-break.sh index 5c51aca..4d70041 100755 --- a/unit-tests/where-does-it-break.sh +++ b/where-does-it-break.sh @@ -3,9 +3,9 @@ # Not really a unit test, but a check to see where bignum addition breaks broken=0 -i=1152921506900200000 +i=11529215046068469750 # we've already proven we can successfullu get up to here -increment=10000 +increment=1 while [ $broken -eq "0" ] do From 22fa7314d6b429aae7bb41d23bc7ca56ba0bc337 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 20 Jan 2019 19:44:56 +0000 Subject: [PATCH 28/40] Mostly fixing and standardising documentation. --- Doxyfile | 14 +- src/arith/integer.c | 43 +++-- src/arith/integer.h | 5 +- src/arith/peano.c | 46 +++-- src/arith/peano.h | 6 +- src/arith/ratio.c | 37 ++-- src/init.c | 22 ++- src/memory/conspage.c | 130 +++++++------ src/memory/conspage.h | 26 --- src/memory/consspaceobject.c | 26 ++- src/memory/consspaceobject.h | 359 ++++++++++++++++++++-------------- src/memory/dump.c | 1 - src/memory/dump.h | 5 +- src/memory/stack.c | 25 +-- src/memory/stack.h | 8 +- src/memory/vectorspace.c | 31 ++- src/memory/vectorspace.h | 46 +++-- src/ops/intern.c | 3 +- src/ops/intern.h | 29 +-- src/ops/lispops.c | 361 +++++++++++++++++++++++------------ src/ops/lispops.h | 5 +- src/ops/print.c | 12 +- src/ops/read.c | 8 +- unit-tests/string-cons.sh | 25 +++ 24 files changed, 770 insertions(+), 503 deletions(-) create mode 100644 unit-tests/string-cons.sh diff --git a/Doxyfile b/Doxyfile index 955cb32..e283f9a 100644 --- a/Doxyfile +++ b/Doxyfile @@ -135,7 +135,7 @@ ABBREVIATE_BRIEF = "The $name class" \ # description. # The default value is: NO. -ALWAYS_DETAILED_SEC = NO +ALWAYS_DETAILED_SEC = YES # If the INLINE_INHERITED_MEMB tag is set to YES, doxygen will show all # inherited members of a class in the documentation of that class as if those @@ -162,7 +162,7 @@ FULL_PATH_NAMES = YES # will be relative from the directory where doxygen is started. # This tag requires that the tag FULL_PATH_NAMES is set to YES. -STRIP_FROM_PATH = +STRIP_FROM_PATH = src/ # The STRIP_FROM_INC_PATH tag can be used to strip a user-defined part of the # path mentioned in the documentation of a class, which tells the reader which @@ -187,7 +187,7 @@ SHORT_NAMES = NO # description.) # The default value is: NO. -JAVADOC_AUTOBRIEF = NO +JAVADOC_AUTOBRIEF = YES # If the QT_AUTOBRIEF tag is set to YES then doxygen will interpret the first # line (until the first dot) of a Qt-style comment as the brief description. If @@ -397,7 +397,7 @@ INLINE_GROUPED_CLASSES = NO # Man pages) or section (for LaTeX and RTF). # The default value is: NO. -INLINE_SIMPLE_STRUCTS = NO +INLINE_SIMPLE_STRUCTS = YES # When TYPEDEF_HIDES_STRUCT tag is enabled, a typedef of a struct, union, or # enum is documented as struct, union, or enum with the name of the typedef. So @@ -578,7 +578,7 @@ SORT_MEMBER_DOCS = YES # this will also influence the order of the classes in the class list. # The default value is: NO. -SORT_BRIEF_DOCS = NO +SORT_BRIEF_DOCS = YES # If the SORT_MEMBERS_CTORS_1ST tag is set to YES then doxygen will sort the # (brief and detailed) documentation of class members so that constructors and @@ -790,7 +790,7 @@ WARN_LOGFILE = doxy.log # spaces. See also FILE_PATTERNS and EXTENSION_MAPPING # Note: If this tag is empty the current directory is searched. -INPUT = src src/arith src/memory src/ops +INPUT = src # This tag can be used to specify the character encoding of the source files # that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses @@ -864,7 +864,7 @@ FILE_PATTERNS = *.c \ # be searched for input files as well. # The default value is: NO. -RECURSIVE = NO +RECURSIVE = YES # The EXCLUDE tag can be used to specify files and/or directories that should be # excluded from the INPUT source files. This way you can easily exclude a diff --git a/src/arith/integer.c b/src/arith/integer.c index b5ed859..c51bc56 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -41,13 +41,12 @@ const char *hex_digits = "0123456789ABCDEF"; /* * Doctrine from here on in is that ALL integers are bignums, it's just * that integers less than 65 bits are bignums of one cell only. - * - * TODO: I have no idea at all how I'm going to print bignums! */ /** - * return the numeric value of this cell, as a C primitive double, not - * as a cons-space object. Cell may in principle be any kind of number. + * return the numeric value of the cell indicated by this `pointer`, as a C + * primitive double, not as a cons_space_object. The indicated cell may in + * principle be any kind of number; if it is not a number, will return `NAN`. */ long double numeric_value( struct cons_pointer pointer ) { long double result = NAN; @@ -75,7 +74,10 @@ long double numeric_value( struct cons_pointer pointer ) { } /** - * Allocate an integer cell representing this value and return a cons pointer to it. + * 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; @@ -94,7 +96,13 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { return result; } - +/** + * Internal to `operate_on_integers`, do not use. + * @param c a pointer to a cell, assumed to be an integer cell; + * @param op a character representing the operation: expectedto be either + * '+' or '*'; behaviour with other values is undefined. + * \see operate_on_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 : ( MAX_INTEGER + 1 ); @@ -115,8 +123,15 @@ __int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) { * 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`. + * + * @param a a pointer to a cell, assumed to be an integer cell; + * @param b 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. + * \see add_integers + * \see multiply_integers */ -/* TODO: there is a significant bug here, which manifests in multiply but +/* \todo there is a significant bug here, which manifests in multiply but * may not manifest in add. The value in the least significant cell ends * up significantly WRONG, but the value in the more significant cell * ends up correct. */ @@ -148,7 +163,7 @@ struct cons_pointer operate_on_integers( struct cons_pointer a, switch ( op ) { case '*': - rv = av * bv * ( ( carry == 0 ) ? 1 : carry ); + rv = av * ( bv + carry ); break; case '+': rv = av + bv + carry; @@ -170,7 +185,7 @@ struct cons_pointer operate_on_integers( struct cons_pointer a, if ( MAX_INTEGER >= rv ) { carry = 0; } else { - // TODO: we're correctly detecting overflow, but not yet correctly + // \todo we're correctly detecting overflow, but not yet correctly // handling it. carry = rv >> 60; debug_printf( DEBUG_ARITH, @@ -210,8 +225,8 @@ struct cons_pointer operate_on_integers( struct cons_pointer a, } /** - * Return the sum of the integers pointed to by `a` and `b`. If either isn't - * an integer, will return nil. + * 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 ) { @@ -220,8 +235,8 @@ struct cons_pointer add_integers( struct cons_pointer a, } /** - * Return the product of the integers pointed to by `a` and `b`. If either isn't - * an integer, will return nil. + * 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. */ struct cons_pointer multiply_integers( struct cons_pointer a, struct cons_pointer b ) { @@ -253,7 +268,7 @@ struct cons_pointer integer_to_string_add_digit( int digit, int digits, * to be looking to the next. H'mmmm. */ /* - * TODO: this blows up when printing three-cell integers, but works fine + * \todo this blows up when printing three-cell integers, but works fine * for two-cell. What's happening is that when we cross the barrier we * SHOULD print 2^120, but what we actually print is 2^117. H'mmm. */ diff --git a/src/arith/integer.h b/src/arith/integer.h index 1eda28f..f9eba33 100644 --- a/src/arith/integer.h +++ b/src/arith/integer.h @@ -1,4 +1,4 @@ -/** +/* * integer.h * * functions for integer cells. @@ -13,9 +13,6 @@ long double numeric_value( struct cons_pointer pointer ); -/** - * Allocate an integer cell representing this value and return a cons pointer to it. - */ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ); struct cons_pointer add_integers( struct cons_pointer a, diff --git a/src/arith/peano.c b/src/arith/peano.c index 0dc2ed0..6666d0e 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -34,7 +34,9 @@ struct cons_pointer add_2( struct stack_frame *frame, 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 ); @@ -56,7 +58,13 @@ bool zerop( struct cons_pointer arg ) { } /** - * TODO: cannot throw an exception out of here, which is a problem + * 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. */ @@ -97,7 +105,13 @@ long double to_long_double( struct cons_pointer arg ) { /** - * TODO: cannot throw an exception out of here, which is a problem + * 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. */ @@ -106,7 +120,7 @@ int64_t to_long_int( struct cons_pointer arg ) { struct cons_space_object cell = pointer2cell( arg ); switch ( cell.tag.value ) { case INTEGERTV: - /* TODO: if (integerp(cell.payload.integer.more)) { + /* \todo if (integerp(cell.payload.integer.more)) { * throw an exception! * } */ result = cell.payload.integer.value; @@ -123,9 +137,9 @@ int64_t to_long_int( struct cons_pointer arg ) { /** -* return a cons_pointer indicating a number which is the sum of -* the numbers indicated by `arg1` and `arg2`. -*/ + * 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, @@ -222,7 +236,8 @@ struct cons_pointer add_2( struct stack_frame *frame, * Add an indefinite number of numbers together * @param env the evaluation environment - ignored; * @param frame the stack frame. - * @return a pointer to an integer or real. + * @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 @@ -356,7 +371,8 @@ struct cons_pointer multiply_2( struct stack_frame *frame, * Multiply an indefinite number of numbers together * @param env the evaluation environment - ignored; * @param frame the stack frame. - * @return a pointer to an integer or real. + * @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 @@ -431,7 +447,7 @@ struct cons_pointer negative( struct cons_pointer frame, /** * return a cons_pointer indicating a number which is the result of - * subtracting the numbers indicated by `arg2` from that indicated by `arg1`, + * 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, @@ -526,10 +542,12 @@ struct cons_pointer subtract_2( struct stack_frame *frame, } /** - * Subtract one number from another. + * 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 or real. + * @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 @@ -539,10 +557,12 @@ struct cons_pointer lisp_subtract( struct } /** - * Divide one number by another. + * 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 diff --git a/src/arith/peano.h b/src/arith/peano.h index 0bd09d5..816b147 100644 --- a/src/arith/peano.h +++ b/src/arith/peano.h @@ -1,4 +1,4 @@ -/** +/* * peano.h * * Basic peano arithmetic @@ -18,7 +18,7 @@ struct cons_pointer negative( struct cons_pointer frame, struct cons_pointer arg ); /** - * TODO: cannot throw an exception out of here, which is a problem + * \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. */ @@ -35,7 +35,7 @@ lisp_add( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); /** - * Multiply an indefinite number of numbers together + * Multiply an indefinite number of numbers together. * @param env the evaluation environment - ignored; * @param frame the stack frame. * @return a pointer to an integer or real. diff --git a/src/arith/ratio.c b/src/arith/ratio.c index f9dd0f4..784e71e 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -46,8 +46,8 @@ int64_t least_common_multiple( int64_t m, int64_t 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. If `arg` isn't a ratio, - * will throw exception. + * 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 ) { @@ -83,8 +83,9 @@ struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, /** * return a cons_pointer indicating a number which is the sum of - * the ratios indicated by `arg1` and `arg2`. If you pass non-ratios, - * this is going to break horribly. + * 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, @@ -100,7 +101,6 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, if ( ratiop( arg1 ) && ratiop( arg2 ) ) { struct cons_space_object cell1 = pointer2cell( arg1 ); struct cons_space_object cell2 = pointer2cell( arg2 ); - // TODO: to be entirely reworked for bignums. All vars must be lisp integers. int64_t dd1v = pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value, dd2v = @@ -160,7 +160,8 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, /** * return a cons_pointer indicating a number which is the sum of * the intger indicated by `intarg` and the ratio indicated by - * `ratarg`. If you pass other types, this is going to break horribly. + * `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, @@ -190,8 +191,9 @@ struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, /** * return a cons_pointer to a ratio which represents the value of the ratio - * indicated by `arg1` divided by the ratio indicated by `arg2`. If either - * of these aren't RTIO cells, something horrid will happen and it is YOUR FAULT. + * 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 frame_pointer, struct cons_pointer arg1, @@ -210,8 +212,9 @@ struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer, /** * return a cons_pointer indicating a number which is the product of - * the ratios indicated by `arg1` and `arg2`. If you pass non-ratios, - * this is going to break horribly. + * 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 frame_pointer, struct cons_pointer arg1, struct @@ -258,7 +261,8 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str /** * return a cons_pointer indicating a number which is the product of * the intger indicated by `intarg` and the ratio indicated by - * `ratarg`. If you pass other types, this is going to break horribly. + * `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, @@ -285,8 +289,9 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, /** * return a cons_pointer indicating a number which is the difference of - * the ratios indicated by `arg1` and `arg2`. If you pass non-ratios, - * this is going to break horribly. + * 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 frame_pointer, struct cons_pointer arg1, @@ -301,8 +306,10 @@ struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer, /** - * Construct a ratio frame from these two pointers, expected to be integers - * or (later) bignums, in the context of this stack_frame. + * 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 frame_pointer, struct cons_pointer dividend, diff --git a/src/init.c b/src/init.c index 1edb586..7fdad2d 100644 --- a/src/init.c +++ b/src/init.c @@ -27,20 +27,28 @@ // extern char *optarg; /* defined in unistd.h */ +/** + * Bind this compiled `executable` function, as a Lisp function, to + * this name in the `oblist`. + * \todo where a function is not compiled from source, we could cache + * the name on the source pointer. Would make stack frames potentially + * more readable and aid debugging generally. + */ void bind_function( wchar_t *name, struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ) ) { struct cons_pointer n = c_string_to_lisp_symbol( name ); inc_ref( n ); - /* TODO: where a function is not compiled from source, we could cache - * the name on the source pointer. Would make stack frames potentially - * more readable and aid debugging generally. */ deep_bind( n, make_function( NIL, executable ) ); dec_ref( n ); } +/** + * Bind this compiled `executable` function, as a Lisp special form, to + * this `name` in the `oblist`. + */ void bind_special( wchar_t *name, struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ) ) { @@ -52,6 +60,9 @@ void bind_special( wchar_t *name, struct cons_pointer ( *executable ) dec_ref( n ); } +/** + * Bind this `value` to this `name` in the `oblist`. + */ void bind_value( wchar_t *name, struct cons_pointer value ) { struct cons_pointer n = c_string_to_lisp_symbol( name ); inc_ref( n ); @@ -61,6 +72,10 @@ void bind_value( wchar_t *name, struct cons_pointer value ) { dec_ref( n ); } +/** + * main entry point; parse command line arguments, initialise the environment, + * and enter the read-eval-print loop. + */ int main( int argc, char *argv[] ) { int option; bool dump_at_end = false; @@ -179,7 +194,6 @@ int main( int argc, char *argv[] ) { dec_ref( oblist ); debug_dump_object( oblist, DEBUG_BOOTSTRAP ); - if ( dump_at_end ) { dump_pages( stdout ); } diff --git a/src/memory/conspage.c b/src/memory/conspage.c index 2aa8dce..f3c1760 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -45,9 +45,12 @@ struct cons_pointer freelist = NIL; struct cons_page *conspages[NCONSPAGES]; /** - * Make a cons page whose serial number (i.e. index in the conspages directory) is pageno. - * Initialise all cells and prepend each to the freelist; if pageno is zero, do not prepend - * cells 0 and 1 to the freelist but initialise them as NIL and T respectively. + * Make a cons page. Initialise all cells and prepend each to the freelist; + * if `initialised_cons_pages` is zero, do not prepend cells 0 and 1 to the + * freelist but initialise them as NIL and T respectively. + * \todo we ought to handle cons space exhaustion more gracefully than just + * crashing; should probably return an exception instead, although obviously + * that exception would have to have been pre-built. */ void make_cons_page( ) { struct cons_page *result = malloc( sizeof( struct cons_page ) ); @@ -110,7 +113,7 @@ void make_cons_page( ) { } /** - * dump the allocated pages to this output stream. + * dump the allocated pages to this `output` stream. */ void dump_pages( FILE * output ) { for ( int i = 0; i < initialised_cons_pages; i++ ) { @@ -125,8 +128,9 @@ void dump_pages( FILE * output ) { } /** - * Frees the cell at the specified pointer. Dangerous, primitive, low - * level. + * Frees the cell at the specified `pointer`; for all the types of cons-space + * object which point to other cons-space objects, cascade the decrement. + * Dangerous, primitive, low level. * * @pointer the cell to free */ @@ -136,63 +140,62 @@ void free_cell( struct cons_pointer pointer ) { debug_printf( DEBUG_ALLOC, L"Freeing cell " ); debug_dump_object( pointer, DEBUG_ALLOC ); - switch ( cell->tag.value ) { - /* for all the types of cons-space object which point to other - * cons-space objects, cascade the decrement. */ - case CONSTV: - dec_ref( cell->payload.cons.car ); - dec_ref( cell->payload.cons.cdr ); - break; - case EXCEPTIONTV: - dec_ref( cell->payload.exception.message ); - dec_ref( cell->payload.exception.frame ); - break; - case FUNCTIONTV: - dec_ref( cell->payload.function.source ); - break; - case INTEGERTV: - dec_ref( cell->payload.integer.more ); - break; - case LAMBDATV: - case NLAMBDATV: - dec_ref( cell->payload.lambda.args ); - dec_ref( cell->payload.lambda.body ); - break; - case RATIOTV: - dec_ref( cell->payload.ratio.dividend ); - dec_ref( cell->payload.ratio.divisor ); - break; - case SPECIALTV: - dec_ref( cell->payload.special.source ); - break; - case STRINGTV: - case SYMBOLTV: - dec_ref( cell->payload.string.cdr ); - break; - case VECTORPOINTTV: - /* for vector space pointers, free the actual vector-space - * object. Dangerous! */ - debug_printf( DEBUG_ALLOC, - L"About to free vector-space object at 0x%lx\n", - cell->payload.vectorp.address ); - struct vector_space_object *vso = cell->payload.vectorp.address; - - switch ( vso->header.tag.value ) { - case STACKFRAMETV: - free_stack_frame( get_stack_frame( pointer ) ); - break; - } - - free( ( void * ) cell->payload.vectorp.address ); - debug_printf( DEBUG_ALLOC, - L"Freed vector-space object at 0x%lx\n", - cell->payload.vectorp.address ); - break; - - } - if ( !check_tag( pointer, FREETAG ) ) { if ( cell->count == 0 ) { + switch ( cell->tag.value ) { + case CONSTV: + dec_ref( cell->payload.cons.car ); + dec_ref( cell->payload.cons.cdr ); + break; + case EXCEPTIONTV: + dec_ref( cell->payload.exception.message ); + dec_ref( cell->payload.exception.frame ); + break; + case FUNCTIONTV: + dec_ref( cell->payload.function.source ); + break; + case INTEGERTV: + dec_ref( cell->payload.integer.more ); + break; + case LAMBDATV: + case NLAMBDATV: + dec_ref( cell->payload.lambda.args ); + dec_ref( cell->payload.lambda.body ); + break; + case RATIOTV: + dec_ref( cell->payload.ratio.dividend ); + dec_ref( cell->payload.ratio.divisor ); + break; + case SPECIALTV: + dec_ref( cell->payload.special.source ); + break; + case STRINGTV: + case SYMBOLTV: + dec_ref( cell->payload.string.cdr ); + break; + case VECTORPOINTTV: + /* for vector space pointers, free the actual vector-space + * object. Dangerous! */ + debug_printf( DEBUG_ALLOC, + L"About to free vector-space object at 0x%lx\n", + cell->payload.vectorp.address ); + struct vector_space_object *vso = + cell->payload.vectorp.address; + + switch ( vso->header.tag.value ) { + case STACKFRAMETV: + free_stack_frame( get_stack_frame( pointer ) ); + break; + } + + free( ( void * ) cell->payload.vectorp.address ); + debug_printf( DEBUG_ALLOC, + L"Freed vector-space object at 0x%lx\n", + cell->payload.vectorp.address ); + break; + + } + strncpy( &cell->tag.bytes[0], FREETAG, TAGLENGTH ); cell->payload.free.car = NIL; cell->payload.free.cdr = freelist; @@ -210,11 +213,14 @@ void free_cell( struct cons_pointer pointer ) { } /** - * Allocates a cell with the specified tag. Dangerous, primitive, low + * Allocates a cell with the specified `tag`. Dangerous, primitive, low * level. * * @param tag the tag of the cell to allocate - must be a valid cons space tag. * @return the cons pointer which refers to the cell allocated. + * \todo handle the case where another cons_page cannot be allocated; + * return an exception. Which, as we cannot create such an exception when + * cons space is exhausted, means we must construct it at init time. */ struct cons_pointer allocate_cell( char *tag ) { struct cons_pointer result = freelist; diff --git a/src/memory/conspage.h b/src/memory/conspage.h index aff6f40..ab04d6d 100644 --- a/src/memory/conspage.h +++ b/src/memory/conspage.h @@ -37,42 +37,16 @@ struct cons_page { struct cons_space_object cell[CONSPAGESIZE]; }; -/** - * The (global) pointer to the (global) freelist. Not sure whether this ultimately - * belongs in this file. - */ extern struct cons_pointer freelist; -/** - * An array of pointers to cons pages. - */ extern struct cons_page *conspages[NCONSPAGES]; -/** - * Frees the cell at the specified pointer. Dangerous, primitive, low - * level. - * - * @pointer the cell to free - */ void free_cell( struct cons_pointer pointer ); -/** - * Allocates a cell with the specified tag. Dangerous, primitive, low - * level. - * - * @param tag the tag of the cell to allocate - must be a valid cons space tag. - * @return the cons pointer which refers to the cell allocated. - */ struct cons_pointer allocate_cell( char *tag ); -/** - * initialise the cons page system; to be called exactly once during startup. - */ void initialise_cons_pages( ); -/** - * dump the allocated pages to this output stream. - */ void dump_pages( FILE * output ); #endif diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 6f89742..6a7e2bd 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -25,9 +25,9 @@ #include "stack.h" /** - * Check that the tag on the cell at this pointer is this tag + * True if the tag on the cell at this `pointer` is this `tag`, else false. */ -int check_tag( struct cons_pointer pointer, char *tag ) { +bool check_tag( struct cons_pointer pointer, char *tag ) { struct cons_space_object cell = pointer2cell( pointer ); return strncmp( &cell.tag.bytes[0], tag, TAGLENGTH ) == 0; } @@ -178,12 +178,12 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) { inc_ref( tail ); cell->payload.string.character = c; cell->payload.string.cdr.page = tail.page; - /* TODO: There's a problem here. Sometimes the offsets on + /* \todo There's a problem here. Sometimes the offsets on * strings are quite massively off. Fix is probably * cell->payload.string.cdr = tsil */ cell->payload.string.cdr.offset = tail.offset; } else { - // TODO: should throw an exception! + // \todo should throw an exception! debug_printf( DEBUG_ALLOC, L"Warning: only NIL and %s can be prepended to %s\n", tag, tag ); @@ -193,17 +193,23 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) { } /** - * Construct a string from this character and - * this tail. A string is implemented as a flat list of cells each of which - * has one character and a pointer to the next; in the last cell the - * pointer to next is NIL. + * Construct a string from the character `c` and this `tail`. A string is + * implemented as a flat list of cells each of which has one character and a + * pointer to the next; in the last cell the pointer to next is NIL. + * + * @param c the character to add (prepend); + * @param tail the string which is being built. */ struct cons_pointer make_string( wint_t c, struct cons_pointer tail ) { return make_string_like_thing( c, tail, STRINGTAG ); } /** - * Construct a symbol from this character and this tail. + * Construct a symbol from the character `c` and this `tail`. A symbol is + * internally identical to a string except for having a different tag. + * + * @param c the character to add (prepend); + * @param tail the symbol which is being built. */ struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) { return make_string_like_thing( c, tail, SYMBOLTAG ); @@ -239,7 +245,7 @@ struct cons_pointer make_read_stream( FILE * input ) { } /** - * Construct a cell which points to a stream open for writeing. + * Construct a cell which points to a stream open for writing. * @param output the C stream to wrap. */ struct cons_pointer make_write_stream( FILE * output ) { diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 0cf44a7..acc36df 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -1,4 +1,4 @@ -/** +/* * consspaceobject.h * * Declarations common to all cons space objects. @@ -25,113 +25,189 @@ */ #define TAGLENGTH 4 -/** - * tag values, all of which must be 4 bytes. Must not collide with vector space tag values +/* + * tag values, all of which must be 4 bytes. Must not collide with vector space + * tag values */ /** - * An ordinary cons cell: 1397641027 + * An ordinary cons cell: */ #define CONSTAG "CONS" + +/** + * The string `CONS`, considered as an `unsigned int`. + */ #define CONSTV 1397641027 /** * An exception. */ #define EXCEPTIONTAG "EXEP" + +/** + * The string `EXEP`, considered as an `unsigned int`. + */ #define EXCEPTIONTV 1346721861 /** * An unallocated cell on the free list - should never be encountered by a Lisp - * function. 1162170950 + * function. */ #define FREETAG "FREE" + +/** + * The string `FREE`, considered as an `unsigned int`. + */ #define FREETV 1162170950 /** - * An ordinary Lisp function - one whose arguments are pre-evaluated and passed as - * a stack frame. 1129207110 + * An ordinary Lisp function - one whose arguments are pre-evaluated. + * \see LAMBDATAG for interpretable functions. + * \see SPECIALTAG for functions whose arguments are not pre-evaluated. */ #define FUNCTIONTAG "FUNC" -#define FUNCTIONTV 1129207110 + /** - * An integer number. 1381256777 + * The string `FUNC`, considered as an `unsigned int`. + */ +#define FUNCTIONTV 1129207110 + +/** + * An integer number (bignums are integers). */ #define INTEGERTAG "INTR" + +/** + * The string `INTR`, considered as an `unsigned int`. + */ #define INTEGERTV 1381256777 /** - * A lambda cell. + * A lambda cell. Lambdas are the interpretable (source) versions of functions. + * \see FUNCTIONTAG. */ #define LAMBDATAG "LMDA" + +/** + * The string `LMDA`, considered as an `unsigned int`. + */ #define LAMBDATV 1094995276 /** - * The special cons cell at address {0,0} whose car and cdr both point to itself. - * 541870414 + * The special cons cell at address {0,0} whose car and cdr both point to + * itself. */ #define NILTAG "NIL " + +/** + * The string `NIL `, considered as an `unsigned int`. + */ #define NILTV 541870414 /** - * An nlambda cell. + * An nlambda cell. NLambdas are the interpretable (source) versions of special + * forms. \see SPECIALTAG. */ #define NLAMBDATAG "NLMD" + +/** + * The string `NLMD`, considered as an `unsigned int`. + */ #define NLAMBDATV 1145916494 +/** + * A rational number, stored as pointers two integers representing dividend + * and divisor respectively. + */ +#define RATIOTAG "RTIO" + +/** + * The string `RTIO`, considered as an `unsigned int`. + */ +#define RATIOTV 1330205778 + /** * An open read stream. */ #define READTAG "READ" + +/** + * The string `READ`, considered as an `unsigned int`. + */ #define READTV 1145128274 /** - * A real number. + * A real number, represented internally as an IEEE 754-2008 `binary64`. */ #define REALTAG "REAL" + +/** + * The string `REAL`, considered as an `unsigned int`. + */ #define REALTV 1279346002 /** - * A ratio. - */ -#define RATIOTAG "RTIO" -#define RATIOTV 1330205778 - -/** - * A special form - one whose arguments are not pre-evaluated but passed as a - * s-expression. 1296453715 + * A special form - one whose arguments are not pre-evaluated but passed as + * provided. + * \see NLAMBDATAG. */ #define SPECIALTAG "SPFM" + +/** + * The string `SPFM`, considered as an `unsigned int`. + */ #define SPECIALTV 1296453715 /** - * A string of characters, organised as a linked list. 1196577875 + * A string of characters, organised as a linked list. */ #define STRINGTAG "STRG" + +/** + * The string `STRG`, considered as an `unsigned int`. + */ #define STRINGTV 1196577875 /** - * A symbol is just like a string except not self-evaluating. 1112365395 + * A symbol is just like a string except not self-evaluating. */ #define SYMBOLTAG "SYMB" + +/** + * The string `SYMB`, considered as an `unsigned int`. + */ #define SYMBOLTV 1112365395 /** - * The special cons cell at address {0,1} which is canonically different from NIL. - * 1163219540 + * The special cons cell at address {0,1} which is canonically different + * from NIL. */ #define TRUETAG "TRUE" + +/** + * The string `TRUE`, considered as an `unsigned int`. + */ #define TRUETV 1163219540 /** * A pointer to an object in vector space. */ #define VECTORPOINTTAG "VECP" + +/** + * The string `VECP`, considered as an `unsigned int`. + */ #define VECTORPOINTTV 1346585942 + /** * An open write stream. */ #define WRITETAG "WRIT" + +/** + * The string `WRIT`, considered as an `unsigned int`. + */ #define WRITETV 1414091351 /** @@ -154,96 +230,103 @@ */ #define tag2uint(tag) ((uint32_t)*tag) +/** + * given a cons_pointer as argument, return the cell. + */ #define pointer2cell(pointer) ((conspages[pointer.page]->cell[pointer.offset])) /** - * true if conspointer points to the special cell NIL, else false + * true if `conspoint` points to the special cell NIL, else false * (there should only be one of these so it's slightly redundant). */ #define nilp(conspoint) (check_tag(conspoint,NILTAG)) /** - * true if conspointer points to a cons cell, else false + * true if `conspoint` points to a cons cell, else false */ #define consp(conspoint) (check_tag(conspoint,CONSTAG)) /** - * true if conspointer points to an exception, else false + * true if `conspoint` points to an exception, else false */ #define exceptionp(conspoint) (check_tag(conspoint,EXCEPTIONTAG)) /** - * true if conspointer points to a function cell, else false + * true if `conspoint` points to a function cell, else false */ #define functionp(conspoint) (check_tag(conspoint,FUNCTIONTAG)) /** - * true if conspointer points to a special Lambda cell, else false + * true if `conspoint` points to a special Lambda cell, else false */ #define lambdap(conspoint) (check_tag(conspoint,LAMBDATAG)) /** - * true if conspointer points to a special form cell, else false + * true if `conspoint` points to a special form cell, else false */ #define specialp(conspoint) (check_tag(conspoint,SPECIALTAG)) /** - * true if conspointer points to a string cell, else false + * true if `conspoint` points to a string cell, else false */ #define stringp(conspoint) (check_tag(conspoint,STRINGTAG)) /** - * true if conspointer points to a symbol cell, else false + * true if `conspoint` points to a symbol cell, else false */ #define symbolp(conspoint) (check_tag(conspoint,SYMBOLTAG)) /** - * true if conspointer points to an integer cell, else false + * true if `conspoint` points to an integer cell, else false */ #define integerp(conspoint) (check_tag(conspoint,INTEGERTAG)) /** - * true if conspointer points to a rational number cell, else false + * true if `conspoint` points to a rational number cell, else false */ #define ratiop(conspoint) (check_tag(conspoint,RATIOTAG)) /** - * true if conspointer points to a read stream cell, else false + * true if `conspoint` points to a read stream cell, else false */ #define readp(conspoint) (check_tag(conspoint,READTAG)) /** - * true if conspointer points to a real number cell, else false + * true if `conspoint` points to a real number cell, else false */ #define realp(conspoint) (check_tag(conspoint,REALTAG)) /** - * true if conspointer points to some sort of a number cell, + * 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)) +/** + * true if `conspoint` points to a sequence (list, string or, later, vector), + * else false. + */ #define sequencep(conspoint) (check_tag(conspoint,CONSTAG)||check_tag(conspoint,STRINGTAG)||check_tag(conspoint,SYMBOLTAG)) /** - * true if thr conspointer points to a vector pointer. + * true if `conspoint` points to a vector pointer, else false. */ #define vectorpointp(conspoint) (check_tag(conspoint,VECTORPOINTTAG)) /** - * true if conspointer points to a write stream cell, else false. + * true if `conspoint` points to a write stream cell, else false. */ #define writep(conspoint) (check_tag(conspoint,WRITETAG)) /** - * true if conspointer points to a true cell, else false + * true if `conspoint` points to a true cell, else false * (there should only be one of these so it's slightly redundant). * Also note that anything that is not NIL is truthy. */ #define tp(conspoint) (checktag(conspoint,TRUETAG)) /** - * true if conspoint points to something that is truthy, i.e. + * true if `conspoint` points to something that is truthy, i.e. * anything but NIL. */ #define truep(conspoint) (!checktag(conspoint,NILTAG)) @@ -265,16 +348,18 @@ struct cons_pointer { /** * A stack frame. Yes, I know it isn't a cons-space object, but it's defined - * here to avoid circularity. TODO: refactor. + * here to avoid circularity. \todo refactor. */ struct stack_frame { - struct cons_pointer previous; /* the previous frame */ + /** the previous frame. */ + struct cons_pointer previous; + /** first 8 arument bindings. */ struct cons_pointer arg[args_in_frame]; - /* - * first 8 arument bindings - */ - struct cons_pointer more; /* list of any further argument bindings */ - struct cons_pointer function; /* the function to be called */ + /** list of any further argument bindings. */ + struct cons_pointer more; + /** the function to be called. */ + struct cons_pointer function; + /** the number of arguments provided. */ int args; }; @@ -282,7 +367,9 @@ struct stack_frame { * payload of a cons cell. */ struct cons_payload { + /** Contents of the Address Register, naturally. */ struct cons_pointer car; + /** Contents of the Decrement Register, naturally. */ struct cons_pointer cdr; }; @@ -291,7 +378,9 @@ struct cons_payload { * Message should be a Lisp string; frame should be a pointer to an (unfreed) stack frame. */ struct exception_payload { + /** The message: should be a Lisp string but in practice anything printable will do. */ struct cons_pointer message; + /** pointer to the (unfreed) stack frame in which the exception was thrown. */ struct cons_pointer frame; }; @@ -305,7 +394,17 @@ struct exception_payload { * result). */ struct function_payload { + /** + * pointer to the source from which the function was compiled, or NIL + * if it is a primitive. + */ struct cons_pointer source; + /** pointer to a function which takes a cons pointer (representing + * its argument list) and a cons pointer (representing its environment) and a + * stack frame (representing the previous stack frame) as arguments and returns + * a cons pointer (representing its result). + * \todo check this documentation is current! + */ struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ); @@ -321,28 +420,37 @@ struct free_payload { }; /** - * payload of an integer cell. For the time being just a signed integer; - * later might be a signed 128 bit integer, or might have some flag to point to an - * optional bignum object. + * payload of an integer cell. An integer is in principle a sequence of cells; + * only 60 bits (+ sign bit) are actually used in each cell. If the value + * exceeds 60 bits, the least significant 60 bits are stored in the first cell + * in the chain, the next 60 in the next cell, and so on. Only the value of the + * first cell in any chain should be negative. */ struct integer_payload { + /** the value of the payload (i.e. 60 bits) of this cell. */ int64_t value; + /** the next (more significant) cell in the chain, ir `NIL` if there are no + * more. */ struct cons_pointer more; }; /** - * payload for lambda and nlambda cells + * payload for lambda and nlambda cells. */ struct lambda_payload { + /** the arument list */ struct cons_pointer args; + /** the body of the function to be applied to the arguments. */ struct cons_pointer body; }; /** - * payload for ratio cells. Both dividend and divisor must point to integer (or, later, bignum) cells. + * payload for ratio cells. Both `dividend` and `divisor` must point to integer cells. */ struct ratio_payload { + /** a pointer to an integer representing the dividend */ struct cons_pointer dividend; + /** a pointer to an integer representing the divisor. */ struct cons_pointer divisor; }; @@ -351,20 +459,25 @@ struct ratio_payload { * precision, but I'm not sure of the detail. */ struct real_payload { + /** the value of the number */ long double value; }; /** - * Payload of a special form cell. - * source points to the source from which the function was compiled, or NIL - * if it is a primitive. - * executable points to a function which takes a cons pointer (representing - * its argument list) and a cons pointer (representing its environment) and a - * stack frame (representing the previous stack frame) as arguments and returns - * a cons pointer (representing its result). + * Payload of a special form cell. Currently identical to the payload of a + * function cell. + * \see function_payload */ struct special_payload { + /** + * pointer to the source from which the special form was compiled, or NIL + * if it is a primitive. + */ struct cons_pointer source; + /** pointer to a function which takes a cons pointer (representing + * its argument list) and a cons pointer (representing its environment) and a + * stack frame (representing the previous stack frame) as arguments and returns + * a cons pointer (representing its result). */ struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ); @@ -374,6 +487,7 @@ struct special_payload { * payload of a read or write stream cell. */ struct stream_payload { + /** the stream to read from or write to. */ FILE *stream; }; @@ -384,8 +498,11 @@ struct stream_payload { * payload of a string cell. */ struct string_payload { - wint_t character; /* the actual character stored in this cell */ - uint32_t padding; /* unused padding to word-align the cdr */ + /** the actual character stored in this cell */ + wint_t character; + /** unused padding to word-align the cdr */ + uint32_t padding; + /** the remainder of the string following this character. */ struct cons_pointer cdr; }; @@ -393,19 +510,21 @@ struct string_payload { * payload of a vector pointer cell. */ struct vectorp_payload { + /** the tag of the vector-space object. NOTE that the vector space object + * should itself have the identical tag. */ union { - char bytes[TAGLENGTH]; /* the tag (type) of the - * vector-space object this cell - * points to, considered as bytes. - * NOTE that the vector space object - * should itself have the identical - * tag. */ - uint32_t value; /* the tag considered as a number */ + /** the tag (type) of the vector-space object this cell + * points to, considered as bytes. */ + char bytes[TAGLENGTH]; + /** the tag considered as a number */ + uint32_t value; } tag; - void *address; - /* the address of the actual vector space - * object (TODO: will change when I actually + /** unused padding to word-align the address */ + uint32_t padding; + /** the address of the actual vector space + * object (\todo will change when I actually * implement vector space) */ + void *address; }; /** @@ -413,87 +532,80 @@ struct vectorp_payload { */ struct cons_space_object { union { - char bytes[TAGLENGTH]; /* the tag (type) of this cell, - * considered as bytes */ - uint32_t value; /* the tag considered as a number */ + /** the tag (type) of this cell, + * considered as bytes */ + char bytes[TAGLENGTH]; + /** the tag considered as a number */ + uint32_t value; } tag; - uint32_t count; /* the count of the number of references to - * this cell */ - struct cons_pointer access; /* cons pointer to the access control list of - * this cell */ + /** the count of the number of references to this cell */ + uint32_t count; + /** cons pointer to the access control list of this cell */ + struct cons_pointer access; union { - /* + /** * if tag == CONSTAG */ struct cons_payload cons; - /* + /** * if tag == EXCEPTIONTAG */ struct exception_payload exception; - /* + /** * if tag == FREETAG */ struct free_payload free; - /* + /** * if tag == FUNCTIONTAG */ struct function_payload function; - /* + /** * if tag == INTEGERTAG */ struct integer_payload integer; - /* + /** * if tag == LAMBDATAG or NLAMBDATAG */ struct lambda_payload lambda; - /* + /** * if tag == NILTAG; we'll treat the special cell NIL as just a cons */ struct cons_payload nil; - /* + /** * if tag == RATIOTAG */ struct ratio_payload ratio; - /* + /** * if tag == READTAG || tag == WRITETAG */ struct stream_payload stream; - /* + /** * if tag == REALTAG */ struct real_payload real; - /* + /** * if tag == SPECIALTAG */ struct special_payload special; - /* + /** * if tag == STRINGTAG || tag == SYMBOLTAG */ struct string_payload string; - /* + /** * if tag == TRUETAG; we'll treat the special cell T as just a cons */ struct cons_payload t; - /* + /** * if tag == VECTORPTAG */ struct vectorp_payload vectorp; } payload; }; -/** - * Check that the tag on the cell at this pointer is this tag - */ -int check_tag( struct cons_pointer pointer, char *tag ); +bool check_tag( struct cons_pointer pointer, char *tag ); -/** - * increment the reference count of the object at this cons pointer - */ void inc_ref( struct cons_pointer pointer ); -/** - * decrement the reference count of the object at this cons pointer - */ void dec_ref( struct cons_pointer pointer ); struct cons_pointer make_cons( struct cons_pointer car, @@ -502,71 +614,34 @@ struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer make_exception( struct cons_pointer message, struct cons_pointer frame_pointer ); -/** - * Construct a cell which points to an executable Lisp special form. - */ struct cons_pointer make_function( struct cons_pointer src, struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ) ); -/** - * Construct a lambda (interpretable source) cell - */ struct cons_pointer make_lambda( struct cons_pointer args, struct cons_pointer body ); -/** - * Construct an nlambda (interpretable source) cell; to a - * lambda as a special form is to a function. - */ struct cons_pointer make_nlambda( struct cons_pointer args, struct cons_pointer body ); -/** - * Construct a cell which points to an executable Lisp special form. - */ struct cons_pointer make_special( struct cons_pointer src, struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ) ); -/** - * Construct a string from this character and this tail. A string is - * implemented as a flat list of cells each of which has one character and a - * pointer to the next; in the last cell the pointer to next is NIL. - */ struct cons_pointer make_string( wint_t c, struct cons_pointer tail ); -/** - * Construct a symbol from this character and this tail. A symbol is identical - * to a string except for having a different tag. - */ struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ); -/** - * Construct a cell which points to a stream open for reading. - * @param input the C stream to wrap. - */ struct cons_pointer make_read_stream( FILE * input ); -/** - * Construct a cell which points to a stream open for writeing. - * @param output the C stream to wrap. - */ struct cons_pointer make_write_stream( FILE * output ); - -/** - * Return a lisp string representation of this old skool ASCII string. - */ struct cons_pointer c_string_to_lisp_string( wchar_t *string ); -/** - * Return a lisp symbol representation of this old skool ASCII string. - */ struct cons_pointer c_string_to_lisp_symbol( wchar_t *symbol ); #endif diff --git a/src/memory/dump.c b/src/memory/dump.c index fc9175d..7ec2631 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -151,4 +151,3 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { break; } } - diff --git a/src/memory/dump.h b/src/memory/dump.h index 2293189..ec8928e 100644 --- a/src/memory/dump.h +++ b/src/memory/dump.h @@ -1,4 +1,4 @@ -/** +/* * dump.h * * Dump representations of both cons space and vector space objects. @@ -20,9 +20,6 @@ #define __dump_h -/** - * dump the object at this cons_pointer to this output stream. - */ void dump_object( FILE * output, struct cons_pointer pointer ); #endif diff --git a/src/memory/stack.c b/src/memory/stack.c index a1026b4..cf68701 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -26,14 +26,22 @@ #include "stack.h" #include "vectorspace.h" +/** + * set a register in a stack frame. Alwaye use this to do so, + * because that way we can be sure the inc_ref happens! + */ void set_reg( struct stack_frame *frame, int reg, struct cons_pointer value ) { debug_printf( DEBUG_STACK, L"Setting register %d to ", reg ); debug_print_object( value, DEBUG_STACK ); debug_println( DEBUG_STACK ); - frame->arg[reg++] = value; + dec_ref(frame->arg[reg]); /* if there was anything in that slot + * previously other than NIL, we need to decrement it; + * NIL won't be decremented as it is locked. */ + frame->arg[reg] = value; inc_ref( value ); - if ( reg > frame->args ) { - frame->args = reg; + + if ( reg == frame->args ) { + frame->args++; } } @@ -71,15 +79,10 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) { debug_dump_object( result, DEBUG_ALLOC ); -// debug_printf( DEBUG_STACK, -// L"make_empty_frame: got vector_space_object with size %lu, tag %4.4s\n", -// pointer_to_vso( result )->header.size, -// &pointer_to_vso( result )->header.tag.bytes ); - if ( !nilp( result ) ) { struct stack_frame *frame = get_stack_frame( result ); /* - * TODO: later, pop a frame off a free-list of stack frames + * \todo later, pop a frame off a free-list of stack frames */ frame->previous = previous; @@ -131,7 +134,7 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous, struct cons_space_object cell = pointer2cell( args ); /* - * TODO: if we were running on real massively parallel hardware, + * \todo if we were running on real massively parallel hardware, * each arg except the first should be handed off to another * processor to be evaled in parallel; but see notes here: * https://github.com/simon-brooke/post-scarcity/wiki/parallelism @@ -220,7 +223,7 @@ struct cons_pointer make_special_frame( struct cons_pointer previous, */ void free_stack_frame( struct stack_frame *frame ) { /* - * TODO: later, push it back on the stack-frame freelist + * \todo later, push it back on the stack-frame freelist */ debug_print( L"Entering free_stack_frame\n", DEBUG_ALLOC ); for ( int i = 0; i < args_in_frame; i++ ) { diff --git a/src/memory/stack.h b/src/memory/stack.h index 189ff6b..11763b2 100644 --- a/src/memory/stack.h +++ b/src/memory/stack.h @@ -35,12 +35,6 @@ */ #define stackframep(vso)(((struct vector_space_object *)vso)->header.tag.value == STACKFRAMETV) -/** - * set a register in a stack frame. Alwaye use this macro to do so, - • because that way we can be sure the inc_ref happens! - */ -//#define set_reg(frame,register,value){frame->arg[register]=value; inc_ref(value);} - void set_reg( struct stack_frame *frame, int reg, struct cons_pointer value ); struct stack_frame *get_stack_frame( struct cons_pointer pointer ); @@ -65,7 +59,7 @@ struct cons_pointer make_special_frame( struct cons_pointer previous, /* * struct stack_frame is defined in consspaceobject.h to break circularity - * TODO: refactor. + * \todo refactor. */ #endif diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c index 5ec14a8..9d98a77 100644 --- a/src/memory/vectorspace.c +++ b/src/memory/vectorspace.c @@ -26,19 +26,28 @@ /** - * make a cons-space object which points to the vector space object + * Make a cons_space_object which points to the vector_space_object * with this `tag` at this `address`. - * NOTE that `tag` should be the vector-space tag of the particular type of - * vector-space object, NOT `VECTORPOINTTAG`. + * + * @address the address of the vector_space_object to point to. + * @tag the vector-space tag of the particular type of vector-space object, + * NOT `VECTORPOINTTAG`. + * + * @return a cons_pointer to the object, or NIL if the object could not be + * allocated due to memory exhaustion. */ -struct cons_pointer make_vec_pointer( struct vector_space_object *address ) { +struct cons_pointer make_vec_pointer( struct vector_space_object *address, char *tag ) { debug_print( L"Entered make_vec_pointer\n", DEBUG_ALLOC ); struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); + debug_printf( DEBUG_ALLOC, L"make_vec_pointer: tag written, about to set pointer address to %p\n", address ); + cell->payload.vectorp.address = address; + strncpy(&cell->payload.vectorp.tag.bytes[0], tag, TAGLENGTH); + debug_printf( DEBUG_ALLOC, L"make_vec_pointer: all good, returning pointer to %p\n", cell->payload.vectorp.address ); @@ -49,11 +58,15 @@ struct cons_pointer make_vec_pointer( struct vector_space_object *address ) { } /** - * allocate a vector space object with this `payload_size` and `tag`, + * Allocate a vector space object with this `payload_size` and `tag`, * and return a `cons_pointer` which points to an object whigh points to it. - * NOTE that `tag` should be the vector-space tag of the particular type of - * vector-space object, NOT `VECTORPOINTTAG`. - * Returns NIL if the vector could not be allocated due to memory exhaustion. + * + * @tag the vector-space tag of the particular type of vector-space object, + * NOT `VECTORPOINTTAG`. + * @payload_size the size of the payload required, in bytes. + * + * @return a cons_pointer to the object, or NIL if the object could not be + * allocated due to memory exhaustion. */ struct cons_pointer make_vso( char *tag, uint64_t payload_size ) { debug_print( L"Entered make_vso\n", DEBUG_ALLOC ); @@ -72,7 +85,7 @@ struct cons_pointer make_vso( char *tag, uint64_t payload_size ) { L"make_vso: about to write tag '%s' into vso at %p\n", tag, vso ); strncpy( &vso->header.tag.bytes[0], tag, TAGLENGTH ); - result = make_vec_pointer( vso ); + result = make_vec_pointer( vso, tag ); debug_dump_object( result, DEBUG_ALLOC ); vso->header.vecp = result; // memcpy(vso->header.vecp, result, sizeof(struct cons_pointer)); diff --git a/src/memory/vectorspace.h b/src/memory/vectorspace.h index 1438d37..22b0d88 100644 --- a/src/memory/vectorspace.h +++ b/src/memory/vectorspace.h @@ -40,32 +40,48 @@ #define VECTORTAG "VECT" #define VECTORTV 0 +/** + * given a pointer to a vector space object, return the object. + */ #define pointer_to_vso(pointer)((vectorpointp(pointer)? (struct vector_space_object *) pointer2cell(pointer).payload.vectorp.address : (struct vector_space_object *) NULL)) -#define vso_get_vecp(vso)((vso->header.vecp)) + +/** + * given a vector space object, return its canonical pointer. + */ +#define vso_get_vecp(vso)((((vector_space_object)vso)->header.vecp)) struct cons_pointer make_vso( char *tag, uint64_t payload_size ); +/** + * the header which forms the start of every vector space object. + */ struct vector_space_header { + /** the tag (type) of this vector-space object. */ union { - char bytes[TAGLENGTH]; /* the tag (type) of the - * vector-space object this cell - * points to, considered as bytes. - * NOTE that the vector space object - * should itself have the identical - * tag. */ - uint32_t value; /* the tag considered as a number */ + /** the tag considered as bytes. */ + char bytes[TAGLENGTH]; + /** the tag considered as a number */ + uint32_t value; } tag; - struct cons_pointer vecp; /* back pointer to the vector pointer - * which uniquely points to this vso */ - uint64_t size; /* the size of my payload, in bytes */ + /** back pointer to the vector pointer which uniquely points to this vso */ + struct cons_pointer vecp; + /** the size of my payload, in bytes */ + uint64_t size; }; +/** a vector_space_object is just a vector_space_header followed by a + * lump of bytes; what we deem to be in there is a function of the tag, + * and at this stage we don't have a good picture of what these may be. + * + * \see stack_frame for an example payload; + * \see make_empty_frame for an example of how to initialise and use one. + */ struct vector_space_object { + /** the header of this object */ struct vector_space_header header; - char payload; /* we'll malloc `size` bytes for payload, - * `payload` is just the first of these. - * TODO: this is almost certainly not - * idiomatic C. */ + /** we'll malloc `size` bytes for payload, `payload` is just the first of these. + * \todo this is almost certainly not idiomatic C. */ + char payload; }; #endif diff --git a/src/ops/intern.c b/src/ops/intern.c index 9d2387c..1e32a36 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -27,7 +27,8 @@ #include "print.h" /** - * The object list. What is added to this during system setup is 'global', that is, + * The global object list/or, to put it differently, the root namespace. + * What is added to this during system setup is 'global', that is, * visible to all sessions/threads. What is added during a session/thread is local to * that session/thread (because shallow binding). There must be some way for a user to * make the contents of their own environment persistent between threads but I don't diff --git a/src/ops/intern.h b/src/ops/intern.h index e940daa..b261242 100644 --- a/src/ops/intern.h +++ b/src/ops/intern.h @@ -1,14 +1,14 @@ -/** +/* * intern.h * * For now this implements an oblist and shallow binding; local environments can * be consed onto the front of the oblist. Later, this won't do; bindings will happen * in namespaces, which will probably be implemented as hash tables. - * + * * Doctrine is that cons cells are immutable, and life is a lot more simple if they are; * so when a symbol is rebound in the master oblist, what in fact we do is construct * a new oblist without the previous binding but with the new binding. Anything which, - * prior to this action, held a pointer to the old oblist (as all current threads' + * prior to this action, held a pointer to the old oblist (as all current threads' * environments must do) continues to hold a pointer to the old oblist, and consequently * doesn't see the change. This is probably good but does mean you cannot use bindings * on the oblist to signal between threads. @@ -22,42 +22,19 @@ extern struct cons_pointer oblist; -/** - * return the value associated with this key in this store. In the current - * implementation a store is just an assoc list, but in future it might be a - * namespace, a regularity or a homogeneity. - */ struct cons_pointer c_assoc( struct cons_pointer key, struct cons_pointer store ); -/** - * Return true if this key is present as a key in this enviroment, defaulting to - * the oblist if no environment is passed. - */ struct cons_pointer internedp( struct cons_pointer key, struct cons_pointer environment ); -/** - * Return a new key/value store containing all the key/value pairs in this store - * with this key/value pair added to the front. - */ struct cons_pointer bind( struct cons_pointer key, struct cons_pointer value, struct cons_pointer store ); -/** - * Binds this key to this value in the global oblist, but doesn't affect the - * current environment. May not be useful except in bootstrapping (and even - * there it may not be especially useful). - */ struct cons_pointer deep_bind( struct cons_pointer key, struct cons_pointer value ); -/** - * Ensure that a canonical copy of this key is bound in this environment, and - * return that canonical copy. If there is currently no such binding, create one - * with the value NIL. - */ struct cons_pointer intern( struct cons_pointer key, struct cons_pointer environment ); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 298ae1a..775f3b4 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -39,9 +39,9 @@ /* * also to create in this section: * struct cons_pointer lisp_let( struct cons_pointer args, struct cons_pointer env, - struct stack_frame* frame); + * struct stack_frame* frame); * struct cons_pointer lisp_mapcar( struct cons_pointer args, struct cons_pointer env, - struct stack_frame* frame); + * struct stack_frame* frame); * * and others I haven't thought of yet. */ @@ -109,9 +109,13 @@ struct cons_pointer eval_form( struct stack_frame *parent, } /** - * eval all the forms in this `list` in the context of this stack `frame` + * Evaluate all the forms in this `list` in the context of this stack `frame` * and this `env`, and return a list of their values. If the arg passed as - * `list` is not in fact a list, return nil. + * `list` is not in fact a list, return NIL. + * @param frame the stack frame. + * @param list the list of forms to be evaluated. + * @param env the evaluation environment. + * @return a list of the the results of evaluating the forms. */ struct cons_pointer eval_forms( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -140,9 +144,8 @@ lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer, return oblist; } - /** - * used to construct the body for `lambda` and `nlambda` expressions. + * Used to construct the body for `lambda` and `nlambda` expressions. */ struct cons_pointer compose_body( struct stack_frame *frame ) { struct cons_pointer body = frame->more; @@ -164,6 +167,8 @@ struct cons_pointer compose_body( struct stack_frame *frame ) { /** * Construct an interpretable function. * + * (lambda args body) + * * @param frame the stack frame in which the expression is to be interpreted; * @param env the environment in which it is to be intepreted. */ @@ -176,6 +181,8 @@ lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer, /** * Construct an interpretable special form. * + * (nlambda args body) + * * @param frame the stack frame in which the expression is to be interpreted; * @param env the environment in which it is to be intepreted. */ @@ -220,11 +227,11 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, } inc_ref( new_env ); - /* TODO: if there's more than `args_in_frame` arguments, bind those too. */ + /* \todo if there's more than `args_in_frame` arguments, bind those too. */ } else if ( symbolp( names ) ) { /* if `names` is a symbol, rather than a list of symbols, * then bind a list of the values of args to that symbol. */ - /* TODO: eval all the things in frame->more */ + /* \todo eval all the things in frame->more */ struct cons_pointer vals = eval_forms( frame, frame_pointer, frame->more, env ); @@ -412,17 +419,24 @@ struct cons_pointer c_type( struct cons_pointer pointer ) { /** - * (eval s_expr) + * Function; evaluate the expression which is the first argument in the frame; + * further arguments are ignored. * - * function. - * If s_expr is a number, NIL, or T, returns s_expr. - * If s_expr is an unprotected string, returns the value that s_expr is bound - * to in the evaluation environment (env). - * If s_expr is a list, expects the car to be something that evaluates to a - * function or special form. - * If a function, evaluates all the other top level elements in s_expr and - * passes them in a stack frame as arguments to the function. - * If a special form, passes the cdr of s_expr to the special form as argument. + * * (eval expression) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return + * * If `expression` is a number, string, `nil`, or `t`, returns `expression`. + * * If `expression` is a symbol, returns the value that expression is bound + * to in the evaluation environment (`env`). + * * If `expression` is a list, expects the car to be something that evaluates to a + * function or special form: + * * If a function, evaluates all the other top level elements in `expression` and + * passes them in a stack frame as arguments to the function; + * * If a special form, passes the cdr of expression to the special form as argument. + * @exception if `expression` is a symbol which is not bound in `env`. */ struct cons_pointer lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -457,12 +471,9 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, } break; /* - * TODO: + * \todo * the Clojure practice of having a map serve in the function place of - * an s-expression is a good one and I should adopt it; also if the - * object is a consp it could be interpretable source code but in the - * long run I don't want an interpreter, and if I can get away without - * so much the better. + * an s-expression is a good one and I should adopt it; */ default: result = frame->arg[0]; @@ -477,11 +488,16 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, /** - * (apply fn args) - * - * function. Apply the function which is the result of evaluating the - * first argoment to the list of arguments which is the result of evaluating + * Function; apply the function which is the result of evaluating the + * first argument to the list of values which is the result of evaluating * the second argument + * + * * (apply fn args) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return the result of applying `fn` to `args`. */ struct cons_pointer lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -502,11 +518,16 @@ lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, /** - * (quote a) - * - * Special form - * Returns its argument (strictly first argument - only one is expected but + * Special form; + * returns its argument (strictly first argument - only one is expected but * this isn't at this stage checked) unevaluated. + * + * * (quote a) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return `a`, unevaluated, */ struct cons_pointer lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -516,13 +537,19 @@ lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer, /** - * (set name value) - * (set name value namespace) - * - * Function. + * Function; + * binds the value of `name` in the `namespace` to value of `value`, altering + * the namespace in so doing. Retuns `value`. * `namespace` defaults to the oblist. - * Binds the value of `name` in the `namespace` to value of `value`, altering - * the namespace in so doing. `namespace` defaults to the value of `oblist`. + * \todo doesn't actually work yet for namespaces which are not the oblist. + * + * * (set name value) + * * (set name value namespace) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return `value` */ struct cons_pointer lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -548,20 +575,25 @@ lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, /** - * (set! symbol value) - * (set! symbol value namespace) + * Special form; + * binds `symbol` in the `namespace` to value of `value`, altering + * the namespace in so doing, and returns value. `namespace` defaults to + * the value of `oblist`. + * \todo doesn't actually work yet for namespaces which are not the oblist. * - * Special form. - * `namespace` defaults to the oblist. - * Binds `symbol` in the `namespace` to value of `value`, altering - * the namespace in so doing. `namespace` defaults to the value of `oblist`. + * * (set! symbol value) + * * (set! symbol value namespace) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return `value` */ struct cons_pointer lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; - struct cons_pointer namespace = - nilp( frame->arg[2] ) ? oblist : frame->arg[2]; + struct cons_pointer namespace = frame->arg[2]; if ( symbolp( frame->arg[0] ) ) { struct cons_pointer val = @@ -581,12 +613,17 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, } /** - * (cons a b) - * - * Function. - * Returns a cell constructed from a and b. If a is of type string but its + * Function; + * returns a cell constructed from a and b. If a is of type string but its * cdr is nill, and b is of type string, then returns a new string cell; * otherwise returns a new cons cell. + * + * * (cons a b) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return a new cons cell whose `car` is `a` and whose `cdr` is `b`. */ struct cons_pointer lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -597,8 +634,8 @@ lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( nilp( car ) && nilp( cdr ) ) { return NIL; - } else if ( stringp( car ) && stringp( cdr ) && - nilp( pointer2cell( car ).payload.string.cdr ) ) { + } else if ( stringp( car ) && stringp( cdr )) { + // \todo check that car is of length 1 result = make_string( pointer2cell( car ).payload.string.character, cdr ); } else { @@ -609,9 +646,17 @@ lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, } /** - * (car s_expr) - * Returns the first item (head) of a sequence. Valid for cons cells, - * strings, and TODO read streams and other things which can be considered as sequences. + * Function; + * returns the first item (head) of a sequence. Valid for cons cells, + * strings, read streams and TODO other things which can be considered as sequences. + * + * * (car expression) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the first item (head) of `expression`. + * @exception if `expression` is not a sequence. */ struct cons_pointer lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -626,11 +671,11 @@ lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, case READTV: result = make_string( fgetwc( cell.payload.stream.stream ), NIL ); break; + case NILTV: + break; case STRINGTV: result = make_string( cell.payload.string.character, NIL ); break; - case NILTV: - break; default: result = throw_exception( c_string_to_lisp_string @@ -642,11 +687,19 @@ lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, } /** - * (cdr s_expr) - * Returns the remainder of a sequence when the head is removed. Valid for cons cells, - * strings, and TODO read streams and other things which can be considered as sequences. - * NOTE that if the argument is an input stream, the first character is removed AND + * Function; + * returns the remainder of a sequence when the head is removed. Valid for cons cells, + * strings, read streams and TODO other things which can be considered as sequences. + * *NOTE* that if the argument is an input stream, the first character is removed AND * DISCARDED. + * + * * (cdr expression) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the remainder of `expression` when the head is removed. + * @exception if `expression` is not a sequence. */ struct cons_pointer lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -678,8 +731,14 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, } /** - * (assoc key store) - * Returns the value associated with key in store, or NIL if not found. + * Function; look up the value of a `key` in a `store`. + * + * * (assoc key store) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the value associated with `key` in `store`, or `nil` if not found. */ struct cons_pointer lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -688,8 +747,14 @@ lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer, } /** - * (eq a b) - * Returns T if a and b are pointers to the same object, else NIL + * Function; are these two objects the same object? Shallow, cheap equality. + * + * * (eq a b) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return `t` if `a` and `b` are pointers to the same object, else `nil`; */ struct cons_pointer lisp_eq( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -698,8 +763,14 @@ struct cons_pointer lisp_eq( struct stack_frame *frame, } /** - * (eq a b) - * Returns T if a and b are pointers to structurally identical objects, else NIL + * Function; are these two arguments identical? Deep, expensive equality. + * + * * (equal a b) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return `t` if `a` and `b` are recursively identical, else `nil`. */ struct cons_pointer lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -728,10 +799,17 @@ struct cons_pointer get_default_stream( bool inputp, struct cons_pointer env ) { /** - * (read) - * (read read-stream) - * Read one complete lisp form and return it. If read-stream is specified and - * is a read stream, then read from that stream, else stdin. + * Function; read one complete lisp form and return it. If read-stream is specified and + * is a read stream, then read from that stream, else the stream which is the value of + * `*in*` in the environment. + * + * * (read) + * * (read read-stream) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return the expression read. */ struct cons_pointer lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -788,8 +866,14 @@ struct cons_pointer c_reverse( struct cons_pointer arg ) { /** - * (reverse sequence) - * Return a sequence like this sequence but with the members in the reverse order. + * Function; reverse the order of members in s sequence. + * + * * (reverse sequence) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return a sequence like this `sequence` but with the members in the reverse order. */ struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -799,10 +883,17 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame, /** - * (print expr) - * (print expr write-stream) - * Print one complete lisp form and return NIL. If write-stream is specified and - * is a write stream, then print to that stream, else stdout. + * Function; print one complete lisp expression and return NIL. If write-stream is specified and + * is a write stream, then print to that stream, else the stream which is the value of + * `*out*` in the environment. + * + * * (print expr) + * * (print expr write-stream) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the value of `expr`. */ struct cons_pointer lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -837,10 +928,14 @@ lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, /** - * Function: Get the Lisp type of the single argument. - * @param frame My stack frame. - * @param env My environment (ignored). - * @return As a Lisp string, the tag of the object which is the argument. + * Function: get the Lisp type of the single argument. + * + * * (type expression) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return As a Lisp string, the tag of `expression`. */ struct cons_pointer lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -849,21 +944,21 @@ lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, } /** - * Evaluate each of these forms in this `env`ironment over this `frame`, + * Evaluate each of these expressions in this `env`ironment over this `frame`, * returning only the value of the last. */ struct cons_pointer c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer forms, struct cons_pointer env ) { + struct cons_pointer expressions, struct cons_pointer env ) { struct cons_pointer result = NIL; - while ( consp( forms ) ) { + while ( consp( expressions ) ) { struct cons_pointer r = result; inc_ref( r ); - result = eval_form( frame, frame_pointer, c_car( forms ), env ); + result = eval_form( frame, frame_pointer, c_car( expressions ), env ); dec_ref( r ); - forms = c_cdr( forms ); + expressions = c_cdr( expressions ); } return result; @@ -871,15 +966,16 @@ c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, /** - * (progn forms...) - * - * Special form; evaluate the forms which are listed in my arguments + * Special form; evaluate the expressions which are listed in my arguments * sequentially and return the value of the last. This function is called 'do' * in some dialects of Lisp. * - * @param frame My stack frame. - * @param env My environment (ignored). - * @return the value of the last form on the sequence which is my single + * * (progn expressions...) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment in which expressions are evaluated. + * @return the value of the last `expression` of the sequence which is my single * argument. */ struct cons_pointer @@ -904,16 +1000,20 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, } /** - * Special form: conditional. Each arg is expected to be a list; if the first + * Special form: conditional. Each `clause` is expected to be a list; if the first * item in such a list evaluates to non-NIL, the remaining items in that list - * are evaluated in turn and the value of the last returned. If no arg (clause) + * are evaluated in turn and the value of the last returned. If no arg `clause` * has a first element which evaluates to non NIL, then NIL is returned. - * @param frame My stack frame. - * @param env My environment (ignored). - * @return the value of the last form of the first successful clause. + * + * * (cond clauses...) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment in which arguments will be evaluated. + * @return the value of the last expression of the first successful `clause`. */ struct cons_pointer -lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, + lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; bool done = false; @@ -943,7 +1043,7 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, frame_pointer ); } } - /* TODO: if there are more than 8 clauses we need to continue into the + /* \todo if there are more than 8 clauses we need to continue into the * remainder */ return result; @@ -978,9 +1078,18 @@ throw_exception( struct cons_pointer message, } /** - * (exception ) + * Function; create an exception. Exceptions are special in as much as if an + * exception is created in the binding of the arguments of any function, the + * function will return the exception rather than whatever else it would + * normally return. A function which detects a problem it cannot resolve + * *should* return an exception. * - * Function. Returns an exception whose message is this `message`, and whose + * * (exception ) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment in which arguments will be evaluated. + * @return areturns an exception whose message is this `message`, and whose * stack frame is the parent stack frame when the function is invoked. * `message` does not have to be a string but should be something intelligible * which can be read. @@ -995,19 +1104,23 @@ lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, } /** - * (repl) - * (repl prompt) - * (repl prompt input_stream output_stream) + * Function: the read/eval/print loop. * - * Function: the read/eval/print loop. Returns the value of the last expression - * entered. + * * (repl) + * * (repl prompt) + * * (repl prompt input_stream output_stream) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment in which epressions will be evaluated. + * @return the value of the last expression read. */ struct cons_pointer lisp_repl( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer expr = NIL; - /* TODO: bind *prompt*, *input*, *output* in the environment to the values + /* \todo bind *prompt*, *input*, *output* in the environment to the values * of arguments 0, 1, and 2 respectively, but in each case only if the * argument is not nil */ @@ -1023,7 +1136,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, inc_ref( output ); inc_ref( prompt_name ); - /* TODO: this is subtly wrong. If we were evaluating + /* \todo this is subtly wrong. If we were evaluating * (print (eval (read))) * then the stack frame for read would have the stack frame for * eval as parent, and it in turn would have the stack frame for @@ -1035,7 +1148,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, * bound in the oblist subsequent to this function being invoked isn't in the * environment. So, for example, changes to *prompt* or *log* made in the oblist * are not visible. So copy changes made in the oblist into the enviroment. - * TODO: the whole process of resolving symbol values needs to be revisited + * \todo the whole process of resolving symbol values needs to be revisited * when we get onto namespaces. */ if ( !eq( oblist, old_oblist ) ) { struct cons_pointer cursor = oblist; @@ -1089,11 +1202,16 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, } /** - * (source object) + * Function. return the source code of the object which is its first argument, + * if it is an executable and has source code. * - * Function. - * Return the source code of the object, if it is an executable - * and has source code. + * * (source object) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment (ignored). + * @return the source of the `object` indicated, if it is a function, a lambda, + * an nlambda, or a spcial form; else `nil`. */ struct cons_pointer lisp_source( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -1119,7 +1237,7 @@ struct cons_pointer lisp_source( struct stack_frame *frame, cell.payload.lambda.body ) ); break; } - // TODO: suffers from premature GC, and I can't see why! + // \todo suffers from premature GC, and I can't see why! inc_ref( result ); return result; @@ -1127,11 +1245,20 @@ struct cons_pointer lisp_source( struct stack_frame *frame, /** - * Print the internal representation of the object indicated by `frame->arg[0]` to the - * (optional, defaults to `stdout`) stream indicated by `frame->arg[1]`. + * Function; print the internal representation of the object indicated by `frame->arg[0]` to the + * (optional, defaults to the value of `*out*` in the environment) stream indicated by `frame->arg[1]`. + * + * * (inspect expression) + * * (inspect expression ) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment. + * @return the value of the first argument - `expression`. */ -struct cons_pointer lisp_inspect( 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 ) { debug_print( L"Entering print\n", DEBUG_IO ); FILE *output = stdout; struct cons_pointer out_stream = writep( frame->arg[1] ) ? diff --git a/src/ops/lispops.h b/src/ops/lispops.h index 7d7d395..1aff486 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -202,5 +202,6 @@ 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 ); +struct cons_pointer lisp_inspect( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); diff --git a/src/ops/print.c b/src/ops/print.c index 3feeb21..604c07c 100644 --- a/src/ops/print.c +++ b/src/ops/print.c @@ -25,7 +25,7 @@ /** * Whether or not we colorise output. - * TODO: this should be a Lisp symbol binding, not a C variable. + * \todo this should be a Lisp symbol binding, not a C variable. */ int print_use_colours = 0; @@ -122,7 +122,7 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { dump_stack_trace( output, pointer ); break; case FUNCTIONTV: - fwprintf( output, L"(Function)" ); + fwprintf( output, L"" ); break; case INTEGERTV:{ struct cons_pointer s = integer_to_string( pointer, 10 ); @@ -167,10 +167,10 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { print( output, cell.payload.ratio.divisor ); break; case READTV: - fwprintf( output, L"(Input stream)" ); + fwprintf( output, L"" ); break; case REALTV: - /* TODO: using the C heap is a bad plan because it will fragment. + /* \todo using the C heap is a bad plan because it will fragment. * As soon as I have working vector space I'll use a special purpose * vector space object */ buffer = ( char * ) malloc( 24 ); @@ -201,13 +201,13 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { print_string_contents( output, pointer ); break; case SPECIALTV: - fwprintf( output, L"(Special form)" ); + fwprintf( output, L"" ); break; case TRUETV: fwprintf( output, L"t" ); break; case WRITETV: - fwprintf( output, L"(Output stream)" ); + fwprintf( output, L"" ); break; default: fwprintf( stderr, diff --git a/src/ops/read.c b/src/ops/read.c index 6e2a07f..4006c99 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -119,7 +119,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, read_number( frame, frame_pointer, input, c, true ); } else if ( iswblank( next ) ) { - /* dotted pair. TODO: this isn't right, we + /* dotted pair. \todo this isn't right, we * really need to backtrack up a level. */ result = read_continuation( frame, frame_pointer, input, @@ -153,7 +153,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, /** * read a number from this input stream, given this initial character. - * TODO: Need to do a lot of inc_ref and dec_ref, to make sure the + * \todo Need to do a lot of inc_ref and dec_ref, to make sure the * garbage is collected. */ struct cons_pointer read_number( struct stack_frame *frame, @@ -163,7 +163,7 @@ struct cons_pointer read_number( struct stack_frame *frame, debug_print( L"entering read_number\n", DEBUG_IO ); struct cons_pointer result = make_integer( 0, NIL ); - /* TODO: we really need to be getting `base` from a privileged Lisp name - + /* \todo we really need to be getting `base` from a privileged Lisp name - * and it should be the same privileged name we use when writing numbers */ struct cons_pointer base = make_integer( 10, NIL ); struct cons_pointer dividend = NIL; @@ -298,7 +298,7 @@ struct cons_pointer read_string( FILE * input, wint_t initial ) { struct cons_pointer result; switch ( initial ) { case '\0': - result = make_string( initial, NIL ); + result = NIL; break; case '"': /* making a string of the null character means we can have an empty diff --git a/unit-tests/string-cons.sh b/unit-tests/string-cons.sh new file mode 100644 index 0000000..0ea0a71 --- /dev/null +++ b/unit-tests/string-cons.sh @@ -0,0 +1,25 @@ +#!/bin/bash + +# We should be able to cons a single character string onto the front of a string +expected='"Test"' +actual=`echo '(cons "T" "est")' | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +# But if the first argument has more than one character, we should get a dotted pair +expected='("Test" . "pass")' +actual=`echo '(cons "Test" "pass")' | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi From 64fc43e9fcc8b15a02cf02622a0c86a022c200d1 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 20 Jan 2019 23:34:46 +0000 Subject: [PATCH 29/40] OK, my idea that long multiplication is like long addition is wrong. It's still broken, but it's broken because of fundamental misunderstanding which tinkering won't solve. --- lisp/scratchpad.lisp | 2 +- lisp/scratchpad2.lisp | 3 ++- src/arith/integer.c | 18 +++++++++++++----- src/ops/lispops.c | 32 +++++++++++++++++++++++++++----- unit-tests/eval-quote-symbol.sh | 2 +- unit-tests/many-args.sh | 13 ++++++++++++- 6 files changed, 56 insertions(+), 14 deletions(-) diff --git a/lisp/scratchpad.lisp b/lisp/scratchpad.lisp index 494fe59..0474099 100644 --- a/lisp/scratchpad.lisp +++ b/lisp/scratchpad.lisp @@ -45,4 +45,4 @@ (inspect (set! z (+ y y y y y y y y y y))) "This blows up: 10^37, which is a three cell bignum." -(inspect (+ z z z z z z z z z z)) +(inspect (set! final (+ z z z z z z z z z z))) diff --git a/lisp/scratchpad2.lisp b/lisp/scratchpad2.lisp index e608106..65f7aca 100644 --- a/lisp/scratchpad2.lisp +++ b/lisp/scratchpad2.lisp @@ -81,4 +81,5 @@ (inspect (set! z (+ y y y y y y y y))) -(inspect (+ z z z z z z z z)) +(inspect + (set! final (+ z z z z z z z z))) diff --git a/src/arith/integer.c b/src/arith/integer.c index c51bc56..5b2e26a 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -27,6 +27,7 @@ #include "conspage.h" #include "consspaceobject.h" #include "debug.h" +#include "lispops.h" /* * The maximum value we will allow in an integer cell. @@ -104,14 +105,20 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { * \see operate_on_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 val = nilp( c ) ? + 0 : + pointer2cell( c ).payload.integer.value; + long int carry = is_first_cell ? 0 : ( MAX_INTEGER + 1 ); __int128_t result = ( __int128_t ) integerp( c ) ? - ( val == 0 ) ? carry : val : op == '*' ? 1 : 0; + ( val == 0 ) ? + carry : + val : + 0; debug_printf( DEBUG_ARITH, - L"cell_value: raw value is %ld, op = '%c', is_first_cell = %s; returning ", - val, op, is_first_cell ? "true" : "false" ); + L"cell_value: raw value is %ld, op = '%c', is_first_cell = %s; %4.4s; returning ", + val, op, is_first_cell ? "true" : "false", pointer2cell(c).tag.bytes); debug_print_128bit( result, DEBUG_ARITH ); debug_println( DEBUG_ARITH ); @@ -139,6 +146,7 @@ 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; bool is_first_cell = true; @@ -163,7 +171,7 @@ struct cons_pointer operate_on_integers( struct cons_pointer a, switch ( op ) { case '*': - rv = av * ( bv + carry ); + rv = (av * bv) + carry; break; case '+': rv = av + bv + carry; diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 775f3b4..c80d965 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -136,7 +136,12 @@ struct cons_pointer eval_forms( struct stack_frame *frame, /** * Return the object list (root namespace). * - * (oblist) + * * (oblist) + * + * @param frame the stack frame in which the expression is to be interpreted; + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the root namespace. */ struct cons_pointer lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -165,12 +170,15 @@ struct cons_pointer compose_body( struct stack_frame *frame ) { } /** - * Construct an interpretable function. + * Construct an interpretable function. *NOTE* that if `args` is a single symbol + * rather than a list, a varargs function will be created. * * (lambda args body) * * @param frame the stack frame in which the expression is to be interpreted; + * @param frame_pointer a pointer to my stack_frame. * @param env the environment in which it is to be intepreted. + * @return an interpretable function with these `args` and this `body`. */ struct cons_pointer lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -179,12 +187,15 @@ lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer, } /** - * Construct an interpretable special form. + * Construct an interpretable special form. *NOTE* that if `args` is a single symbol + * rather than a list, a varargs special form will be created. * * (nlambda args body) * * @param frame the stack frame in which the expression is to be interpreted; + * @param frame_pointer a pointer to my stack_frame. * @param env the environment in which it is to be intepreted. + * @return an interpretable special form with these `args` and this `body`. */ struct cons_pointer lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -612,6 +623,16 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, return result; } +/** + * @return true if `arg` represents an end of string, else false. + * \todo candidate for moving to a memory/string.c file + */ +bool end_of_stringp(struct cons_pointer arg) { + return nilp(arg) || + ( stringp( arg ) && + pointer2cell(arg).payload.string.character == (wint_t)'\0'); +} + /** * Function; * returns a cell constructed from a and b. If a is of type string but its @@ -634,7 +655,8 @@ lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( nilp( car ) && nilp( cdr ) ) { return NIL; - } else if ( stringp( car ) && stringp( cdr )) { + } else if ( stringp( car ) && stringp( cdr ) && + end_of_stringp( c_cdr( car)) ) { // \todo check that car is of length 1 result = make_string( pointer2cell( car ).payload.string.character, cdr ); @@ -1084,7 +1106,7 @@ throw_exception( struct cons_pointer message, * normally return. A function which detects a problem it cannot resolve * *should* return an exception. * - * * (exception ) + * * (exception message frame) * * @param frame my stack frame. * @param frame_pointer a pointer to my stack_frame. diff --git a/unit-tests/eval-quote-symbol.sh b/unit-tests/eval-quote-symbol.sh index 253ce32..7e80c48 100755 --- a/unit-tests/eval-quote-symbol.sh +++ b/unit-tests/eval-quote-symbol.sh @@ -1,6 +1,6 @@ #!/bin/bash -expected='(Special form)' +expected='' actual=`echo "(eval 'cond)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] diff --git a/unit-tests/many-args.sh b/unit-tests/many-args.sh index a574ecb..0317f77 100755 --- a/unit-tests/many-args.sh +++ b/unit-tests/many-args.sh @@ -6,7 +6,18 @@ actual=`echo "(+ 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then echo "OK" - exit 0 +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +# check that all the args are actually being evaluated... +expected="120" +actual=`echo "(+ (+ 0 1) (+ 0 2) (+ 0 3) (+ 0 4) (+ 0 5) (+ 0 6) (+ 0 7) (+ 0 8) (+ 0 9) (+ 0 10) (+ 0 11) (+ 0 12) (+ 0 13) (+ 0 14 ) (+ 0 15))" | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" else echo "Fail: expected '${expected}', got '${actual}'" exit 1 From 3fd322af6f147c55b415b7c286227381a0d501b6 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 21 Jan 2019 16:14:25 +0000 Subject: [PATCH 30/40] Major progress, multiply now almost works There's a premature free() somewhere, and I'm not sure why. Print depends on divide, which is easy, but also on mod and floor (of rationals) which isn't. --- lisp/expt.lisp | 3 +- src/arith/integer.c | 238 +++++++++++++++++++++++++++++--------------- src/arith/peano.c | 138 ++++++++++++++++++++----- src/arith/peano.h | 50 +++------- src/init.c | 2 + 5 files changed, 287 insertions(+), 144 deletions(-) diff --git a/lisp/expt.lisp b/lisp/expt.lisp index 433b0ea..7ec849e 100644 --- a/lisp/expt.lisp +++ b/lisp/expt.lisp @@ -5,4 +5,5 @@ ((= x 1) n) (t (* n (expt n (- x 1))))))) -(expt 2 60) +(inspect expt) +(expt 2 59) diff --git a/src/arith/integer.c b/src/arith/integer.c index 5b2e26a..9e1a8a0 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -27,7 +27,9 @@ #include "conspage.h" #include "consspaceobject.h" #include "debug.h" +#include "equal.h" #include "lispops.h" +#include "peano.h" /* * The maximum value we will allow in an integer cell. @@ -100,11 +102,11 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { /** * Internal to `operate_on_integers`, do not use. * @param c a pointer to a cell, assumed to be an integer cell; - * @param op a character representing the operation: expectedto 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 operate_on_integers */ -__int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) { +__int128_t cell_value( struct cons_pointer c, bool is_first_cell ) { long int val = nilp( c ) ? 0 : pointer2cell( c ).payload.integer.value; @@ -117,8 +119,8 @@ __int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) { val : 0; debug_printf( DEBUG_ARITH, - L"cell_value: raw value is %ld, op = '%c', is_first_cell = %s; %4.4s; returning ", - val, op, is_first_cell ? "true" : "false", pointer2cell(c).tag.bytes); + 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 ); @@ -126,60 +128,77 @@ __int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) { } /** - * 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`. + * Overwrite the value field of the integer indicated by `new` with + * the least significant 60 bits of `val`, and return the more significant + * bits (if any) right-shifted by 60 places. Destructive, primitive, do not + * use in any context except primitive operations on integers. * - * @param a a pointer to a cell, assumed to be an integer cell; - * @param b 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. - * \see add_integers - * \see multiply_integers + * @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. */ -/* \todo there is a significant bug here, which manifests in multiply but - * may not manifest in add. The value in the least significant cell ends - * up significantly WRONG, but the value in the more significant cell - * ends up correct. */ -struct cons_pointer operate_on_integers( struct cons_pointer a, - struct cons_pointer b, char op ) { +__int128_t int128_to_integer( __int128_t val, + struct cons_pointer less_significant, + struct cons_pointer new) +{ + struct cons_pointer cursor = NIL; + __int128_t carry = 0; + + if ( MAX_INTEGER >= val ) { + carry = 0; + } else { + carry = val >> 60; + debug_printf( DEBUG_ARITH, + L"int128_to_integer: 64 bit overflow; setting carry to %ld\n", + ( int64_t ) carry ); + val &= MAX_INTEGER; + } + + struct cons_space_object * newc = &pointer2cell( new); + newc->payload.integer.value = 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; + debug_print( L"add_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); + __int128_t carry = 0; bool is_first_cell = true; if ( integerp( a ) && integerp( b ) ) { - debug_print( L"operate_on_integers: \n", DEBUG_ARITH ); + debug_print( L"add_integers: \n", DEBUG_ARITH ); debug_dump_object( a, DEBUG_ARITH ); - debug_printf( DEBUG_ARITH, L" %c \n", op ); + debug_print( L" plus \n", DEBUG_ARITH ); debug_dump_object( b, DEBUG_ARITH ); debug_println( DEBUG_ARITH ); while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { - __int128_t av = cell_value( a, op, is_first_cell ); - __int128_t bv = cell_value( b, op, is_first_cell ); + __int128_t av = cell_value( a, is_first_cell ); + __int128_t bv = cell_value( b, is_first_cell ); + __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; - } - - debug_printf( DEBUG_ARITH, - L"operate_on_integers: op = '%c'; av = ", op ); + 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 ); @@ -189,31 +208,9 @@ struct cons_pointer operate_on_integers( struct cons_pointer a, debug_print_128bit( rv, DEBUG_ARITH ); debug_print( L"\n", DEBUG_ARITH ); - - 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"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; - } 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; - cursor = tail; - } + struct cons_pointer new = make_integer( 0, NIL); + carry = int128_to_integer(rv, cursor, new); + cursor = new; if ( nilp( result ) ) { result = cursor; @@ -225,30 +222,111 @@ struct cons_pointer operate_on_integers( struct cons_pointer a, } } - debug_print( L"operate_on_integers returning:\n", DEBUG_ARITH ); - debug_dump_object( result, DEBUG_ARITH ); + debug_print( L"add_integers returning: ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); debug_println( DEBUG_ARITH ); return result; } -/** - * 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 base_partial(int depth) { + struct cons_pointer result = NIL; - return operate_on_integers( a, b, '+' ); + for (int i = 0; i < depth; i++) { + result = make_integer(0, result); + } + + 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. + * \todo it is MUCH more complicated than this! + * + * @param a an integer; + * @param b an integer. */ struct cons_pointer multiply_integers( struct cons_pointer a, struct cons_pointer b ) { - return operate_on_integers( a, b, '*' ); + struct cons_pointer result = NIL; + bool neg = is_negative(a) != is_negative(b); + bool is_first_b = true; + int oom = 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 ) ) { + while ( !nilp( b ) ) { + bool is_first_d = true; + struct cons_pointer d = a; + struct cons_pointer partial = base_partial(oom++); + __int128_t carry = 0; + + while ( !nilp(d) || carry != 0) { + struct cons_pointer old_partial = partial; + struct cons_pointer new = make_integer( 0, NIL); + __int128_t dv = cell_value( d, is_first_d ); + __int128_t bv = cell_value( b, is_first_b ); + + __int128_t rv = (dv * bv) + carry; + + debug_print( L"multiply_integers: d = ", DEBUG_ARITH); + debug_print_object( d, DEBUG_ARITH); + debug_print( L"; dv = ", DEBUG_ARITH ); + debug_print_128bit( dv, 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"; acc = ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH); + debug_print( L"; partial = ", DEBUG_ARITH ); + debug_print_object( partial, DEBUG_ARITH); + debug_print( L"\n", DEBUG_ARITH ); + + inc_ref(new); + carry = int128_to_integer(rv, NIL, new); + + if (nilp(d) && carry != 0) debug_print(L"THIS SHOULD NEVER HAPPEN!\n", DEBUG_ARITH); + + if (nilp(partial) || zerop(partial)) { + partial = new; + } else { + partial = add_integers(partial, new); + inc_ref(partial); + //dec_ref(new); + } + + //dec_ref(old_partial); + d = integerp(d) ? pointer2cell( d ).payload.integer.more : NIL; + is_first_d = false; + } + + if (nilp(result) || zerop(result)) { + result = partial; + } else { + struct cons_pointer old = result; + result = add_integers(partial, result); + //if (!eq(result, old)) dec_ref(old); + //if (!eq(result, partial)) dec_ref(partial); + } + b = pointer2cell( b ).payload.integer.more; + is_first_b = false; + } + } + + debug_print( L"multiply_integers returning: ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); + + return result; } /** @@ -325,7 +403,7 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, * an unwanted comma on the front. */ struct cons_pointer tmp = result; result = pointer2cell( result ).payload.string.cdr; - dec_ref( tmp ); + //dec_ref( tmp ); } if ( is_negative ) { diff --git a/src/arith/peano.c b/src/arith/peano.c index 6666d0e..85bbd5c 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -57,6 +57,51 @@ bool zerop( struct cons_pointer arg ) { 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; +} + +struct cons_pointer absolute( struct cons_pointer frame_pointer, struct cons_pointer arg) { + struct cons_pointer result = NIL; + struct cons_space_object cell = pointer2cell( 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(frame_pointer, + absolute(frame_pointer, cell.payload.ratio.dividend), + cell.payload.ratio.divisor); + break; + case REALTV: + result = make_real( 0 - cell.payload.real.value ); + break; + } + } + + 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` @@ -136,6 +181,22 @@ int64_t to_long_int( struct cons_pointer arg ) { } +/** + * 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_pointer, frame->arg[0]); +} + /** * return a cons_pointer indicating a number which is the sum of * the numbers indicated by `arg1` and `arg2`. @@ -286,7 +347,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame, debug_print_object( arg1, DEBUG_ARITH ); debug_print( L"; arg2 = ", DEBUG_ARITH ); debug_print_object( arg2, DEBUG_ARITH ); - debug_print( L")", DEBUG_ARITH ); + debug_print( L")\n", DEBUG_ARITH ); if ( zerop( arg1 ) ) { result = arg2; @@ -316,9 +377,10 @@ struct cons_pointer multiply_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = throw_exception( c_string_to_lisp_string - ( L"Cannot multiply: argument 2 is not a number" ), - frame_pointer ); + result = throw_exception( make_cons( + c_string_to_lisp_string( L"Cannot multiply: argument 2 is not a number: " ), + c_type(arg2)), + frame_pointer ); break; } break; @@ -342,8 +404,10 @@ struct cons_pointer multiply_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = throw_exception( c_string_to_lisp_string - ( L"Cannot multiply: argument 1 is not a number" ), + result = throw_exception( + make_cons(c_string_to_lisp_string + ( L"Cannot multiply: argument 2 is not a number" ), + c_type(arg2)), frame_pointer ); } break; @@ -353,20 +417,24 @@ struct cons_pointer multiply_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = throw_exception( c_string_to_lisp_string - ( L"Cannot multiply: not a number" ), - frame_pointer ); + result = throw_exception( + 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" => ", DEBUG_ARITH ); - debug_print_object( arg2, DEBUG_ARITH ); + 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; @@ -381,29 +449,31 @@ struct cons_pointer lisp_multiply( struct 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++ ) { - tmp = result; - result = multiply_2( frame, frame_pointer, result, frame->arg[i] ); + 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); - if ( !eq( tmp, result ) ) { - dec_ref( tmp ); - } + multiply_one_arg(frame->arg[i]); } struct cons_pointer more = frame->more; while ( consp( more ) && !exceptionp( result ) ) { - tmp = result; - result = multiply_2( frame, frame_pointer, result, c_car( more ) ); - - if ( !eq( tmp, result ) ) { - dec_ref( tmp ); - } - + 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; } @@ -445,6 +515,24 @@ struct cons_pointer negative( struct cons_pointer frame, 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`, diff --git a/src/arith/peano.h b/src/arith/peano.h index 816b147..fa03212 100644 --- a/src/arith/peano.h +++ b/src/arith/peano.h @@ -17,66 +17,40 @@ bool zerop( struct cons_pointer arg ); struct cons_pointer negative( struct cons_pointer frame, struct cons_pointer arg ); -/** - * \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. - */ +bool is_negative( struct cons_pointer arg); + +struct cons_pointer absolute( struct cons_pointer frame_pointer, struct cons_pointer arg); + long double to_long_double( struct cons_pointer arg ); -/** - * Add an indefinite number of numbers together - * @param env the evaluation environment - ignored; - * @param frame the stack frame. - * @return a pointer to an integer or real. - */ +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 ); -/** - * Multiply an indefinite number of numbers together. - * @param env the evaluation environment - ignored; - * @param frame the stack frame. - * @return a pointer to an integer or real. - */ +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 ); -/** - * 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 ); -/** - * return a cons_pointer indicating a number which is the result of - * subtracting the numbers 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 ); -/** - * Subtract one number from another. - * @param env the evaluation environment - ignored; - * @param frame the stack frame. - * @return a pointer to an integer or real. - */ struct cons_pointer lisp_subtract( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); -/** - * Divide one number by another. - * @param env the evaluation environment - ignored; - * @param frame the stack frame. - * @return a pointer to an integer or real. - */ struct cons_pointer lisp_divide( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); diff --git a/src/init.c b/src/init.c index 7fdad2d..e0d2b01 100644 --- a/src/init.c +++ b/src/init.c @@ -142,6 +142,7 @@ int main( int argc, char *argv[] ) { /* * primitive function operations */ + bind_function( L"absolute", &lisp_absolute ); bind_function( L"add", &lisp_add ); bind_function( L"apply", &lisp_apply ); bind_function( L"assoc", &lisp_assoc ); @@ -155,6 +156,7 @@ int main( int argc, char *argv[] ) { bind_function( L"exception", &lisp_exception ); bind_function( L"inspect", &lisp_inspect ); bind_function( L"multiply", &lisp_multiply ); + bind_function( L"negative?", &lisp_is_negative); bind_function( L"read", &lisp_read ); bind_function( L"repl", &lisp_repl ); bind_function( L"oblist", &lisp_oblist ); From bf72ae379d180b4fb773bb48920e4628e55be895 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 22 Jan 2019 09:48:26 +0000 Subject: [PATCH 31/40] Getting closer. WARNING: GC disabled in this commit. --- src/arith/integer.c | 58 ++++++++---------------------------- src/arith/integer.h | 2 -- src/arith/peano.c | 19 +++++------- src/arith/peano.h | 5 ++++ src/memory/consspaceobject.c | 2 +- src/ops/equal.c | 6 ++-- 6 files changed, 30 insertions(+), 62 deletions(-) diff --git a/src/arith/integer.c b/src/arith/integer.c index 9e1a8a0..543bf0d 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -31,11 +31,6 @@ #include "lispops.h" #include "peano.h" -/* - * The maximum value we will allow in an integer cell. - */ -#define MAX_INTEGER ((__int128_t)0x0fffffffffffffffL) - /** * hexadecimal digits for printing numbers. */ @@ -46,36 +41,6 @@ const char *hex_digits = "0123456789ABCDEF"; * that integers less than 65 bits are bignums of one cell only. */ -/** - * return the numeric value of the cell indicated by this `pointer`, as a C - * primitive double, not as a cons_space_object. The indicated cell may in - * principle be any kind of number; if it is not a number, will return `NAN`. - */ -long double numeric_value( struct cons_pointer pointer ) { - long double result = NAN; - struct cons_space_object *cell = &pointer2cell( pointer ); - - switch ( cell->tag.value ) { - case INTEGERTV: - result = 1.0; - while ( cell->tag.value == INTEGERTV ) { - result = ( result * LONG_MAX * cell->payload.integer.value ); - cell = &pointer2cell( cell->payload.integer.more ); - } - break; - case RATIOTV: - result = numeric_value( cell->payload.ratio.dividend ) / - numeric_value( cell->payload.ratio.divisor ); - break; - case REALTV: - result = cell->payload.real.value; - break; - // default is NAN - } - - return result; -} - /** * Allocate an integer cell representing this `value` and return a cons_pointer to it. * @param value an integer value; @@ -100,13 +65,17 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { } /** - * Internal to `operate_on_integers`, do not use. + * 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: expectedto 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 operate_on_integers + * \see multiply_integers + * \see add_integers */ -__int128_t cell_value( struct cons_pointer c, bool is_first_cell ) { +__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; @@ -117,7 +86,7 @@ __int128_t cell_value( struct cons_pointer c, bool is_first_cell ) { ( val == 0 ) ? carry : val : - 0; + 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); @@ -194,8 +163,8 @@ struct cons_pointer add_integers( struct cons_pointer a, debug_println( DEBUG_ARITH ); while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { - __int128_t av = cell_value( a, is_first_cell ); - __int128_t bv = cell_value( b, is_first_cell ); + __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 ); @@ -268,10 +237,10 @@ struct cons_pointer multiply_integers( struct cons_pointer a, __int128_t carry = 0; while ( !nilp(d) || carry != 0) { - struct cons_pointer old_partial = partial; + partial = make_integer(0, partial); struct cons_pointer new = make_integer( 0, NIL); - __int128_t dv = cell_value( d, is_first_d ); - __int128_t bv = cell_value( b, is_first_b ); + __int128_t dv = cell_value( d, '*', is_first_d ); + __int128_t bv = cell_value( b, '*', is_first_b ); __int128_t rv = (dv * bv) + carry; @@ -304,7 +273,6 @@ struct cons_pointer multiply_integers( struct cons_pointer a, //dec_ref(new); } - //dec_ref(old_partial); d = integerp(d) ? pointer2cell( d ).payload.integer.more : NIL; is_first_d = false; } diff --git a/src/arith/integer.h b/src/arith/integer.h index f9eba33..117a0bf 100644 --- a/src/arith/integer.h +++ b/src/arith/integer.h @@ -11,8 +11,6 @@ #ifndef __integer_h #define __integer_h -long double numeric_value( struct cons_pointer pointer ); - struct cons_pointer make_integer( int64_t value, struct cons_pointer more ); struct cons_pointer add_integers( struct cons_pointer a, diff --git a/src/arith/peano.c b/src/arith/peano.c index 85bbd5c..addfed6 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -21,6 +21,7 @@ #include "integer.h" #include "intern.h" #include "lispops.h" +#include "peano.h" #include "print.h" #include "ratio.h" #include "read.h" @@ -119,19 +120,15 @@ long double to_long_double( struct cons_pointer arg ) { switch ( cell.tag.value ) { case INTEGERTV: - result = ( double ) cell.payload.integer.value; + result = 1.0; + while ( cell.tag.value == INTEGERTV ) { + result = ( result * (MAX_INTEGER + 1) * cell.payload.integer.value ); + cell = pointer2cell( cell.payload.integer.more ); + } break; case RATIOTV: - { - struct cons_space_object dividend = - pointer2cell( cell.payload.ratio.dividend ); - struct cons_space_object divisor = - pointer2cell( cell.payload.ratio.divisor ); - - result = - ( long double ) dividend.payload.integer.value / - divisor.payload.integer.value; - } + result = to_long_double(cell.payload.ratio.dividend) / + to_long_double(cell.payload.ratio.divisor); break; case REALTV: result = cell.payload.real.value; diff --git a/src/arith/peano.h b/src/arith/peano.h index fa03212..7164a24 100644 --- a/src/arith/peano.h +++ b/src/arith/peano.h @@ -12,6 +12,11 @@ #ifndef PEANO_H #define PEANO_H +/** + * The maximum value we will allow in an integer cell. + */ +#define MAX_INTEGER ((__int128_t)0x0fffffffffffffffL) + bool zerop( struct cons_pointer arg ); struct cons_pointer negative( struct cons_pointer frame, diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 6a7e2bd..4eefde0 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -59,7 +59,7 @@ void dec_ref( struct cons_pointer pointer ) { cell->count--; if ( cell->count == 0 ) { - free_cell( pointer ); + // free_cell( pointer ); } } } diff --git a/src/ops/equal.c b/src/ops/equal.c index 9eedd53..0c01a81 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -12,7 +12,7 @@ #include "conspage.h" #include "consspaceobject.h" -#include "integer.h" +#include "peano.h" /** * Shallow, and thus cheap, equality: true if these two objects are @@ -92,8 +92,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { break; case REALTV: { - double num_a = numeric_value( a ); - double num_b = numeric_value( b ); + 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 ); From f8c20ab3b1778606024fa86cd52067603293d07f Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 24 Jan 2019 10:12:08 +0000 Subject: [PATCH 32/40] Still broken, but I believe we're moving in the right direction. --- lisp/expt.lisp | 3 +- notes/mad-software.md | 75 ++++++++++++++++++++++++++++++++++++ src/arith/integer.c | 36 +++++++++++------ src/arith/peano.c | 32 ++++++++++----- src/memory/consspaceobject.c | 2 +- 5 files changed, 124 insertions(+), 24 deletions(-) create mode 100644 notes/mad-software.md diff --git a/lisp/expt.lisp b/lisp/expt.lisp index 7ec849e..8b32252 100644 --- a/lisp/expt.lisp +++ b/lisp/expt.lisp @@ -5,5 +5,4 @@ ((= x 1) n) (t (* n (expt n (- x 1))))))) -(inspect expt) -(expt 2 59) +(inspect (expt 2 60)) diff --git a/notes/mad-software.md b/notes/mad-software.md new file mode 100644 index 0000000..bbe8092 --- /dev/null +++ b/notes/mad-software.md @@ -0,0 +1,75 @@ +# Mad software + +I was listening to [Eric Normand's podcast](https://lispcast.com/tension-between-data-and-entity/) this morning, as I was making breakfast and tidying my room; he was talking about semantics and data. It started a train of thought which I shall try to unroll. + +I have blogged a lot in the past about madness and about software, but I don't think I've ever blogged about madness and software in the same essay. But the reasons I'm mad and the reasons I'm (sometimes) very good at software are related; both have their roots in autism and dyslexia, or, to put it differently, how my brain is wired. + +I first wrote about [post scarcity software](https://blog.journeyman.cc/2006/02/post-scarcity-software.html) thirteen years ago. It was a thought about how software environments should be designed if were weren't held back by the cruft of the past, by tradition and by a lack, frankly, of anything much in the way of new creative thought. And seeing that the core of the system I described is a Lisp, which is to say it builds on a software architecture which is exactly as old as I am, perhaps it is infected by my take on tradition and my own lack of creativity, but let's, for the purposes of this essay, assume not. + +I started actually writing the [post scarcity software environment](https://github.com/simon-brooke/post-scarcity) on the second of January 2017, which is to say two years ago. It's been an extremely low priority task, because I don't have enough faith in either my vision or my skill to think that it will ever be of use to anyone. Nevertheless, it does now actually work, in as much as you can write software in it. It's not at all easy yet, and I wouldn't recommend anyone try, but you can check out the master branch from Github, compile it, and it works. + +As my mental health has deteriorated, I have been working on it more over the past couple of months, partly because I have lost faith in my ability to deliver the more practical projects I've been working on, and partly because doing something which is genuinely intellectually hard helps subdue the chaos in my mind. + +Having said that, it is hard and I am not sharp, and so progress is slow. I started work on big number arithmetic a three weeks ago, and where I'm up to at this point is: + +* addition seems to work up to at least the second bignum boundary; +* multiplication doesn't work beyond the first bignum boundary; +* subraction doesn't work, and turns out not to be as easy as just inverting addition; +* division sort of trivially works, but only in the sense that we can create a rational number out of arbitrary bignums; +* reading works beyond the first bignum boundary, but not up to the second (because multiplication doesn't work); +* printing doesn't work beyond the first bignum boundary. + +I knew bignums were going to be a challenge, and I could have studied other people's bignum code and have consciously chosen not to do so; but this is not fast progress. + +(I should point out that in those three weeks I've also done four days of customer work, which is .Net and boring but it's done, spent two days seeing my sister, spent two days so depressed I didn't actually do anything at all, and done a bit or practical work around the croft. But still!) + +In a sense, it wasn't expected to be. Writing the underpinnings of a software environment which is conceptually without limits has challenge after challenge after challenge. + +But there are ideas in post scarcity which may have wider utility than this mad idea in itself. Layering homogeneities and regularities onto Clojure maps might - perhaps would - make a useful library, might would make a very useful component for exactly the sort of data wrangling Eric Normand was talking about. Yes, you can use a map - raw data soup - to represent a company. But if this map is a member of a homogeneity, 'Companies', then we know every member of it has employees, and that every employee has a salary and an email address. Regularities and homogeneities form the building blocks of APIs; to use the example Eric discussed in his podcast, the salary is the property of the employee, but the payroll is a property of the company. So in post scarcity, you'd get the payroll figure for a company by using a method on the 'Companies' homogeneity. How it computes that value is part of the general doctrine of **'Don't Know, Don't Care'**: the principal that people writing software at any layer in the system do not need to know, and should not need to care, about how things are implemented in the layers below them. + + + +So, the user needing to find the payroll value would enter something like this: + +``` + (with ((companies . ::shared:pool:companies) + (acme . companies:acme-widgets)) + (companies:methods:payroll acme)) +``` + +In practice, in post scarcity notation, the payroll method probably looks something like this: + +``` + (lambda (company) + (reduce + (map ::shared:pool:employees:methods:salary (:employees company)))) +``` + +There are issues that I haven't resolved yet about the mutability of regularities and homogeneities; obviously, in order to provide multi-user visibility of current values of shared data, some regularities must be mutable. But mutability has potentially very serious perfomance issues for the hypercube architecture, so I think that in general they should not be. + +However, that's detail, and not what I'm trying to talk about here. + +What I'm trying to talk about here is the fact that if I were confident that these ideas were any good, and that I had the ability to persuade others that they were any good, it would make far more sense to implement them in Clojure and promote them as a library. + +But the problem with depression is that you cannot evaluate whether your ideas are any good. The black dog tells you you're shit, and that your ideas are shit, and that you don't really know enough to be worth listening to, and that you're an old tramp who lives in a hut in the woods, and probably smells, and that in any case interaction with other people quickly makes you shaky and confused, and that you can never get your act together, and you never finish anything. + +And all that is objectively true, and I know that it is true. But I also know that I can (or at least have in the past been able to) build really good software, and that I can (or have been able, in the past, to) present ideas really well. + +These two collections of statements about me are both true at the same time. But the difference is that I believe the first and I don't believe the second. + +And behind all this is the fact that bignum arithmetic is a solved problem. I could dig out the SBCL source code and crib from that. I am bashing my head against bignum arithmetic and trying to solve it myself, not because it's the most efficient way to produce good code quickly, but because what I'm really trying to do is just distract myself and waste time while I can get on with dying. + +And the reason beyond that that I'm working on a software system I know I'll never finish, which is designed to run on computers which don't even exist yet - and although I'm very confident that enormously parallel hardware will be used in future, I'm not at all sure it will look anything like what I'm envisaging - the reason I'm building this mad software is that, because it will never be finished, no-one will ever use it except me, and no-one will say how crap it is and how easily it could have been done better. + +Because the other thing that I'm doing in writing this stuff, apart from distracting from the swirling chaos and rage in my head, apart from waiting to die, the other thing I'm doing is trying to give myself a feeling of mastery, of competence, of ability to face problems and solve them. And, to an extent, it works. But I have so little confidence that I actually have that mastery, that competence, that I don't want to expose it to criticism. I don't want my few fragile rags of self worth stripped away. + +And so I work, and work, and work at something which is so arcane, so obscure, so damned pointless that no-one will ever use it. + +Not because I'm even enjoying it, but just to burn the time. + +This is mad. + +I am mad. + +I hate, hate, hate being mad. + +Postscript: just writing this essay has made me tearful, headachey, sick, shaky. It's very hard to face up to the irrationalities and self-deceptions in one's own behaviour. diff --git a/src/arith/integer.c b/src/arith/integer.c index 543bf0d..6a26126 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -137,6 +137,23 @@ __int128_t int128_to_integer( __int128_t val, return carry; } +struct cons_pointer make_integer_128(__int128_t val, + struct cons_pointer less_significant) { + struct cons_pointer result = NIL; + + do { + if ( MAX_INTEGER >= val ) { + result = make_integer( (long int) val, less_significant); + } else { + less_significant = make_integer( (long int)val & MAX_INTEGER, less_significant); + val = val >> 60; + } + + } while (nilp(result)); + + return result; +} + /** * 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. @@ -221,7 +238,7 @@ struct cons_pointer multiply_integers( struct cons_pointer a, struct cons_pointer result = NIL; bool neg = is_negative(a) != is_negative(b); bool is_first_b = true; - int oom = 0; + int oom = -1; debug_print( L"multiply_integers: a = ", DEBUG_ARITH ); debug_print_object(a, DEBUG_ARITH); @@ -233,14 +250,14 @@ struct cons_pointer multiply_integers( struct cons_pointer a, while ( !nilp( b ) ) { bool is_first_d = true; struct cons_pointer d = a; - struct cons_pointer partial = base_partial(oom++); + struct cons_pointer partial = base_partial(++oom); __int128_t carry = 0; while ( !nilp(d) || carry != 0) { partial = make_integer(0, partial); - struct cons_pointer new = make_integer( 0, NIL); - __int128_t dv = cell_value( d, '*', is_first_d ); - __int128_t bv = cell_value( b, '*', is_first_b ); + struct cons_pointer new = NIL; + __int128_t dv = cell_value( d, '+', is_first_d ); + __int128_t bv = cell_value( b, '+', is_first_b ); __int128_t rv = (dv * bv) + carry; @@ -260,17 +277,12 @@ struct cons_pointer multiply_integers( struct cons_pointer a, debug_print_object( partial, DEBUG_ARITH); debug_print( L"\n", DEBUG_ARITH ); - inc_ref(new); - carry = int128_to_integer(rv, NIL, new); + new = make_integer_128(rv, base_partial(oom)); - if (nilp(d) && carry != 0) debug_print(L"THIS SHOULD NEVER HAPPEN!\n", DEBUG_ARITH); - - if (nilp(partial) || zerop(partial)) { + if ( zerop(partial)) { partial = new; } else { partial = add_integers(partial, new); - inc_ref(partial); - //dec_ref(new); } d = integerp(d) ? pointer2cell( d ).payload.integer.more : NIL; diff --git a/src/arith/peano.c b/src/arith/peano.c index addfed6..7db638a 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -43,9 +43,14 @@ bool zerop( struct cons_pointer arg ) { struct cons_space_object cell = pointer2cell( arg ); switch ( cell.tag.value ) { - case INTEGERTV: - result = cell.payload.integer.value == 0 && - nilp( cell.payload.integer.more ); + 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 ); @@ -115,16 +120,25 @@ struct cons_pointer absolute( struct cons_pointer frame_pointer, struct cons_poi * not a number is passed in. */ long double to_long_double( struct cons_pointer arg ) { - long double result = 0; /* not a number, as a long double */ + long double result = 0; struct cons_space_object cell = pointer2cell( arg ); switch ( cell.tag.value ) { case INTEGERTV: - result = 1.0; - while ( cell.tag.value == INTEGERTV ) { - result = ( result * (MAX_INTEGER + 1) * cell.payload.integer.value ); - cell = pointer2cell( cell.payload.integer.more ); - } + // 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) / diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 4eefde0..6a7e2bd 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -59,7 +59,7 @@ void dec_ref( struct cons_pointer pointer ) { cell->count--; if ( cell->count == 0 ) { - // free_cell( pointer ); + free_cell( pointer ); } } } From a355a28ffa1f8789b13ca43ee4c62fe19a04ee2a Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 24 Jan 2019 18:59:01 +0000 Subject: [PATCH 33/40] Tactical commit whilst converting to URL_FILE --- .gitignore | 2 + Makefile | 2 +- src/arith/integer.c | 10 +- src/init.c | 15 +- src/io/fopen.c | 543 +++++++++++++++++++++++++++++++++++ src/io/fopen.h | 72 +++++ src/memory/conspage.c | 2 +- src/memory/conspage.h | 2 +- src/memory/consspaceobject.c | 6 +- src/memory/consspaceobject.h | 9 +- src/memory/dump.c | 8 +- src/memory/dump.h | 2 +- src/memory/stack.c | 4 +- src/memory/stack.h | 4 +- src/ops/io.c | 8 + src/ops/lispops.c | 8 +- src/ops/print.c | 12 +- src/ops/print.h | 4 +- src/ops/read.c | 23 +- src/ops/read.h | 2 +- unit-tests/bignum-print.sh | 38 +-- unit-tests/string-cons.sh | 0 unit-tests/wide-character.sh | 12 + 23 files changed, 700 insertions(+), 88 deletions(-) create mode 100644 src/io/fopen.c create mode 100644 src/io/fopen.h create mode 100644 src/ops/io.c mode change 100644 => 100755 unit-tests/string-cons.sh create mode 100755 unit-tests/wide-character.sh diff --git a/.gitignore b/.gitignore index b428e03..6fa1cd9 100644 --- a/.gitignore +++ b/.gitignore @@ -32,3 +32,5 @@ log* utils_src/readprintwc/out *.dump + +*.bak diff --git a/Makefile b/Makefile index 7179c91..c4c4ef3 100644 --- a/Makefile +++ b/Makefile @@ -16,7 +16,7 @@ INDENT_FLAGS := -nbad -bap -nbc -br -brf -brs -c33 -cd33 -ncdb -ce -ci4 -cli4 \ -npsl -nsc -nsob -nss -nut -prs -l79 -ts2 CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g -DDEBUG -LDFLAGS := -lm +LDFLAGS := -lm -lcurl all: $(TARGET) diff --git a/src/arith/integer.c b/src/arith/integer.c index 6a26126..679bf37 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -314,7 +314,6 @@ struct cons_pointer multiply_integers( struct cons_pointer a, */ struct cons_pointer integer_to_string_add_digit( int digit, int digits, struct cons_pointer tail ) { - digits++; wint_t character = btowc( hex_digits[digit] ); return ( digits % 3 == 0 ) ? make_string( L',', make_string( character, @@ -352,10 +351,7 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, while ( accumulator > 0 || !nilp( integer.payload.integer.more ) ) { if ( !nilp( integer.payload.integer.more ) ) { integer = pointer2cell( integer.payload.integer.more ); - accumulator += integer.payload.integer.value == 0 ? - MAX_INTEGER : - ( llabs( integer.payload.integer.value ) * - ( MAX_INTEGER + 1 ) ); + accumulator += integer.payload.integer.value; debug_print ( L"integer_to_string: crossing cell boundary, accumulator is: ", DEBUG_IO ); @@ -369,10 +365,12 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, 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 ); + integer_to_string_add_digit( offset, ++digits, result ); accumulator = accumulator / base; } while ( accumulator > base ); } diff --git a/src/init.c b/src/init.c index e0d2b01..e8a33a9 100644 --- a/src/init.c +++ b/src/init.c @@ -9,6 +9,7 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#include #include #include #include @@ -81,6 +82,8 @@ int main( int argc, char *argv[] ) { bool dump_at_end = false; bool show_prompt = false; + setlocale(LC_ALL, ""); + while ( ( option = getopt( argc, argv, "cpdv:" ) ) != -1 ) { switch ( option ) { case 'c': @@ -123,14 +126,14 @@ int main( int argc, char *argv[] ) { * standard input, output, error and sink streams * attempt to set wide character acceptance on all streams */ - FILE *sink = fopen( "/dev/null", "w" ); + URL_FILE *sink = url_fopen( "/dev/null", "w" ); fwide( stdin, 1 ); fwide( stdout, 1 ); fwide( stderr, 1 ); fwide( sink, 1 ); - bind_value( L"*in*", make_read_stream( stdin ) ); - bind_value( L"*out*", make_write_stream( stdout ) ); - bind_value( L"*log*", make_write_stream( stderr ) ); + bind_value( L"*in*", make_read_stream( file_to_url_file(stdin) ) ); + bind_value( L"*out*", make_write_stream( file_to_url_file(stdout) ) ); + bind_value( L"*log*", make_write_stream( file_to_url_file(stderr) ) ); bind_value( L"*sink*", make_write_stream( sink ) ); /* @@ -180,9 +183,9 @@ int main( int argc, char *argv[] ) { */ bind_special( L"cond", &lisp_cond ); bind_special( L"lambda", &lisp_lambda ); - // bind_special( L"λ", &lisp_lambda ); + bind_special( L"\u03bb", &lisp_lambda ); // λ bind_special( L"nlambda", &lisp_nlambda ); - // bind_special( L"nλ", &lisp_nlambda ); + bind_special( L"n\u03bb", &lisp_nlambda ); bind_special( L"progn", &lisp_progn ); bind_special( L"quote", &lisp_quote ); bind_special( L"set!", &lisp_set_shriek ); diff --git a/src/io/fopen.c b/src/io/fopen.c new file mode 100644 index 0000000..d13250f --- /dev/null +++ b/src/io/fopen.c @@ -0,0 +1,543 @@ +/* + * fopen.c + * + * adapted from https://curl.haxx.se/libcurl/c/fopen.html. + * + * Copyright (c) 2003, 2017 Simtec Electronics + * Some portions (c) 2017 Simon Brooke + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. The name of the author may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES + * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. + * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT + * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF + * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + * This example requires libcurl 7.9.7 or later. + */ + + +#include +#include +#ifndef WIN32 +# include +#endif +#include +#include + +#include +/* + * wide characters + */ +#include +#include + +#include "fopen.h" + +/* we use a global one for convenience */ +static CURLM *multi_handle; + +/* curl calls this routine to get more data */ +static size_t write_callback(char *buffer, + size_t size, + size_t nitems, + void *userp) +{ + char *newbuff; + size_t rembuff; + + URL_FILE *url = (URL_FILE *)userp; + size *= nitems; + + rembuff = url->buffer_len - url->buffer_pos; /* remaining space in buffer */ + + if(size > rembuff) { + /* not enough space in buffer */ + newbuff = realloc(url->buffer, url->buffer_len + (size - rembuff)); + if(newbuff == NULL) { + fprintf(stderr, "callback buffer grow failed\n"); + size = rembuff; + } + else { + /* realloc succeeded increase buffer size*/ + url->buffer_len += size - rembuff; + url->buffer = newbuff; + } + } + + memcpy(&url->buffer[url->buffer_pos], buffer, size); + url->buffer_pos += size; + + return size; +} + +/* use to attempt to fill the read buffer up to requested number of bytes */ +static int fill_buffer(URL_FILE *file, size_t want) +{ + fd_set fdread; + fd_set fdwrite; + fd_set fdexcep; + struct timeval timeout; + int rc; + CURLMcode mc; /* curl_multi_fdset() return code */ + + /* only attempt to fill buffer if transactions still running and buffer + * doesn't exceed required size already + */ + if((!file->still_running) || (file->buffer_pos > want)) + return 0; + + /* attempt to fill buffer */ + do { + int maxfd = -1; + long curl_timeo = -1; + + FD_ZERO(&fdread); + FD_ZERO(&fdwrite); + FD_ZERO(&fdexcep); + + /* set a suitable timeout to fail on */ + timeout.tv_sec = 60; /* 1 minute */ + timeout.tv_usec = 0; + + curl_multi_timeout(multi_handle, &curl_timeo); + if(curl_timeo >= 0) { + timeout.tv_sec = curl_timeo / 1000; + if(timeout.tv_sec > 1) + timeout.tv_sec = 1; + else + timeout.tv_usec = (curl_timeo % 1000) * 1000; + } + + /* get file descriptors from the transfers */ + mc = curl_multi_fdset(multi_handle, &fdread, &fdwrite, &fdexcep, &maxfd); + + if(mc != CURLM_OK) { + fprintf(stderr, "curl_multi_fdset() failed, code %d.\n", mc); + break; + } + + /* On success the value of maxfd is guaranteed to be >= -1. We call + select(maxfd + 1, ...); specially in case of (maxfd == -1) there are + no fds ready yet so we call select(0, ...) --or Sleep() on Windows-- + to sleep 100ms, which is the minimum suggested value in the + curl_multi_fdset() doc. */ + + if(maxfd == -1) { +#ifdef _WIN32 + Sleep(100); + rc = 0; +#else + /* Portable sleep for platforms other than Windows. */ + struct timeval wait = { 0, 100 * 1000 }; /* 100ms */ + rc = select(0, NULL, NULL, NULL, &wait); +#endif + } + else { + /* Note that on some platforms 'timeout' may be modified by select(). + If you need access to the original value save a copy beforehand. */ + rc = select(maxfd + 1, &fdread, &fdwrite, &fdexcep, &timeout); + } + + switch(rc) { + case -1: + /* select error */ + break; + + case 0: + default: + /* timeout or readable/writable sockets */ + curl_multi_perform(multi_handle, &file->still_running); + break; + } + } while(file->still_running && (file->buffer_pos < want)); + return 1; +} + +/* use to remove want bytes from the front of a files buffer */ +static int use_buffer(URL_FILE *file, size_t want) +{ + /* sort out buffer */ + if((file->buffer_pos - want) <= 0) { + /* ditch buffer - write will recreate */ + free(file->buffer); + file->buffer = NULL; + file->buffer_pos = 0; + file->buffer_len = 0; + } + else { + /* move rest down make it available for later */ + memmove(file->buffer, + &file->buffer[want], + (file->buffer_pos - want)); + + file->buffer_pos -= want; + } + return 0; +} + +URL_FILE *url_fopen(const char *url, const char *operation) +{ + /* this code could check for URLs or types in the 'url' and + basically use the real fopen() for standard files */ + + URL_FILE *file; + (void)operation; + + file = calloc(1, sizeof(URL_FILE)); + if(!file) + return NULL; + + file->handle.file = fopen(url, operation); + if(file->handle.file) + file->type = CFTYPE_FILE; /* marked as URL */ + + else { + file->type = CFTYPE_CURL; /* marked as URL */ + file->handle.curl = curl_easy_init(); + + curl_easy_setopt(file->handle.curl, CURLOPT_URL, url); + curl_easy_setopt(file->handle.curl, CURLOPT_WRITEDATA, file); + curl_easy_setopt(file->handle.curl, CURLOPT_VERBOSE, 0L); + curl_easy_setopt(file->handle.curl, CURLOPT_WRITEFUNCTION, write_callback); + + if(!multi_handle) + multi_handle = curl_multi_init(); + + curl_multi_add_handle(multi_handle, file->handle.curl); + + /* lets start the fetch */ + curl_multi_perform(multi_handle, &file->still_running); + + if((file->buffer_pos == 0) && (!file->still_running)) { + /* if still_running is 0 now, we should return NULL */ + + /* make sure the easy handle is not in the multi handle anymore */ + curl_multi_remove_handle(multi_handle, file->handle.curl); + + /* cleanup */ + curl_easy_cleanup(file->handle.curl); + + free(file); + + file = NULL; + } + } + return file; +} + +int url_fclose(URL_FILE *file) +{ + int ret = 0;/* default is good return */ + + switch(file->type) { + case CFTYPE_FILE: + ret = fclose(file->handle.file); /* passthrough */ + break; + + case CFTYPE_CURL: + /* make sure the easy handle is not in the multi handle anymore */ + curl_multi_remove_handle(multi_handle, file->handle.curl); + + /* cleanup */ + curl_easy_cleanup(file->handle.curl); + break; + + default: /* unknown or supported type - oh dear */ + ret = EOF; + errno = EBADF; + break; + } + + free(file->buffer);/* free any allocated buffer space */ + free(file); + + return ret; +} + +int url_feof(URL_FILE *file) +{ + int ret = 0; + + switch(file->type) { + case CFTYPE_FILE: + ret = feof(file->handle.file); + break; + + case CFTYPE_CURL: + if((file->buffer_pos == 0) && (!file->still_running)) + ret = 1; + break; + + default: /* unknown or supported type - oh dear */ + ret = -1; + errno = EBADF; + break; + } + return ret; +} + +size_t url_fread(void *ptr, size_t size, size_t nmemb, URL_FILE *file) +{ + size_t want; + + switch(file->type) { + case CFTYPE_FILE: + want = fread(ptr, size, nmemb, file->handle.file); + break; + + case CFTYPE_CURL: + want = nmemb * size; + + fill_buffer(file, want); + + /* check if there's data in the buffer - if not fill_buffer() + * either errored or EOF */ + if(!file->buffer_pos) + return 0; + + /* ensure only available data is considered */ + if(file->buffer_pos < want) + want = file->buffer_pos; + + /* xfer data to caller */ + memcpy(ptr, file->buffer, want); + + use_buffer(file, want); + + want = want / size; /* number of items */ + break; + + default: /* unknown or supported type - oh dear */ + want = 0; + errno = EBADF; + break; + + } + return want; +} + +char *url_fgets(char *ptr, size_t size, URL_FILE *file) +{ + size_t want = size - 1;/* always need to leave room for zero termination */ + size_t loop; + + switch(file->type) { + case CFTYPE_FILE: + ptr = fgets(ptr, (int)size, file->handle.file); + break; + + case CFTYPE_CURL: + fill_buffer(file, want); + + /* check if there's data in the buffer - if not fill either errored or + * EOF */ + if(!file->buffer_pos) + return NULL; + + /* ensure only available data is considered */ + if(file->buffer_pos < want) + want = file->buffer_pos; + + /*buffer contains data */ + /* look for newline or eof */ + for(loop = 0; loop < want; loop++) { + if(file->buffer[loop] == '\n') { + want = loop + 1;/* include newline */ + break; + } + } + + /* xfer data to caller */ + memcpy(ptr, file->buffer, want); + ptr[want] = 0;/* always null terminate */ + + use_buffer(file, want); + + break; + + default: /* unknown or supported type - oh dear */ + ptr = NULL; + errno = EBADF; + break; + } + + return ptr;/*success */ +} + +void url_rewind(URL_FILE *file) +{ + switch(file->type) { + case CFTYPE_FILE: + rewind(file->handle.file); /* passthrough */ + break; + + case CFTYPE_CURL: + /* halt transaction */ + curl_multi_remove_handle(multi_handle, file->handle.curl); + + /* restart */ + curl_multi_add_handle(multi_handle, file->handle.curl); + + /* ditch buffer - write will recreate - resets stream pos*/ + free(file->buffer); + file->buffer = NULL; + file->buffer_pos = 0; + file->buffer_len = 0; + + break; + + default: /* unknown or supported type - oh dear */ + break; + } +} + +/** + * given this file handle f, return a new url_file handle wrapping it. + * + * @param f the file to be wrapped; + * @return the new handle, or null if no such handle could be allocated. + */ +URL_FILE * file_to_url_file( FILE* f) { + URL_FILE * result = (URL_FILE *)malloc(sizeof(URL_FILE)); + + if ( result != NULL) { + result->type = CFTYPE_FILE, + result->handle.file = f; + } + + return result; +} + + +wint_t url_fgetwc(URL_FILE *file) { + wint_t result = 0; + + switch(file->type) { + case CFTYPE_FILE: + fwide( file->handle.file, 1 ); /* wide characters */ + result = fgetc(file->handle.file); /* passthrough */ + break; + + case CFTYPE_CURL: + url_fread(&result, sizeof(wint_t), 1, file); + break; + } + + return result; +} + +/* #define FGETSFILE "fgets.test" */ +/* #define FREADFILE "fread.test" */ +/* #define REWINDFILE "rewind.test" */ + +/* /\* Small main program to retrieve from a url using fgets and fread saving the */ +/* * output to two test files (note the fgets method will corrupt binary files if */ +/* * they contain 0 chars *\/ */ +/* int main(int argc, char *argv[]) */ +/* { */ +/* URL_FILE *handle; */ +/* FILE *outf; */ + +/* size_t nread; */ +/* char buffer[256]; */ +/* const char *url; */ + +/* if(argc < 2) */ +/* url = "http://192.168.7.3/testfile";/\* default to testurl *\/ */ +/* else */ +/* url = argv[1];/\* use passed url *\/ */ + +/* /\* copy from url line by line with fgets *\/ */ +/* outf = fopen(FGETSFILE, "wb+"); */ +/* if(!outf) { */ +/* perror("couldn't open fgets output file\n"); */ +/* return 1; */ +/* } */ + +/* handle = url_fopen(url, "r"); */ +/* if(!handle) { */ +/* printf("couldn't url_fopen() %s\n", url); */ +/* fclose(outf); */ +/* return 2; */ +/* } */ + +/* while(!url_feof(handle)) { */ +/* url_fgets(buffer, sizeof(buffer), handle); */ +/* fwrite(buffer, 1, strlen(buffer), outf); */ +/* } */ + +/* url_fclose(handle); */ + +/* fclose(outf); */ + + +/* /\* Copy from url with fread *\/ */ +/* outf = fopen(FREADFILE, "wb+"); */ +/* if(!outf) { */ +/* perror("couldn't open fread output file\n"); */ +/* return 1; */ +/* } */ + +/* handle = url_fopen("testfile", "r"); */ +/* if(!handle) { */ +/* printf("couldn't url_fopen() testfile\n"); */ +/* fclose(outf); */ +/* return 2; */ +/* } */ + +/* do { */ +/* nread = url_fread(buffer, 1, sizeof(buffer), handle); */ +/* fwrite(buffer, 1, nread, outf); */ +/* } while(nread); */ + +/* url_fclose(handle); */ + +/* fclose(outf); */ + + +/* /\* Test rewind *\/ */ +/* outf = fopen(REWINDFILE, "wb+"); */ +/* if(!outf) { */ +/* perror("couldn't open fread output file\n"); */ +/* return 1; */ +/* } */ + +/* handle = url_fopen("testfile", "r"); */ +/* if(!handle) { */ +/* printf("couldn't url_fopen() testfile\n"); */ +/* fclose(outf); */ +/* return 2; */ +/* } */ + +/* nread = url_fread(buffer, 1, sizeof(buffer), handle); */ +/* fwrite(buffer, 1, nread, outf); */ +/* url_rewind(handle); */ + +/* buffer[0]='\n'; */ +/* fwrite(buffer, 1, 1, outf); */ + +/* nread = url_fread(buffer, 1, sizeof(buffer), handle); */ +/* fwrite(buffer, 1, nread, outf); */ + +/* url_fclose(handle); */ + +/* fclose(outf); */ + +/* return 0;/\* all done *\/ */ +/* } */ diff --git a/src/io/fopen.h b/src/io/fopen.h new file mode 100644 index 0000000..9874ac7 --- /dev/null +++ b/src/io/fopen.h @@ -0,0 +1,72 @@ +/* + * fopen.h + * + * adapted from https://curl.haxx.se/libcurl/c/fopen.html. + * + * Copyright (c) 2003, 2017 Simtec Electronics + * Some portions (c) 2017 Simon Brooke + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. The name of the author may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES + * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. + * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT + * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF + * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + * This example requires libcurl 7.9.7 or later. + */ + +#ifndef __fopen_h +#define __fopen_h + +enum fcurl_type_e { + CFTYPE_NONE = 0, + CFTYPE_FILE = 1, + CFTYPE_CURL = 2 +}; + +struct fcurl_data +{ + enum fcurl_type_e type; /* type of handle */ + union { + CURL *curl; + FILE *file; + } handle; /* handle */ + + char *buffer; /* buffer to store cached data*/ + size_t buffer_len; /* currently allocated buffers length */ + size_t buffer_pos; /* end of data in buffer*/ + int still_running; /* Is background url fetch still in progress */ +}; + +typedef struct fcurl_data URL_FILE; + +/* exported functions */ +URL_FILE *url_fopen(const char *url, const char *operation); +int url_fclose(URL_FILE *file); +int url_feof(URL_FILE *file); +size_t url_fread(void *ptr, size_t size, size_t nmemb, URL_FILE *file); +char *url_fgets(char *ptr, size_t size, URL_FILE *file); +void url_rewind(URL_FILE *file); + +wint_t url_fgetwc(URL_FILE *file); +URL_FILE * file_to_url_file( FILE* f); + + + +#endif diff --git a/src/memory/conspage.c b/src/memory/conspage.c index f3c1760..03034e4 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -115,7 +115,7 @@ void make_cons_page( ) { /** * dump the allocated pages to this `output` stream. */ -void dump_pages( FILE * output ) { +void dump_pages( URL_FILE * output ) { for ( int i = 0; i < initialised_cons_pages; i++ ) { fwprintf( output, L"\nDUMPING PAGE %d\n", i ); diff --git a/src/memory/conspage.h b/src/memory/conspage.h index ab04d6d..fa11da9 100644 --- a/src/memory/conspage.h +++ b/src/memory/conspage.h @@ -47,6 +47,6 @@ struct cons_pointer allocate_cell( char *tag ); void initialise_cons_pages( ); -void dump_pages( FILE * output ); +void dump_pages( URL_FILE * output ); #endif diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 6a7e2bd..9edbf66 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -95,8 +95,6 @@ struct cons_pointer make_exception( struct cons_pointer message, struct cons_pointer pointer = allocate_cell( EXCEPTIONTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); -// inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */ - inc_ref( message ); inc_ref( frame_pointer ); cell->payload.exception.message = message; @@ -235,7 +233,7 @@ make_special( struct cons_pointer src, struct cons_pointer ( *executable ) * Construct a cell which points to a stream open for reading. * @param input the C stream to wrap. */ -struct cons_pointer make_read_stream( FILE * input ) { +struct cons_pointer make_read_stream( URL_FILE * input ) { struct cons_pointer pointer = allocate_cell( READTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); @@ -248,7 +246,7 @@ struct cons_pointer make_read_stream( FILE * input ) { * Construct a cell which points to a stream open for writing. * @param output the C stream to wrap. */ -struct cons_pointer make_write_stream( FILE * output ) { +struct cons_pointer make_write_stream( URL_FILE * output ) { struct cons_pointer pointer = allocate_cell( WRITETAG ); struct cons_space_object *cell = &pointer2cell( pointer ); diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index acc36df..8db8099 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -16,6 +16,9 @@ */ #include #include +#include + +#include "fopen.h" #ifndef __consspaceobject_h #define __consspaceobject_h @@ -488,7 +491,7 @@ struct special_payload { */ struct stream_payload { /** the stream to read from or write to. */ - FILE *stream; + URL_FILE *stream; }; /** @@ -636,9 +639,9 @@ struct cons_pointer make_string( wint_t c, struct cons_pointer tail ); struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ); -struct cons_pointer make_read_stream( FILE * input ); +struct cons_pointer make_read_stream( URL_FILE * input ); -struct cons_pointer make_write_stream( FILE * output ); +struct cons_pointer make_write_stream( URL_FILE * output ); struct cons_pointer c_string_to_lisp_string( wchar_t *string ); diff --git a/src/memory/dump.c b/src/memory/dump.c index 7ec2631..cec0dfd 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -26,7 +26,7 @@ #include "vectorspace.h" -void dump_string_cell( FILE * output, wchar_t *prefix, +void dump_string_cell( URL_FILE * output, wchar_t *prefix, struct cons_pointer pointer ) { struct cons_space_object cell = pointer2cell( pointer ); if ( cell.payload.string.character == 0 ) { @@ -52,7 +52,7 @@ void dump_string_cell( FILE * output, wchar_t *prefix, /** * dump the object at this cons_pointer to this output stream. */ -void dump_object( FILE * output, struct cons_pointer pointer ) { +void dump_object( URL_FILE * output, struct cons_pointer pointer ) { struct cons_space_object cell = pointer2cell( pointer ); fwprintf( output, L"\t%4.4s (%d) at page %d, offset %d count %u\n", @@ -89,7 +89,7 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { } break; case LAMBDATV: - fwprintf( output, L"\t\tLambda cell;\n\t\t args: " ); + fwprintf( output, L"\t\t\u03bb cell;\n\t\t args: " ); print( output, cell.payload.lambda.args ); fwprintf( output, L";\n\t\t\tbody: " ); print( output, cell.payload.lambda.body ); @@ -98,7 +98,7 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { case NILTV: break; case NLAMBDATV: - fwprintf( output, L"\t\tNlambda cell; \n\t\targs: " ); + fwprintf( output, L"\t\tn\u03bb cell; \n\t\targs: " ); print( output, cell.payload.lambda.args ); fwprintf( output, L";\n\t\t\tbody: " ); print( output, cell.payload.lambda.body ); diff --git a/src/memory/dump.h b/src/memory/dump.h index ec8928e..f8ef75f 100644 --- a/src/memory/dump.h +++ b/src/memory/dump.h @@ -20,6 +20,6 @@ #define __dump_h -void dump_object( FILE * output, struct cons_pointer pointer ); +void dump_object( URL_FILE * output, struct cons_pointer pointer ); #endif diff --git a/src/memory/stack.c b/src/memory/stack.c index cf68701..b2585c7 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -241,7 +241,7 @@ void free_stack_frame( struct stack_frame *frame ) { * @param output the stream * @param frame_pointer the pointer to the frame */ -void dump_frame( FILE * output, struct cons_pointer frame_pointer ) { +void dump_frame( URL_FILE * output, struct cons_pointer frame_pointer ) { struct stack_frame *frame = get_stack_frame( frame_pointer ); if ( frame != NULL ) { @@ -265,7 +265,7 @@ void dump_frame( FILE * output, struct cons_pointer frame_pointer ) { } } -void dump_stack_trace( FILE * output, struct cons_pointer pointer ) { +void dump_stack_trace( URL_FILE * output, struct cons_pointer pointer ) { if ( exceptionp( pointer ) ) { print( output, pointer2cell( pointer ).payload.exception.message ); fputws( L"\n", output ); diff --git a/src/memory/stack.h b/src/memory/stack.h index 11763b2..0ea903c 100644 --- a/src/memory/stack.h +++ b/src/memory/stack.h @@ -47,9 +47,9 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous, void free_stack_frame( struct stack_frame *frame ); -void dump_frame( FILE * output, struct cons_pointer pointer ); +void dump_frame( URL_FILE * output, struct cons_pointer pointer ); -void dump_stack_trace( FILE * output, struct cons_pointer frame_pointer ); +void dump_stack_trace( URL_FILE * output, struct cons_pointer frame_pointer ); struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int n ); diff --git a/src/ops/io.c b/src/ops/io.c new file mode 100644 index 0000000..ccd0af5 --- /dev/null +++ b/src/ops/io.c @@ -0,0 +1,8 @@ +/* + * io.c + * + * Communication between PSSE and the outside world, via libcurl. + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ diff --git a/src/ops/lispops.c b/src/ops/lispops.c index c80d965..9448c55 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -839,7 +839,7 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, #ifdef DEBUG debug_print( L"entering lisp_read\n", DEBUG_IO ); #endif - FILE *input = stdin; + URL_FILE *input = stdin; struct cons_pointer in_stream = readp( frame->arg[0] ) ? frame->arg[0] : get_default_stream( true, env ); @@ -922,7 +922,7 @@ lisp_print( 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 = NIL; - FILE *output = stdout; + URL_FILE *output = stdout; struct cons_pointer out_stream = writep( frame->arg[1] ) ? frame->arg[1] : get_default_stream( false, env ); @@ -1148,7 +1148,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, struct cons_pointer input = get_default_stream( true, env ); struct cons_pointer output = get_default_stream( false, env ); - FILE *os = pointer2cell( output ).payload.stream.stream; + URL_FILE *os = pointer2cell( output ).payload.stream.stream; struct cons_pointer prompt_name = c_string_to_lisp_symbol( L"*prompt*" ); struct cons_pointer old_oblist = oblist; struct cons_pointer new_env = env; @@ -1282,7 +1282,7 @@ 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 ); - FILE *output = stdout; + URL_FILE *output = stdout; struct cons_pointer out_stream = writep( frame->arg[1] ) ? frame->arg[1] : get_default_stream( false, env ); diff --git a/src/ops/print.c b/src/ops/print.c index 604c07c..d313960 100644 --- a/src/ops/print.c +++ b/src/ops/print.c @@ -34,7 +34,7 @@ int print_use_colours = 0; * onto this `output`; if `pointer` does not indicate a string or symbol, * don't print anything but just return. */ -void print_string_contents( FILE * output, struct cons_pointer pointer ) { +void print_string_contents( URL_FILE * output, struct cons_pointer pointer ) { while ( stringp( pointer ) || symbolp( pointer ) ) { struct cons_space_object *cell = &pointer2cell( pointer ); wchar_t c = cell->payload.string.character; @@ -51,7 +51,7 @@ void print_string_contents( FILE * output, struct cons_pointer pointer ) { * the stream at this `output`, prepending and appending double quote * characters. */ -void print_string( FILE * output, struct cons_pointer pointer ) { +void print_string( URL_FILE * output, struct cons_pointer pointer ) { fputwc( btowc( '"' ), output ); print_string_contents( output, pointer ); fputwc( btowc( '"' ), output ); @@ -63,7 +63,7 @@ void print_string( FILE * output, struct cons_pointer pointer ) { * a space character. */ void -print_list_contents( FILE * output, struct cons_pointer pointer, +print_list_contents( URL_FILE * output, struct cons_pointer pointer, bool initial_space ) { struct cons_space_object *cell = &pointer2cell( pointer ); @@ -84,7 +84,7 @@ print_list_contents( FILE * output, struct cons_pointer pointer, } } -void print_list( FILE * output, struct cons_pointer pointer ) { +void print_list( URL_FILE * output, struct cons_pointer pointer ) { if ( print_use_colours ) { fwprintf( output, L"%s(%s", "\x1B[31m", "\x1B[39m" ); } else { @@ -104,7 +104,7 @@ void print_list( FILE * output, struct cons_pointer pointer ) { * Print the cons-space object indicated by `pointer` to the stream indicated * by `output`. */ -struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { +struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { struct cons_space_object cell = pointer2cell( pointer ); char *buffer; @@ -225,6 +225,6 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { return pointer; } -void println( FILE * output ) { +void println( URL_FILE * output ) { fputws( L"\n", output ); } diff --git a/src/ops/print.h b/src/ops/print.h index 2751032..f59f090 100644 --- a/src/ops/print.h +++ b/src/ops/print.h @@ -14,8 +14,8 @@ #ifndef __print_h #define __print_h -struct cons_pointer print( FILE * output, struct cons_pointer pointer ); -void println( FILE * output ); +struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ); +void println( URL_FILE * output ); extern int print_use_colours; #endif diff --git a/src/ops/read.c b/src/ops/read.c index 4006c99..d2f79c4 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -38,13 +38,13 @@ struct cons_pointer read_number( struct stack_frame *frame, struct cons_pointer frame_pointer, - FILE * input, wint_t initial, + URL_FILE * input, wint_t initial, bool seen_period ); struct cons_pointer read_list( struct stack_frame *frame, - struct cons_pointer frame_pointer, FILE * input, + struct cons_pointer frame_pointer, URL_FILE * input, wint_t initial ); -struct cons_pointer read_string( FILE * input, wint_t initial ); -struct cons_pointer read_symbol( FILE * input, wint_t initial ); +struct cons_pointer read_string( URL_FILE * input, wint_t initial ); +struct cons_pointer read_symbol( URL_FILE * input, wint_t initial ); /** * quote reader macro in C (!) @@ -61,7 +61,7 @@ struct cons_pointer c_quote( struct cons_pointer arg ) { */ struct cons_pointer read_continuation( struct stack_frame *frame, struct cons_pointer frame_pointer, - FILE * input, wint_t initial ) { + URL_FILE * input, wint_t initial ) { debug_print( L"entering read_continuation\n", DEBUG_IO ); struct cons_pointer result = NIL; @@ -129,6 +129,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, } } break; + //case ':': reserved for keywords and paths default: if ( iswdigit( c ) ) { result = @@ -158,7 +159,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, */ struct cons_pointer read_number( struct stack_frame *frame, struct cons_pointer frame_pointer, - FILE * input, + URL_FILE * input, wint_t initial, bool seen_period ) { debug_print( L"entering read_number\n", DEBUG_IO ); @@ -267,7 +268,7 @@ struct cons_pointer read_number( struct stack_frame *frame, */ struct cons_pointer read_list( struct stack_frame *frame, struct cons_pointer frame_pointer, - FILE * input, wint_t initial ) { + URL_FILE * input, wint_t initial ) { struct cons_pointer result = NIL; if ( initial != ')' ) { debug_printf( DEBUG_IO, @@ -293,7 +294,7 @@ struct cons_pointer read_list( struct stack_frame *frame, * so delimited in which case it may not contain whitespace (unless escaped) * but may contain a double quote character (probably not a good idea!) */ -struct cons_pointer read_string( FILE * input, wint_t initial ) { +struct cons_pointer read_string( URL_FILE * input, wint_t initial ) { struct cons_pointer cdr = NIL; struct cons_pointer result; switch ( initial ) { @@ -315,7 +316,7 @@ struct cons_pointer read_string( FILE * input, wint_t initial ) { return result; } -struct cons_pointer read_symbol( FILE * input, wint_t initial ) { +struct cons_pointer read_symbol( URL_FILE * input, wint_t initial ) { struct cons_pointer cdr = NIL; struct cons_pointer result; switch ( initial ) { @@ -331,7 +332,7 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) { break; case ')': /* - * symbols may not include right-parenthesis + * symbols may not include right-parenthesis; */ result = NIL; /* @@ -367,6 +368,6 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) { struct cons_pointer read( struct stack_frame *frame, struct cons_pointer frame_pointer, - FILE * input ) { + URL_FILE * input ) { return read_continuation( frame, frame_pointer, input, fgetwc( input ) ); } diff --git a/src/ops/read.h b/src/ops/read.h index c6dbba3..a1674d6 100644 --- a/src/ops/read.h +++ b/src/ops/read.h @@ -15,6 +15,6 @@ * read the next object on this input stream and return a cons_pointer to it. */ struct cons_pointer read( struct stack_frame *frame, - struct cons_pointer frame_pointer, FILE * input ); + struct cons_pointer frame_pointer, URL_FILE * input ); #endif diff --git a/unit-tests/bignum-print.sh b/unit-tests/bignum-print.sh index 5615871..d556e71 100755 --- a/unit-tests/bignum-print.sh +++ b/unit-tests/bignum-print.sh @@ -18,17 +18,6 @@ else exit 1 fi -echo -n "checking no bignum was created: " -grep -v 'BIGNUM!' psse.log > /dev/null -if [ $? -eq "0" ] -then - echo "OK" -else - echo "Fail" - exit 1 -fi - - ##################################################################### # right on the boundary @@ -48,17 +37,6 @@ else exit 1 fi -echo -n "checking no bignum was created: " -grep -v 'BIGNUM!' psse.log > /dev/null -if [ $? -eq "0" ] -then - echo "OK" -else - echo "Fail" - exit 1 -fi - - ##################################################################### # definitely a bignum @@ -79,16 +57,10 @@ else fi -echo -n "checking a bignum was created: " -grep 'BIGNUM!' psse.log > /dev/null -if [ $? -eq "0" ] -then - echo "OK" -else - echo "Fail" - exit 1 -fi - +# Currently failing from here on, but it's failing in read because of +# the multiply bug. We know printing blows up at the 3 cell boundary +# because `lisp/scratchpad2.lisp` constructs a 3 cell bignum by +# repeated addition. ##################################################################### # Just on the three cell boundary expected='1329227995784915872903807060280344576' @@ -103,7 +75,7 @@ if [ "${expected}" = "${actual}" ] then echo "OK" else - echo "Fail: expected '${expected}', got '${actual}'" + echo "Fail: expected '${expected}', \n got '${actual}'" exit 1 fi diff --git a/unit-tests/string-cons.sh b/unit-tests/string-cons.sh old mode 100644 new mode 100755 diff --git a/unit-tests/wide-character.sh b/unit-tests/wide-character.sh new file mode 100755 index 0000000..d56544e --- /dev/null +++ b/unit-tests/wide-character.sh @@ -0,0 +1,12 @@ +#!/bin/bash + +expected='"λάμ(β)δα"' +actual=`echo $expected | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi From b8f241c2c51ca00f981e42a3539da3a65dbcbd7d Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 27 Jan 2019 12:23:51 +0000 Subject: [PATCH 34/40] Progress, not working --- src/init.c | 4 +-- src/io/fopen.c | 48 +++++++++++++++++++++++++++--------- src/io/fopen.h | 16 ++++++++++-- src/memory/consspaceobject.h | 1 - 4 files changed, 52 insertions(+), 17 deletions(-) diff --git a/src/init.c b/src/init.c index e8a33a9..8f278bf 100644 --- a/src/init.c +++ b/src/init.c @@ -130,7 +130,7 @@ int main( int argc, char *argv[] ) { fwide( stdin, 1 ); fwide( stdout, 1 ); fwide( stderr, 1 ); - fwide( sink, 1 ); + fwide( sink->handle.file, 1 ); bind_value( L"*in*", make_read_stream( file_to_url_file(stdin) ) ); bind_value( L"*out*", make_write_stream( file_to_url_file(stdout) ) ); bind_value( L"*log*", make_write_stream( file_to_url_file(stderr) ) ); @@ -200,7 +200,7 @@ int main( int argc, char *argv[] ) { debug_dump_object( oblist, DEBUG_BOOTSTRAP ); if ( dump_at_end ) { - dump_pages( stdout ); + dump_pages( file_to_url_file(stdout) ); } return ( 0 ); diff --git a/src/io/fopen.c b/src/io/fopen.c index d13250f..14c95e8 100644 --- a/src/io/fopen.c +++ b/src/io/fopen.c @@ -3,8 +3,11 @@ * * adapted from https://curl.haxx.se/libcurl/c/fopen.html. * + * Modifications to read/write wide character streams by + * Simon Brooke. + * * Copyright (c) 2003, 2017 Simtec Electronics - * Some portions (c) 2017 Simon Brooke + * Some portions (c) 2019 Simon Brooke * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions @@ -41,11 +44,6 @@ #include #include -/* - * wide characters - */ -#include -#include #include "fopen.h" @@ -177,8 +175,11 @@ static int use_buffer(URL_FILE *file, size_t want) /* ditch buffer - write will recreate */ free(file->buffer); file->buffer = NULL; + free(file->wide_buffer); + file->wide_buffer = NULL; file->buffer_pos = 0; file->buffer_len = 0; + file->wide_cursor = 0; } else { /* move rest down make it available for later */ @@ -187,6 +188,7 @@ static int use_buffer(URL_FILE *file, size_t want) (file->buffer_pos - want)); file->buffer_pos -= want; + // TODO: something to adjust the wide_cursor } return 0; } @@ -424,18 +426,40 @@ URL_FILE * file_to_url_file( FILE* f) { return result; } - -wint_t url_fgetwc(URL_FILE *file) { +/** + * get one wide character from the buffer. + * + * @param file the stream to read from; + * @return the next wide character on the stream, or zero if no more. + */ +wint_t url_fgetwc(URL_FILE *input) { wint_t result = 0; - switch(file->type) { + switch(input->type) { case CFTYPE_FILE: - fwide( file->handle.file, 1 ); /* wide characters */ - result = fgetc(file->handle.file); /* passthrough */ + fwide( input->handle.file, 1 ); /* wide characters */ + result = fgetc(input->handle.file); /* passthrough */ break; case CFTYPE_CURL: - url_fread(&result, sizeof(wint_t), 1, file); + if (input.buffer_len != 0) { + if ( input.wide_buffer == NULL) { + /* not initialised */ + input.wide_buffer = calloc( input.buffer_len, sizeof(wint_t)); + } + + size_t len = wcslen(input.wide_buffer); + if (input.still_running || + len == 0 || + len >= input.wide_cursor) { + /* refresh the wide buffer */ + mbstowcs(input.wide_buffer, input.buffer, input.buffer_pos); + } + + result = input.wide_buffer[input.wide_cursor] ++; + + /* do something to fread (advance) one utf character */ + } break; } diff --git a/src/io/fopen.h b/src/io/fopen.h index 9874ac7..83ea5a8 100644 --- a/src/io/fopen.h +++ b/src/io/fopen.h @@ -3,8 +3,12 @@ * * adapted from https://curl.haxx.se/libcurl/c/fopen.html. * + * + * Modifications to read/write wide character streams by + * Simon Brooke. + * * Copyright (c) 2003, 2017 Simtec Electronics - * Some portions (c) 2017 Simon Brooke + * Some portions (c) 2019 Simon Brooke * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions @@ -33,6 +37,12 @@ #ifndef __fopen_h #define __fopen_h +#include +/* + * wide characters + */ +#include +#include enum fcurl_type_e { CFTYPE_NONE = 0, @@ -49,8 +59,10 @@ struct fcurl_data } handle; /* handle */ char *buffer; /* buffer to store cached data*/ - size_t buffer_len; /* currently allocated buffers length */ + wchar_t *wide_buffer; /* wide character buffer */ + size_t buffer_len; /* currently allocated buffer's length */ size_t buffer_pos; /* end of data in buffer*/ + size_t wide_cursor; /* cursor into the wide buffer */ int still_running; /* Is background url fetch still in progress */ }; diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 8db8099..b3f587c 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -16,7 +16,6 @@ */ #include #include -#include #include "fopen.h" From 0e11adea1cfdafe97f4b0ebe5e8ce74e956132a5 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 27 Jan 2019 17:22:13 +0000 Subject: [PATCH 35/40] Compiles, most tests break --- src/arith/peano.c | 129 +++--- src/arith/peano.h | 14 +- src/arith/ratio.c | 16 +- src/debug.c | 9 +- src/init.c | 19 +- src/io/fopen.c | 832 ++++++++++++++++------------------- src/io/fopen.h | 55 +-- src/io/io.c | 177 ++++++++ src/io/io.h | 28 ++ src/memory/conspage.c | 2 +- src/memory/consspaceobject.h | 4 + src/memory/dump.c | 113 ++--- src/memory/stack.c | 24 +- src/memory/vectorspace.c | 5 +- src/ops/equal.c | 4 +- src/ops/intern.c | 8 +- src/ops/intern.h | 6 +- src/ops/io.c | 8 - src/ops/lispops.c | 56 ++- src/ops/print.c | 50 +-- src/ops/read.c | 54 ++- src/ops/read.h | 3 +- 22 files changed, 902 insertions(+), 714 deletions(-) create mode 100644 src/io/io.c create mode 100644 src/io/io.h delete mode 100644 src/ops/io.c diff --git a/src/arith/peano.c b/src/arith/peano.c index 7db638a..8e4cb43 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -43,13 +43,14 @@ bool zerop( struct cons_pointer arg ) { struct cons_space_object cell = pointer2cell( arg ); switch ( cell.tag.value ) { - case INTEGERTV: { + 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)); + 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: @@ -66,7 +67,7 @@ bool zerop( struct cons_pointer arg ) { /** * does this `arg` point to a negative number? */ -bool is_negative( struct cons_pointer arg) { +bool is_negative( struct cons_pointer arg ) { bool result = false; struct cons_space_object cell = pointer2cell( arg ); @@ -85,27 +86,31 @@ 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 result = NIL; +struct cons_pointer absolute( struct cons_pointer frame_pointer, + struct cons_pointer arg ) { + struct cons_pointer result = NIL; struct cons_space_object cell = pointer2cell( 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(frame_pointer, - absolute(frame_pointer, cell.payload.ratio.dividend), - cell.payload.ratio.divisor); - break; - case REALTV: - result = make_real( 0 - cell.payload.real.value ); - break; + 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( frame_pointer, + absolute( frame_pointer, + cell.payload.ratio.dividend ), + cell.payload.ratio.divisor ); + break; + case REALTV: + result = make_real( 0 - cell.payload.real.value ); + break; + } } - } - return result; + return result; } /** @@ -126,7 +131,7 @@ long double to_long_double( struct cons_pointer arg ) { switch ( cell.tag.value ) { case INTEGERTV: // obviously, this doesn't work for bignums - result = (long double)cell.payload.integer.value; + 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) { @@ -141,8 +146,8 @@ long double to_long_double( struct cons_pointer arg ) { // } break; case RATIOTV: - result = to_long_double(cell.payload.ratio.dividend) / - to_long_double(cell.payload.ratio.divisor); + result = to_long_double( cell.payload.ratio.dividend ) / + to_long_double( cell.payload.ratio.divisor ); break; case REALTV: result = cell.payload.real.value; @@ -203,9 +208,9 @@ int64_t to_long_int( struct cons_pointer arg ) { * 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_pointer, frame->arg[0]); + *frame, struct cons_pointer frame_pointer, struct + cons_pointer env ) { + return absolute( frame_pointer, frame->arg[0] ); } /** @@ -388,10 +393,12 @@ struct cons_pointer multiply_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = throw_exception( make_cons( - c_string_to_lisp_string( L"Cannot multiply: argument 2 is not a number: " ), - c_type(arg2)), - frame_pointer ); + result = + throw_exception( make_cons + ( c_string_to_lisp_string + ( L"Cannot multiply: argument 2 is not a number: " ), + c_type( arg2 ) ), + frame_pointer ); break; } break; @@ -415,11 +422,12 @@ struct cons_pointer multiply_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = throw_exception( - make_cons(c_string_to_lisp_string - ( L"Cannot multiply: argument 2 is not a number" ), - c_type(arg2)), - frame_pointer ); + result = + throw_exception( make_cons + ( c_string_to_lisp_string + ( L"Cannot multiply: argument 2 is not a number" ), + c_type( arg2 ) ), + frame_pointer ); } break; case REALTV: @@ -428,11 +436,10 @@ struct cons_pointer multiply_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = throw_exception( - make_cons(c_string_to_lisp_string - ( L"Cannot multiply: argument 1 is not a number" ), - c_type(arg1)), - frame_pointer ); + result = throw_exception( make_cons( c_string_to_lisp_string + ( L"Cannot multiply: argument 1 is not a number" ), + c_type( arg1 ) ), + frame_pointer ); break; } } @@ -460,30 +467,27 @@ struct cons_pointer lisp_multiply( struct 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); + 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]); + multiply_one_arg( frame->arg[i] ); } struct cons_pointer more = frame->more; while ( consp( more ) && !exceptionp( result ) ) { - multiply_one_arg(c_car( more )); + 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); + debug_print( L"lisp_multiply returning: ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); return result; } @@ -538,9 +542,10 @@ struct cons_pointer negative( struct cons_pointer frame, * 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; + *frame, + struct cons_pointer frame_pointer, struct + cons_pointer env ) { + return is_negative( frame->arg[0] ) ? TRUE : NIL; } diff --git a/src/arith/peano.h b/src/arith/peano.h index 7164a24..7ad7662 100644 --- a/src/arith/peano.h +++ b/src/arith/peano.h @@ -22,23 +22,25 @@ bool zerop( struct cons_pointer arg ); struct cons_pointer negative( struct cons_pointer frame, struct cons_pointer arg ); -bool is_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 frame_pointer, + struct cons_pointer arg ); long double to_long_double( struct cons_pointer arg ); struct cons_pointer lisp_absolute( struct stack_frame - *frame, struct cons_pointer frame_pointer, struct - cons_pointer env ); + *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 ); + *frame, + struct cons_pointer frame_pointer, struct + cons_pointer env ); struct cons_pointer lisp_multiply( struct stack_frame *frame, diff --git a/src/arith/ratio.c b/src/arith/ratio.c index 784e71e..65b09da 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -55,10 +55,10 @@ struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, 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 ); + 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 ( gcd > 1 ) { if ( drrv / gcd == 1 ) { @@ -199,10 +199,10 @@ struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg1, struct cons_pointer arg2 ) { struct cons_pointer i = make_ratio( frame_pointer, - pointer2cell( arg2 ).payload.ratio. - divisor, - pointer2cell( arg2 ).payload.ratio. - dividend ), result = + pointer2cell( arg2 ).payload. + ratio.divisor, + pointer2cell( arg2 ).payload. + ratio.dividend ), result = multiply_ratio_ratio( frame_pointer, arg1, i ); dec_ref( i ); diff --git a/src/debug.c b/src/debug.c index d694827..14881f9 100644 --- a/src/debug.c +++ b/src/debug.c @@ -19,6 +19,7 @@ #include #include "consspaceobject.h" +#include "fopen.h" #include "debug.h" #include "dump.h" #include "print.h" @@ -104,8 +105,10 @@ void debug_printf( int level, wchar_t *format, ... ) { void debug_print_object( struct cons_pointer pointer, int level ) { #ifdef DEBUG if ( level & verbosity ) { + URL_FILE *ustderr = file_to_url_file( stderr ); fwide( stderr, 1 ); - print( stderr, pointer ); + print( ustderr, pointer ); + free( ustderr ); } #endif } @@ -116,8 +119,10 @@ void debug_print_object( struct cons_pointer pointer, int level ) { void debug_dump_object( struct cons_pointer pointer, int level ) { #ifdef DEBUG if ( level & verbosity ) { + URL_FILE *ustderr = file_to_url_file( stderr ); fwide( stderr, 1 ); - dump_object( stderr, pointer ); + dump_object( ustderr, pointer ); + free( ustderr ); } #endif } diff --git a/src/init.c b/src/init.c index 8f278bf..a45e685 100644 --- a/src/init.c +++ b/src/init.c @@ -21,6 +21,7 @@ #include "consspaceobject.h" #include "debug.h" #include "intern.h" +#include "io.h" #include "lispops.h" #include "peano.h" #include "print.h" @@ -82,7 +83,7 @@ int main( int argc, char *argv[] ) { bool dump_at_end = false; bool show_prompt = false; - setlocale(LC_ALL, ""); + setlocale( LC_ALL, "" ); while ( ( option = getopt( argc, argv, "cpdv:" ) ) != -1 ) { switch ( option ) { @@ -131,9 +132,9 @@ int main( int argc, char *argv[] ) { fwide( stdout, 1 ); fwide( stderr, 1 ); fwide( sink->handle.file, 1 ); - bind_value( L"*in*", make_read_stream( file_to_url_file(stdin) ) ); - bind_value( L"*out*", make_write_stream( file_to_url_file(stdout) ) ); - bind_value( L"*log*", make_write_stream( file_to_url_file(stderr) ) ); + bind_value( L"*in*", make_read_stream( file_to_url_file( stdin ) ) ); + bind_value( L"*out*", make_write_stream( file_to_url_file( stdout ) ) ); + bind_value( L"*log*", make_write_stream( file_to_url_file( stderr ) ) ); bind_value( L"*sink*", make_write_stream( sink ) ); /* @@ -151,6 +152,7 @@ int main( int argc, char *argv[] ) { bind_function( L"assoc", &lisp_assoc ); bind_function( L"car", &lisp_car ); bind_function( L"cdr", &lisp_cdr ); + bind_function( L"close", &lisp_close ); bind_function( L"cons", &lisp_cons ); bind_function( L"divide", &lisp_divide ); bind_function( L"eq", &lisp_eq ); @@ -159,12 +161,15 @@ int main( int argc, char *argv[] ) { bind_function( L"exception", &lisp_exception ); bind_function( L"inspect", &lisp_inspect ); bind_function( L"multiply", &lisp_multiply ); - bind_function( L"negative?", &lisp_is_negative); + bind_function( L"negative?", &lisp_is_negative ); bind_function( L"read", &lisp_read ); bind_function( L"repl", &lisp_repl ); bind_function( L"oblist", &lisp_oblist ); + bind_function( L"open", &lisp_open ); bind_function( L"print", &lisp_print ); bind_function( L"progn", &lisp_progn ); + bind_function( L"read", &lisp_read ); + bind_function( L"read_char", &lisp_read_char ); bind_function( L"reverse", &lisp_reverse ); bind_function( L"set", &lisp_set ); bind_function( L"source", &lisp_source ); @@ -183,7 +188,7 @@ int main( int argc, char *argv[] ) { */ bind_special( L"cond", &lisp_cond ); bind_special( L"lambda", &lisp_lambda ); - bind_special( L"\u03bb", &lisp_lambda ); // λ + bind_special( L"\u03bb", &lisp_lambda ); // λ bind_special( L"nlambda", &lisp_nlambda ); bind_special( L"n\u03bb", &lisp_nlambda ); bind_special( L"progn", &lisp_progn ); @@ -200,7 +205,7 @@ int main( int argc, char *argv[] ) { debug_dump_object( oblist, DEBUG_BOOTSTRAP ); if ( dump_at_end ) { - dump_pages( file_to_url_file(stdout) ); + dump_pages( file_to_url_file( stdout ) ); } return ( 0 ); diff --git a/src/io/fopen.c b/src/io/fopen.c index 14c95e8..499fada 100644 --- a/src/io/fopen.c +++ b/src/io/fopen.c @@ -6,6 +6,9 @@ * Modifications to read/write wide character streams by * Simon Brooke. * + * NOTE THAT: for my purposes, I'm only interested in wide characters, + * and I always read them one character at a time. + * * Copyright (c) 2003, 2017 Simtec Electronics * Some portions (c) 2019 Simon Brooke * @@ -34,14 +37,13 @@ * This example requires libcurl 7.9.7 or later. */ - +#include #include +#include #include #ifndef WIN32 -# include +#include #endif -#include -#include #include @@ -51,362 +53,376 @@ static CURLM *multi_handle; /* curl calls this routine to get more data */ -static size_t write_callback(char *buffer, - size_t size, - size_t nitems, - void *userp) -{ - char *newbuff; - size_t rembuff; +static size_t write_callback( char *buffer, + size_t size, size_t nitems, void *userp ) { + char *newbuff; + size_t rembuff; - URL_FILE *url = (URL_FILE *)userp; - size *= nitems; + URL_FILE *url = ( URL_FILE * ) userp; + size *= nitems; - rembuff = url->buffer_len - url->buffer_pos; /* remaining space in buffer */ + rembuff = url->buffer_len - url->buffer_pos; /* remaining space in buffer */ - if(size > rembuff) { - /* not enough space in buffer */ - newbuff = realloc(url->buffer, url->buffer_len + (size - rembuff)); - if(newbuff == NULL) { - fprintf(stderr, "callback buffer grow failed\n"); - size = rembuff; + if ( size > rembuff ) { + /* not enough space in buffer */ + newbuff = realloc( url->buffer, url->buffer_len + ( size - rembuff ) ); + if ( newbuff == NULL ) { + fprintf( stderr, "callback buffer grow failed\n" ); + size = rembuff; + } else { + /* realloc succeeded increase buffer size */ + url->buffer_len += size - rembuff; + url->buffer = newbuff; + } } - else { - /* realloc succeeded increase buffer size*/ - url->buffer_len += size - rembuff; - url->buffer = newbuff; - } - } - memcpy(&url->buffer[url->buffer_pos], buffer, size); - url->buffer_pos += size; + memcpy( &url->buffer[url->buffer_pos], buffer, size ); + url->buffer_pos += size; - return size; + return size; } /* use to attempt to fill the read buffer up to requested number of bytes */ -static int fill_buffer(URL_FILE *file, size_t want) -{ - fd_set fdread; - fd_set fdwrite; - fd_set fdexcep; - struct timeval timeout; - int rc; - CURLMcode mc; /* curl_multi_fdset() return code */ +static int fill_buffer( URL_FILE * file, size_t want ) { + fd_set fdread; + fd_set fdwrite; + fd_set fdexcep; + struct timeval timeout; + int rc; + CURLMcode mc; /* curl_multi_fdset() return code */ - /* only attempt to fill buffer if transactions still running and buffer - * doesn't exceed required size already - */ - if((!file->still_running) || (file->buffer_pos > want)) - return 0; + /* only attempt to fill buffer if transactions still running and buffer + * doesn't exceed required size already + */ + if ( ( !file->still_running ) || ( file->buffer_pos > want ) ) + return 0; - /* attempt to fill buffer */ - do { - int maxfd = -1; - long curl_timeo = -1; + /* attempt to fill buffer */ + do { + int maxfd = -1; + long curl_timeo = -1; - FD_ZERO(&fdread); - FD_ZERO(&fdwrite); - FD_ZERO(&fdexcep); + FD_ZERO( &fdread ); + FD_ZERO( &fdwrite ); + FD_ZERO( &fdexcep ); - /* set a suitable timeout to fail on */ - timeout.tv_sec = 60; /* 1 minute */ - timeout.tv_usec = 0; + /* set a suitable timeout to fail on */ + timeout.tv_sec = 60; /* 1 minute */ + timeout.tv_usec = 0; - curl_multi_timeout(multi_handle, &curl_timeo); - if(curl_timeo >= 0) { - timeout.tv_sec = curl_timeo / 1000; - if(timeout.tv_sec > 1) - timeout.tv_sec = 1; - else - timeout.tv_usec = (curl_timeo % 1000) * 1000; - } + curl_multi_timeout( multi_handle, &curl_timeo ); + if ( curl_timeo >= 0 ) { + timeout.tv_sec = curl_timeo / 1000; + if ( timeout.tv_sec > 1 ) + timeout.tv_sec = 1; + else + timeout.tv_usec = ( curl_timeo % 1000 ) * 1000; + } - /* get file descriptors from the transfers */ - mc = curl_multi_fdset(multi_handle, &fdread, &fdwrite, &fdexcep, &maxfd); + /* get file descriptors from the transfers */ + mc = curl_multi_fdset( multi_handle, &fdread, &fdwrite, &fdexcep, + &maxfd ); - if(mc != CURLM_OK) { - fprintf(stderr, "curl_multi_fdset() failed, code %d.\n", mc); - break; - } + if ( mc != CURLM_OK ) { + fprintf( stderr, "curl_multi_fdset() failed, code %d.\n", mc ); + break; + } - /* On success the value of maxfd is guaranteed to be >= -1. We call - select(maxfd + 1, ...); specially in case of (maxfd == -1) there are - no fds ready yet so we call select(0, ...) --or Sleep() on Windows-- - to sleep 100ms, which is the minimum suggested value in the - curl_multi_fdset() doc. */ + /* On success the value of maxfd is guaranteed to be >= -1. We call + select(maxfd + 1, ...); specially in case of (maxfd == -1) there are + no fds ready yet so we call select(0, ...) --or Sleep() on Windows-- + to sleep 100ms, which is the minimum suggested value in the + curl_multi_fdset() doc. */ - if(maxfd == -1) { + if ( maxfd == -1 ) { #ifdef _WIN32 - Sleep(100); - rc = 0; + Sleep( 100 ); + rc = 0; #else - /* Portable sleep for platforms other than Windows. */ - struct timeval wait = { 0, 100 * 1000 }; /* 100ms */ - rc = select(0, NULL, NULL, NULL, &wait); + /* Portable sleep for platforms other than Windows. */ + struct timeval wait = { 0, 100 * 1000 }; /* 100ms */ + rc = select( 0, NULL, NULL, NULL, &wait ); #endif - } - else { - /* Note that on some platforms 'timeout' may be modified by select(). - If you need access to the original value save a copy beforehand. */ - rc = select(maxfd + 1, &fdread, &fdwrite, &fdexcep, &timeout); - } + } else { + /* Note that on some platforms 'timeout' may be modified by select(). + If you need access to the original value save a copy beforehand. */ + rc = select( maxfd + 1, &fdread, &fdwrite, &fdexcep, &timeout ); + } - switch(rc) { - case -1: - /* select error */ - break; + switch ( rc ) { + case -1: + /* select error */ + break; - case 0: - default: - /* timeout or readable/writable sockets */ - curl_multi_perform(multi_handle, &file->still_running); - break; - } - } while(file->still_running && (file->buffer_pos < want)); - return 1; + case 0: + default: + /* timeout or readable/writable sockets */ + curl_multi_perform( multi_handle, &file->still_running ); + break; + } + } while ( file->still_running && ( file->buffer_pos < want ) ); + + return 1; } /* use to remove want bytes from the front of a files buffer */ -static int use_buffer(URL_FILE *file, size_t want) -{ - /* sort out buffer */ - if((file->buffer_pos - want) <= 0) { - /* ditch buffer - write will recreate */ - free(file->buffer); - file->buffer = NULL; - free(file->wide_buffer); - file->wide_buffer = NULL; - file->buffer_pos = 0; - file->buffer_len = 0; - file->wide_cursor = 0; - } - else { - /* move rest down make it available for later */ - memmove(file->buffer, - &file->buffer[want], - (file->buffer_pos - want)); +static int use_buffer( URL_FILE * file, size_t want ) { + /* sort out buffer */ + if ( ( file->buffer_pos - want ) <= 0 ) { + /* ditch buffer - write will recreate */ + free( file->buffer ); + file->buffer = NULL; + file->buffer_pos = 0; + file->buffer_len = 0; + } else { + /* move rest down make it available for later */ + memmove( file->buffer, + &file->buffer[want], ( file->buffer_pos - want ) ); - file->buffer_pos -= want; - // TODO: something to adjust the wide_cursor - } - return 0; -} - -URL_FILE *url_fopen(const char *url, const char *operation) -{ - /* this code could check for URLs or types in the 'url' and - basically use the real fopen() for standard files */ - - URL_FILE *file; - (void)operation; - - file = calloc(1, sizeof(URL_FILE)); - if(!file) - return NULL; - - file->handle.file = fopen(url, operation); - if(file->handle.file) - file->type = CFTYPE_FILE; /* marked as URL */ - - else { - file->type = CFTYPE_CURL; /* marked as URL */ - file->handle.curl = curl_easy_init(); - - curl_easy_setopt(file->handle.curl, CURLOPT_URL, url); - curl_easy_setopt(file->handle.curl, CURLOPT_WRITEDATA, file); - curl_easy_setopt(file->handle.curl, CURLOPT_VERBOSE, 0L); - curl_easy_setopt(file->handle.curl, CURLOPT_WRITEFUNCTION, write_callback); - - if(!multi_handle) - multi_handle = curl_multi_init(); - - curl_multi_add_handle(multi_handle, file->handle.curl); - - /* lets start the fetch */ - curl_multi_perform(multi_handle, &file->still_running); - - if((file->buffer_pos == 0) && (!file->still_running)) { - /* if still_running is 0 now, we should return NULL */ - - /* make sure the easy handle is not in the multi handle anymore */ - curl_multi_remove_handle(multi_handle, file->handle.curl); - - /* cleanup */ - curl_easy_cleanup(file->handle.curl); - - free(file); - - file = NULL; + file->buffer_pos -= want; } - } - return file; + return 0; } -int url_fclose(URL_FILE *file) -{ - int ret = 0;/* default is good return */ +/** + * consume one wide character on the buffer of this file. + * + * @param file the url or file from which the character is consumed. + */ +static int use_one_wide( URL_FILE * file ) { + int c = ( int ) file->buffer[file->buffer_pos]; + size_t count = 0; - switch(file->type) { - case CFTYPE_FILE: - ret = fclose(file->handle.file); /* passthrough */ - break; - - case CFTYPE_CURL: - /* make sure the easy handle is not in the multi handle anymore */ - curl_multi_remove_handle(multi_handle, file->handle.curl); - - /* cleanup */ - curl_easy_cleanup(file->handle.curl); - break; - - default: /* unknown or supported type - oh dear */ - ret = EOF; - errno = EBADF; - break; - } - - free(file->buffer);/* free any allocated buffer space */ - free(file); - - return ret; -} - -int url_feof(URL_FILE *file) -{ - int ret = 0; - - switch(file->type) { - case CFTYPE_FILE: - ret = feof(file->handle.file); - break; - - case CFTYPE_CURL: - if((file->buffer_pos == 0) && (!file->still_running)) - ret = 1; - break; - - default: /* unknown or supported type - oh dear */ - ret = -1; - errno = EBADF; - break; - } - return ret; -} - -size_t url_fread(void *ptr, size_t size, size_t nmemb, URL_FILE *file) -{ - size_t want; - - switch(file->type) { - case CFTYPE_FILE: - want = fread(ptr, size, nmemb, file->handle.file); - break; - - case CFTYPE_CURL: - want = nmemb * size; - - fill_buffer(file, want); - - /* check if there's data in the buffer - if not fill_buffer() - * either errored or EOF */ - if(!file->buffer_pos) - return 0; - - /* ensure only available data is considered */ - if(file->buffer_pos < want) - want = file->buffer_pos; - - /* xfer data to caller */ - memcpy(ptr, file->buffer, want); - - use_buffer(file, want); - - want = want / size; /* number of items */ - break; - - default: /* unknown or supported type - oh dear */ - want = 0; - errno = EBADF; - break; - - } - return want; -} - -char *url_fgets(char *ptr, size_t size, URL_FILE *file) -{ - size_t want = size - 1;/* always need to leave room for zero termination */ - size_t loop; - - switch(file->type) { - case CFTYPE_FILE: - ptr = fgets(ptr, (int)size, file->handle.file); - break; - - case CFTYPE_CURL: - fill_buffer(file, want); - - /* check if there's data in the buffer - if not fill either errored or - * EOF */ - if(!file->buffer_pos) - return NULL; - - /* ensure only available data is considered */ - if(file->buffer_pos < want) - want = file->buffer_pos; - - /*buffer contains data */ - /* look for newline or eof */ - for(loop = 0; loop < want; loop++) { - if(file->buffer[loop] == '\n') { - want = loop + 1;/* include newline */ - break; - } + /* The value of each individual byte indicates its UTF-8 function, as follows: + * + * 00 to 7F hex (0 to 127): first and only byte of a sequence. + * 80 to BF hex (128 to 191): continuing byte in a multi-byte sequence. + * C2 to DF hex (194 to 223): first byte of a two-byte sequence. + * E0 to EF hex (224 to 239): first byte of a three-byte sequence. + * F0 to FF hex (240 to 255): first byte of a four-byte sequence. + */ + if ( c <= '0x07' ) { + count = 1; + } else if ( c >= '0xc2' && c <= '0xdf' ) { + count = 2; + } else if ( c >= '0xe0' && c <= '0xef' ) { + count = 3; + } else if ( c >= '0xf0' && c <= '0xff' ) { + count = 4; } - /* xfer data to caller */ - memcpy(ptr, file->buffer, want); - ptr[want] = 0;/* always null terminate */ - - use_buffer(file, want); - - break; - - default: /* unknown or supported type - oh dear */ - ptr = NULL; - errno = EBADF; - break; - } - - return ptr;/*success */ + return use_buffer( file, c ); } -void url_rewind(URL_FILE *file) -{ - switch(file->type) { - case CFTYPE_FILE: - rewind(file->handle.file); /* passthrough */ - break; +URL_FILE *url_fopen( const char *url, const char *operation ) { + /* this code could check for URLs or types in the 'url' and + basically use the real fopen() for standard files */ - case CFTYPE_CURL: - /* halt transaction */ - curl_multi_remove_handle(multi_handle, file->handle.curl); + URL_FILE *file; + ( void ) operation; - /* restart */ - curl_multi_add_handle(multi_handle, file->handle.curl); + file = calloc( 1, sizeof( URL_FILE ) ); + if ( !file ) + return NULL; - /* ditch buffer - write will recreate - resets stream pos*/ - free(file->buffer); - file->buffer = NULL; - file->buffer_pos = 0; - file->buffer_len = 0; + file->handle.file = fopen( url, operation ); + if ( file->handle.file ) + file->type = CFTYPE_FILE; /* marked as URL */ - break; + else { + file->type = CFTYPE_CURL; /* marked as URL */ + file->handle.curl = curl_easy_init( ); - default: /* unknown or supported type - oh dear */ - break; - } + curl_easy_setopt( file->handle.curl, CURLOPT_URL, url ); + curl_easy_setopt( file->handle.curl, CURLOPT_WRITEDATA, file ); + curl_easy_setopt( file->handle.curl, CURLOPT_VERBOSE, 0L ); + curl_easy_setopt( file->handle.curl, CURLOPT_WRITEFUNCTION, + write_callback ); + + if ( !multi_handle ) + multi_handle = curl_multi_init( ); + + curl_multi_add_handle( multi_handle, file->handle.curl ); + + /* lets start the fetch */ + curl_multi_perform( multi_handle, &file->still_running ); + + if ( ( file->buffer_pos == 0 ) && ( !file->still_running ) ) { + /* if still_running is 0 now, we should return NULL */ + + /* make sure the easy handle is not in the multi handle anymore */ + curl_multi_remove_handle( multi_handle, file->handle.curl ); + + /* cleanup */ + curl_easy_cleanup( file->handle.curl ); + + free( file ); + + file = NULL; + } + } + return file; +} + +int url_fclose( URL_FILE * file ) { + int ret = 0; /* default is good return */ + + switch ( file->type ) { + case CFTYPE_FILE: + ret = fclose( file->handle.file ); /* passthrough */ + break; + + case CFTYPE_CURL: + /* make sure the easy handle is not in the multi handle anymore */ + curl_multi_remove_handle( multi_handle, file->handle.curl ); + + /* cleanup */ + curl_easy_cleanup( file->handle.curl ); + break; + + default: /* unknown or supported type - oh dear */ + ret = EOF; + errno = EBADF; + break; + } + + free( file->buffer ); /* free any allocated buffer space */ + free( file ); + + return ret; +} + +int url_feof( URL_FILE * file ) { + int ret = 0; + + switch ( file->type ) { + case CFTYPE_FILE: + ret = feof( file->handle.file ); + break; + + case CFTYPE_CURL: + if ( ( file->buffer_pos == 0 ) && ( !file->still_running ) ) + ret = 1; + break; + + default: /* unknown or supported type - oh dear */ + ret = -1; + errno = EBADF; + break; + } + return ret; +} + +size_t url_fread( void *ptr, size_t size, size_t nmemb, URL_FILE * file ) { + size_t want; + + switch ( file->type ) { + case CFTYPE_FILE: + want = fread( ptr, size, nmemb, file->handle.file ); + break; + + case CFTYPE_CURL: + want = nmemb * size; + + fill_buffer( file, want ); + + /* check if there's data in the buffer - if not fill_buffer() + * either errored or EOF */ + if ( !file->buffer_pos ) + return 0; + + /* ensure only available data is considered */ + if ( file->buffer_pos < want ) + want = file->buffer_pos; + + /* xfer data to caller */ + memcpy( ptr, file->buffer, want ); + + use_buffer( file, want ); + + want = want / size; /* number of items */ + break; + + default: /* unknown or supported type - oh dear */ + want = 0; + errno = EBADF; + break; + + } + return want; +} + +char *url_fgets( char *ptr, size_t size, URL_FILE * file ) { + size_t want = size - 1; /* always need to leave room for zero termination */ + size_t loop; + + switch ( file->type ) { + case CFTYPE_FILE: + ptr = fgets( ptr, ( int ) size, file->handle.file ); + break; + + case CFTYPE_CURL: + fill_buffer( file, want ); + + /* check if there's data in the buffer - if not fill either errored or + * EOF */ + if ( !file->buffer_pos ) + return NULL; + + /* ensure only available data is considered */ + if ( file->buffer_pos < want ) + want = file->buffer_pos; + + /*buffer contains data */ + /* look for newline or eof */ + for ( loop = 0; loop < want; loop++ ) { + if ( file->buffer[loop] == '\n' ) { + want = loop + 1; /* include newline */ + break; + } + } + + /* xfer data to caller */ + memcpy( ptr, file->buffer, want ); + ptr[want] = 0; /* always null terminate */ + + use_buffer( file, want ); + + break; + + default: /* unknown or supported type - oh dear */ + ptr = NULL; + errno = EBADF; + break; + } + + return ptr; /*success */ +} + +void url_rewind( URL_FILE * file ) { + switch ( file->type ) { + case CFTYPE_FILE: + rewind( file->handle.file ); /* passthrough */ + break; + + case CFTYPE_CURL: + /* halt transaction */ + curl_multi_remove_handle( multi_handle, file->handle.curl ); + + /* restart */ + curl_multi_add_handle( multi_handle, file->handle.curl ); + + /* ditch buffer - write will recreate - resets stream pos */ + free( file->buffer ); + file->buffer = NULL; + file->buffer_pos = 0; + file->buffer_len = 0; + + break; + + default: /* unknown or supported type - oh dear */ + break; + } } /** @@ -415,153 +431,79 @@ void url_rewind(URL_FILE *file) * @param f the file to be wrapped; * @return the new handle, or null if no such handle could be allocated. */ -URL_FILE * file_to_url_file( FILE* f) { - URL_FILE * result = (URL_FILE *)malloc(sizeof(URL_FILE)); +URL_FILE *file_to_url_file( FILE * f ) { + URL_FILE *result = ( URL_FILE * ) malloc( sizeof( URL_FILE ) ); - if ( result != NULL) { - result->type = CFTYPE_FILE, - result->handle.file = f; - } + if ( result != NULL ) { + result->type = CFTYPE_FILE, result->handle.file = f; + } - return result; + return result; } + /** * get one wide character from the buffer. * * @param file the stream to read from; * @return the next wide character on the stream, or zero if no more. */ -wint_t url_fgetwc(URL_FILE *input) { - wint_t result = 0; +wint_t url_fgetwc( URL_FILE * input ) { + wint_t result = -1; - switch(input->type) { - case CFTYPE_FILE: - fwide( input->handle.file, 1 ); /* wide characters */ - result = fgetc(input->handle.file); /* passthrough */ - break; + switch ( input->type ) { + case CFTYPE_FILE: + fwide( input->handle.file, 1 ); /* wide characters */ + result = fgetwc( input->handle.file ); /* passthrough */ + break; - case CFTYPE_CURL: - if (input.buffer_len != 0) { - if ( input.wide_buffer == NULL) { - /* not initialised */ - input.wide_buffer = calloc( input.buffer_len, sizeof(wint_t)); - } + case CFTYPE_CURL:{ + wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) ); + char *cbuff = calloc( 5, sizeof( char ) ); - size_t len = wcslen(input.wide_buffer); - if (input.still_running || - len == 0 || - len >= input.wide_cursor) { - /* refresh the wide buffer */ - mbstowcs(input.wide_buffer, input.buffer, input.buffer_pos); - } + url_fread( cbuff, sizeof( char ), 4, input ); + mbstowcs( wbuff, cbuff, 1 ); + result = wbuff[0]; + use_one_wide( input ); - result = input.wide_buffer[input.wide_cursor] ++; - - /* do something to fread (advance) one utf character */ + free( cbuff ); + free( wbuff ); + } + break; + case CFTYPE_NONE: + break; } - break; - } - return result; + return result; } -/* #define FGETSFILE "fgets.test" */ -/* #define FREADFILE "fread.test" */ -/* #define REWINDFILE "rewind.test" */ +wint_t url_ungetwc( wint_t wc, URL_FILE * input ) { + wint_t result = -1; -/* /\* Small main program to retrieve from a url using fgets and fread saving the */ -/* * output to two test files (note the fgets method will corrupt binary files if */ -/* * they contain 0 chars *\/ */ -/* int main(int argc, char *argv[]) */ -/* { */ -/* URL_FILE *handle; */ -/* FILE *outf; */ + switch ( input->type ) { + case CFTYPE_FILE: + fwide( input->handle.file, 1 ); /* wide characters */ + result = fgetwc( input->handle.file ); /* passthrough */ + break; -/* size_t nread; */ -/* char buffer[256]; */ -/* const char *url; */ + case CFTYPE_CURL:{ + wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) ); + char *cbuff = calloc( 5, sizeof( char ) ); -/* if(argc < 2) */ -/* url = "http://192.168.7.3/testfile";/\* default to testurl *\/ */ -/* else */ -/* url = argv[1];/\* use passed url *\/ */ + wbuff[0] = wc; + result = wcstombs( cbuff, wbuff, 1 ); -/* /\* copy from url line by line with fgets *\/ */ -/* outf = fopen(FGETSFILE, "wb+"); */ -/* if(!outf) { */ -/* perror("couldn't open fgets output file\n"); */ -/* return 1; */ -/* } */ + input->buffer_pos -= strlen( cbuff ); -/* handle = url_fopen(url, "r"); */ -/* if(!handle) { */ -/* printf("couldn't url_fopen() %s\n", url); */ -/* fclose(outf); */ -/* return 2; */ -/* } */ + free( cbuff ); + free( wbuff ); -/* while(!url_feof(handle)) { */ -/* url_fgets(buffer, sizeof(buffer), handle); */ -/* fwrite(buffer, 1, strlen(buffer), outf); */ -/* } */ + result = result > 0 ? wc : result; + break; + case CFTYPE_NONE: + break; + } + } -/* url_fclose(handle); */ - -/* fclose(outf); */ - - -/* /\* Copy from url with fread *\/ */ -/* outf = fopen(FREADFILE, "wb+"); */ -/* if(!outf) { */ -/* perror("couldn't open fread output file\n"); */ -/* return 1; */ -/* } */ - -/* handle = url_fopen("testfile", "r"); */ -/* if(!handle) { */ -/* printf("couldn't url_fopen() testfile\n"); */ -/* fclose(outf); */ -/* return 2; */ -/* } */ - -/* do { */ -/* nread = url_fread(buffer, 1, sizeof(buffer), handle); */ -/* fwrite(buffer, 1, nread, outf); */ -/* } while(nread); */ - -/* url_fclose(handle); */ - -/* fclose(outf); */ - - -/* /\* Test rewind *\/ */ -/* outf = fopen(REWINDFILE, "wb+"); */ -/* if(!outf) { */ -/* perror("couldn't open fread output file\n"); */ -/* return 1; */ -/* } */ - -/* handle = url_fopen("testfile", "r"); */ -/* if(!handle) { */ -/* printf("couldn't url_fopen() testfile\n"); */ -/* fclose(outf); */ -/* return 2; */ -/* } */ - -/* nread = url_fread(buffer, 1, sizeof(buffer), handle); */ -/* fwrite(buffer, 1, nread, outf); */ -/* url_rewind(handle); */ - -/* buffer[0]='\n'; */ -/* fwrite(buffer, 1, 1, outf); */ - -/* nread = url_fread(buffer, 1, sizeof(buffer), handle); */ -/* fwrite(buffer, 1, nread, outf); */ - -/* url_fclose(handle); */ - -/* fclose(outf); */ - -/* return 0;/\* all done *\/ */ -/* } */ + return result; +} diff --git a/src/io/fopen.h b/src/io/fopen.h index 83ea5a8..f952a65 100644 --- a/src/io/fopen.h +++ b/src/io/fopen.h @@ -7,6 +7,9 @@ * Modifications to read/write wide character streams by * Simon Brooke. * + * NOTE THAT: for my purposes, I'm only interested in wide characters, + * and I always read them one character at a time. + * * Copyright (c) 2003, 2017 Simtec Electronics * Some portions (c) 2019 Simon Brooke * @@ -44,41 +47,41 @@ #include #include +#define url_fwprintf(f, ...) ((f->type = CFTYPE_FILE) ? fwprintf( f->handle.file, __VA_ARGS__) : -1) +#define url_fputws(ws, f) ((f->type = CFTYPE_FILE) ? fputws(ws, f->handle.file) : 0) +#define url_fputwc(wc, f) ((f->type = CFTYPE_FILE) ? fputwc(wc, f->handle.file) : 0) + enum fcurl_type_e { - CFTYPE_NONE = 0, - CFTYPE_FILE = 1, - CFTYPE_CURL = 2 + CFTYPE_NONE = 0, + CFTYPE_FILE = 1, + CFTYPE_CURL = 2 }; -struct fcurl_data -{ - enum fcurl_type_e type; /* type of handle */ - union { - CURL *curl; - FILE *file; - } handle; /* handle */ +struct fcurl_data { + enum fcurl_type_e type; /* type of handle */ + union { + CURL *curl; + FILE *file; + } handle; /* handle */ - char *buffer; /* buffer to store cached data*/ - wchar_t *wide_buffer; /* wide character buffer */ - size_t buffer_len; /* currently allocated buffer's length */ - size_t buffer_pos; /* end of data in buffer*/ - size_t wide_cursor; /* cursor into the wide buffer */ - int still_running; /* Is background url fetch still in progress */ + char *buffer; /* buffer to store cached data */ + size_t buffer_len; /* currently allocated buffer's length */ + size_t buffer_pos; /* cursor into in buffer */ + int still_running; /* Is background url fetch still in progress */ }; typedef struct fcurl_data URL_FILE; /* exported functions */ -URL_FILE *url_fopen(const char *url, const char *operation); -int url_fclose(URL_FILE *file); -int url_feof(URL_FILE *file); -size_t url_fread(void *ptr, size_t size, size_t nmemb, URL_FILE *file); -char *url_fgets(char *ptr, size_t size, URL_FILE *file); -void url_rewind(URL_FILE *file); - -wint_t url_fgetwc(URL_FILE *file); -URL_FILE * file_to_url_file( FILE* f); - +URL_FILE *url_fopen( const char *url, const char *operation ); +int url_fclose( URL_FILE * file ); +int url_feof( URL_FILE * file ); +size_t url_fread( void *ptr, size_t size, size_t nmemb, URL_FILE * file ); +char *url_fgets( char *ptr, size_t size, URL_FILE * file ); +void url_rewind( URL_FILE * file ); +wint_t url_fgetwc( URL_FILE * file ); +wint_t url_ungetwc( wint_t wc, URL_FILE * input ); +URL_FILE *file_to_url_file( FILE * f ); #endif diff --git a/src/io/io.c b/src/io/io.c new file mode 100644 index 0000000..5d2c652 --- /dev/null +++ b/src/io/io.c @@ -0,0 +1,177 @@ +/* + * io.c + * + * Communication between PSSE and the outside world, via libcurl. + * + * (c) 2019 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include + +#include "conspage.h" +#include "consspaceobject.h" +#include "debug.h" +#include "fopen.h" +#include "lispops.h" + +/** + * Convert this lisp string-like-thing (also works for symbols, and, later + * keywords) into a UTF-8 string. NOTE that the returned value has been + * malloced and must be freed. TODO: candidate to moving into a utilities + * file. + * + * @param s the lisp string or symbol; + * @return the c string. + */ +char *lisp_string_to_c_string( struct cons_pointer s ) { + char *result = NULL; + + if ( stringp( s ) || symbolp( s ) ) { + int len = 0; + + for ( struct cons_pointer c = s; !nilp( c ); + c = pointer2cell( c ).payload.string.cdr ) { + len++; + } + + wchar_t *buffer = calloc( len + 1, sizeof( wchar_t ) ); + /* worst case, one wide char = four utf bytes */ + result = calloc( ( len * 4 ) + 1, sizeof( char ) ); + + int i = 0; + for ( struct cons_pointer c = s; !nilp( c ); + c = pointer2cell( c ).payload.string.cdr ) { + buffer[i++] = pointer2cell( c ).payload.string.character; + } + + wcstombs( result, buffer, len ); + free( buffer ); + } + + return result; +} + +/** + * Function, sort-of: close the file indicated by my first arg, and return + * nil. If the first arg is not a stream, does nothing. All other args are + * ignored. + * + * * (close stream) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return T if the stream was successfully closed, else NIL. + */ +struct cons_pointer +lisp_close( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + + if ( readp( frame->arg[0] ) || writep( frame->arg[0] ) ) { + if ( url_fclose( pointer2cell( frame->arg[0] ).payload.stream.stream ) + == 0 ) { + result = TRUE; + } + } + + return result; +} + +/** + * Function: return a stream open on the URL indicated by the first argument; + * if a second argument is present and is non-nil, open it for reading. At + * present, further arguments are ignored and there is no mechanism to open + * to append, or error if the URL is faulty or indicates an unavailable + * resource. + * + * * (read-char stream) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return a string of one character, namely the next available character + * on my stream, if any, else NIL. + */ +struct cons_pointer +lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + + if ( stringp( frame->arg[0] ) ) { + char *url = lisp_string_to_c_string( frame->arg[0] ); + + if ( nilp( frame->arg[1] ) ) { + result = make_read_stream( url_fopen( url, "r" ) ); + } else { + // TODO: anything more complex is a problem for another day. + result = make_write_stream( url_fopen( url, "w" ) ); + } + + free( url ); + } + + return result; +} + +/** + * Function: return the next character from the stream indicated by arg 0; + * further arguments are ignored. + * + * * (read-char stream) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return a string of one character, namely the next available character + * on my stream, if any, else NIL. + */ +struct cons_pointer +lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + + if ( readp( frame->arg[0] ) ) { + result = + make_string( url_fgetwc + ( pointer2cell( frame->arg[0] ).payload.stream. + stream ), NIL ); + } + + return result; +} + +/** + * Function: return a string representing all characters from the stream + * indicated by arg 0; further arguments are ignored. + * + * * (slurp stream) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return a string of one character, namely the next available character + * on my stream, if any, else NIL. + */ +struct cons_pointer +lisp_slurp( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + struct cons_pointer cdr = NIL; + + if ( readp( frame->arg[0] ) ) { + URL_FILE *stream = pointer2cell( frame->arg[0] ).payload.stream.stream; + + for ( wint_t c = url_fgetwc( stream ); c != -1; + c = url_fgetwc( stream ) ) { + cdr = make_string( ( ( wchar_t ) c ), cdr ); + + if ( nilp( result ) ) { + result = cdr; + } + } + } + + return result; +} diff --git a/src/io/io.h b/src/io/io.h new file mode 100644 index 0000000..06dcaed --- /dev/null +++ b/src/io/io.h @@ -0,0 +1,28 @@ + +/* + * io.h + * + * Communication between PSSE and the outside world, via libcurl. + * + * (c) 2019 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_io_h +#define __psse_io_h + +struct cons_pointer +lisp_close( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); +struct cons_pointer +lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); +struct cons_pointer +lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); +struct cons_pointer +lisp_slurp( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); + + +#endif diff --git a/src/memory/conspage.c b/src/memory/conspage.c index 03034e4..7a1a0d8 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -117,7 +117,7 @@ void make_cons_page( ) { */ void dump_pages( URL_FILE * output ) { for ( int i = 0; i < initialised_cons_pages; i++ ) { - fwprintf( output, L"\nDUMPING PAGE %d\n", i ); + url_fwprintf( output, L"\nDUMPING PAGE %d\n", i ); for ( int j = 0; j < CONSPAGESIZE; j++ ) { dump_object( output, ( struct cons_pointer ) { diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index b3f587c..6230e64 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -491,6 +491,10 @@ struct special_payload { struct stream_payload { /** the stream to read from or write to. */ URL_FILE *stream; + /** metadata on the stream (e.g. its file attributes if a file, its HTTP + * headers if a URL, etc). Expected to be an association, or nil. Not yet + * implemented. */ + struct cons_pointer meta; }; /** diff --git a/src/memory/dump.c b/src/memory/dump.c index cec0dfd..e99d306 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -30,22 +30,22 @@ void dump_string_cell( URL_FILE * output, wchar_t *prefix, struct cons_pointer pointer ) { struct cons_space_object cell = pointer2cell( pointer ); if ( cell.payload.string.character == 0 ) { - fwprintf( output, - L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n", - prefix, - cell.payload.string.cdr.page, cell.payload.string.cdr.offset, - cell.count ); + url_fwprintf( output, + L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n", + prefix, + cell.payload.string.cdr.page, + cell.payload.string.cdr.offset, cell.count ); } else { - fwprintf( output, - L"\t\t%ls cell: character '%lc' (%d) next at page %d offset %d, count %u\n", - prefix, - ( wint_t ) cell.payload.string.character, - cell.payload.string.character, - cell.payload.string.cdr.page, - cell.payload.string.cdr.offset, cell.count ); - fwprintf( output, L"\t\t value: " ); + url_fwprintf( output, + L"\t\t%ls cell: character '%lc' (%d) next at page %d offset %d, count %u\n", + prefix, + ( wint_t ) cell.payload.string.character, + cell.payload.string.character, + cell.payload.string.cdr.page, + cell.payload.string.cdr.offset, cell.count ); + url_fwprintf( output, L"\t\t value: " ); print( output, pointer ); - fwprintf( output, L"\n" ); + url_fwprintf( output, L"\n" ); } } @@ -54,70 +54,71 @@ void dump_string_cell( URL_FILE * output, wchar_t *prefix, */ void dump_object( URL_FILE * output, struct cons_pointer pointer ) { struct cons_space_object cell = pointer2cell( pointer ); - fwprintf( output, - L"\t%4.4s (%d) at page %d, offset %d count %u\n", - cell.tag.bytes, - cell.tag.value, pointer.page, pointer.offset, cell.count ); + url_fwprintf( output, + L"\t%4.4s (%d) at page %d, offset %d count %u\n", + cell.tag.bytes, + cell.tag.value, pointer.page, pointer.offset, cell.count ); switch ( cell.tag.value ) { case CONSTV: - fwprintf( output, - L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u :", - cell.payload.cons.car.page, - cell.payload.cons.car.offset, - cell.payload.cons.cdr.page, - cell.payload.cons.cdr.offset, cell.count ); + url_fwprintf( output, + L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u :", + cell.payload.cons.car.page, + cell.payload.cons.car.offset, + cell.payload.cons.cdr.page, + cell.payload.cons.cdr.offset, cell.count ); print( output, pointer ); - fputws( L"\n", output ); + url_fputws( L"\n", output ); break; case EXCEPTIONTV: - fwprintf( output, L"\t\tException cell: " ); + url_fwprintf( output, L"\t\tException cell: " ); dump_stack_trace( output, pointer ); break; case FREETV: - fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n", - cell.payload.cons.cdr.page, - cell.payload.cons.cdr.offset ); + url_fwprintf( output, + L"\t\tFree cell: next at page %d offset %d\n", + cell.payload.cons.cdr.page, + cell.payload.cons.cdr.offset ); break; case INTEGERTV: - fwprintf( output, - L"\t\tInteger cell: value %ld, count %u\n", - cell.payload.integer.value, cell.count ); + url_fwprintf( output, + L"\t\tInteger cell: value %ld, count %u\n", + cell.payload.integer.value, cell.count ); if ( !nilp( cell.payload.integer.more ) ) { - fputws( L"\t\tBIGNUM! More at:\n", output ); + url_fputws( L"\t\tBIGNUM! More at:\n", output ); dump_object( output, cell.payload.integer.more ); } break; case LAMBDATV: - fwprintf( output, L"\t\t\u03bb cell;\n\t\t args: " ); + url_fwprintf( output, L"\t\t\u03bb cell;\n\t\t args: " ); print( output, cell.payload.lambda.args ); - fwprintf( output, L";\n\t\t\tbody: " ); + url_fwprintf( output, L";\n\t\t\tbody: " ); print( output, cell.payload.lambda.body ); - fputws( L"\n", output ); + url_fputws( L"\n", output ); break; case NILTV: break; case NLAMBDATV: - fwprintf( output, L"\t\tn\u03bb cell; \n\t\targs: " ); + url_fwprintf( output, L"\t\tn\u03bb cell; \n\t\targs: " ); print( output, cell.payload.lambda.args ); - fwprintf( output, L";\n\t\t\tbody: " ); + url_fwprintf( output, L";\n\t\t\tbody: " ); print( output, cell.payload.lambda.body ); - fputws( L"\n", output ); + url_fputws( L"\n", output ); break; case RATIOTV: - fwprintf( output, - L"\t\tRational cell: value %ld/%ld, count %u\n", - pointer2cell( cell.payload.ratio.dividend ).payload. - integer.value, - pointer2cell( cell.payload.ratio.divisor ).payload. - integer.value, cell.count ); + url_fwprintf( output, + L"\t\tRational cell: value %ld/%ld, count %u\n", + pointer2cell( cell.payload.ratio.dividend ). + payload.integer.value, + pointer2cell( cell.payload.ratio.divisor ). + payload.integer.value, cell.count ); break; case READTV: - fwprintf( output, L"\t\tInput stream\n" ); + url_fwprintf( output, L"\t\tInput stream\n" ); break; case REALTV: - fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n", - cell.payload.real.value, cell.count ); + url_fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n", + cell.payload.real.value, cell.count ); break; case STRINGTV: dump_string_cell( output, L"String", pointer ); @@ -128,14 +129,14 @@ void dump_object( URL_FILE * output, struct cons_pointer pointer ) { case TRUETV: break; case VECTORPOINTTV:{ - fwprintf( output, - L"\t\tPointer to vector-space object at %p\n", - cell.payload.vectorp.address ); + url_fwprintf( output, + L"\t\tPointer to vector-space object at %p\n", + cell.payload.vectorp.address ); struct vector_space_object *vso = cell.payload.vectorp.address; - fwprintf( output, - L"\t\tVector space object of type %4.4s (%d), payload size %d bytes\n", - &vso->header.tag.bytes, vso->header.tag.value, - vso->header.size ); + url_fwprintf( output, + L"\t\tVector space object of type %4.4s (%d), payload size %d bytes\n", + &vso->header.tag.bytes, vso->header.tag.value, + vso->header.size ); if ( stackframep( vso ) ) { dump_frame( output, pointer ); } @@ -147,7 +148,7 @@ void dump_object( URL_FILE * output, struct cons_pointer pointer ) { } break; case WRITETV: - fwprintf( output, L"\t\tOutput stream\n" ); + url_fwprintf( output, L"\t\tOutput stream\n" ); break; } } diff --git a/src/memory/stack.c b/src/memory/stack.c index b2585c7..3f4a271 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -34,9 +34,9 @@ void set_reg( struct stack_frame *frame, int reg, struct cons_pointer value ) { debug_printf( DEBUG_STACK, L"Setting register %d to ", reg ); debug_print_object( value, DEBUG_STACK ); debug_println( DEBUG_STACK ); - dec_ref(frame->arg[reg]); /* if there was anything in that slot - * previously other than NIL, we need to decrement it; - * NIL won't be decremented as it is locked. */ + dec_ref( frame->arg[reg] ); /* if there was anything in that slot + * previously other than NIL, we need to decrement it; + * NIL won't be decremented as it is locked. */ frame->arg[reg] = value; inc_ref( value ); @@ -245,22 +245,22 @@ void dump_frame( URL_FILE * output, struct cons_pointer frame_pointer ) { struct stack_frame *frame = get_stack_frame( frame_pointer ); if ( frame != NULL ) { - fwprintf( output, L"Stack frame with %d arguments:\n", frame->args ); + url_fwprintf( output, L"Stack frame with %d arguments:\n", + frame->args ); for ( int arg = 0; arg < frame->args; arg++ ) { struct cons_space_object cell = pointer2cell( frame->arg[arg] ); - fwprintf( output, L"Arg %d:\t%c%c%c%c\tcount: %10u\tvalue: ", arg, - cell.tag.bytes[0], - cell.tag.bytes[1], cell.tag.bytes[2], cell.tag.bytes[3], - cell.count ); + url_fwprintf( output, L"Arg %d:\t%c%c%c%c\tcount: %10u\tvalue: ", + arg, cell.tag.bytes[0], cell.tag.bytes[1], + cell.tag.bytes[2], cell.tag.bytes[3], cell.count ); print( output, frame->arg[arg] ); - fputws( L"\n", output ); + url_fputws( L"\n", output ); } if ( !nilp( frame->more ) ) { - fputws( L"More: \t", output ); + url_fputws( L"More: \t", output ); print( output, frame->more ); - fputws( L"\n", output ); + url_fputws( L"\n", output ); } } } @@ -268,7 +268,7 @@ 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 ) ) { print( output, pointer2cell( pointer ).payload.exception.message ); - fputws( L"\n", output ); + url_fputws( L"\n", output ); dump_stack_trace( output, pointer2cell( pointer ).payload.exception.frame ); } else { diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c index 9d98a77..480effb 100644 --- a/src/memory/vectorspace.c +++ b/src/memory/vectorspace.c @@ -36,7 +36,8 @@ * @return a cons_pointer to the object, or NIL if the object could not be * allocated due to memory exhaustion. */ -struct cons_pointer make_vec_pointer( struct vector_space_object *address, char *tag ) { +struct cons_pointer make_vec_pointer( struct vector_space_object *address, + char *tag ) { debug_print( L"Entered make_vec_pointer\n", DEBUG_ALLOC ); struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); @@ -46,7 +47,7 @@ struct cons_pointer make_vec_pointer( struct vector_space_object *address, char address ); cell->payload.vectorp.address = address; - strncpy(&cell->payload.vectorp.tag.bytes[0], tag, TAGLENGTH); + strncpy( &cell->payload.vectorp.tag.bytes[0], tag, TAGLENGTH ); debug_printf( DEBUG_ALLOC, L"make_vec_pointer: all good, returning pointer to %p\n", diff --git a/src/ops/equal.c b/src/ops/equal.c index 0c01a81..2775218 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -80,8 +80,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { && ( 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 ) ) ); + && end_of_string( cell_b->payload. + string.cdr ) ) ); break; case INTEGERTV: result = diff --git a/src/ops/intern.c b/src/ops/intern.c index 1e32a36..87d116e 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -110,8 +110,8 @@ struct cons_pointer c_assoc( struct cons_pointer key, * with this key/value pair added to the front. */ struct cons_pointer -bind( struct cons_pointer key, struct cons_pointer value, - struct cons_pointer store ) { +set( struct cons_pointer key, struct cons_pointer value, + struct cons_pointer store ) { debug_print( L"Binding ", DEBUG_BIND ); debug_print_object( key, DEBUG_BIND ); debug_print( L" to ", DEBUG_BIND ); @@ -131,7 +131,7 @@ deep_bind( struct cons_pointer key, struct cons_pointer value ) { debug_print( L"Entering deep_bind\n", DEBUG_BIND ); struct cons_pointer old = oblist; - oblist = bind( key, value, oblist ); + oblist = set( key, value, oblist ); inc_ref( oblist ); dec_ref( old ); @@ -153,7 +153,7 @@ intern( struct cons_pointer key, struct cons_pointer environment ) { /* * not currently bound */ - result = bind( key, NIL, environment ); + result = set( key, NIL, environment ); } return result; diff --git a/src/ops/intern.h b/src/ops/intern.h index b261242..fa17563 100644 --- a/src/ops/intern.h +++ b/src/ops/intern.h @@ -28,9 +28,9 @@ struct cons_pointer c_assoc( struct cons_pointer key, struct cons_pointer internedp( struct cons_pointer key, struct cons_pointer environment ); -struct cons_pointer bind( struct cons_pointer key, - struct cons_pointer value, - struct cons_pointer store ); +struct cons_pointer set( struct cons_pointer key, + struct cons_pointer value, + struct cons_pointer store ); struct cons_pointer deep_bind( struct cons_pointer key, struct cons_pointer value ); diff --git a/src/ops/io.c b/src/ops/io.c deleted file mode 100644 index ccd0af5..0000000 --- a/src/ops/io.c +++ /dev/null @@ -1,8 +0,0 @@ -/* - * io.c - * - * Communication between PSSE and the outside world, via libcurl. - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 9448c55..4bfe6f0 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -29,6 +29,7 @@ #include "debug.h" #include "dump.h" #include "equal.h" +#include "fopen.h" #include "integer.h" #include "intern.h" #include "lispops.h" @@ -231,7 +232,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, struct cons_pointer name = c_car( names ); struct cons_pointer val = frame->arg[i]; - new_env = bind( name, val, new_env ); + new_env = set( name, val, new_env ); log_binding( name, val ); names = c_cdr( names ); @@ -256,7 +257,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, } } - new_env = bind( names, vals, new_env ); + new_env = set( names, vals, new_env ); inc_ref( new_env ); } @@ -377,10 +378,9 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, result = next_pointer; } else { result = - ( *fn_cell.payload. - special.executable ) ( get_stack_frame - ( next_pointer ), - next_pointer, env ); + ( *fn_cell.payload.special. + executable ) ( get_stack_frame( next_pointer ), + next_pointer, env ); debug_print( L"Special form returning: ", DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL ); debug_println( DEBUG_EVAL ); @@ -627,10 +627,10 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, * @return true if `arg` represents an end of string, else false. * \todo candidate for moving to a memory/string.c file */ -bool end_of_stringp(struct cons_pointer arg) { - return nilp(arg) || - ( stringp( arg ) && - pointer2cell(arg).payload.string.character == (wint_t)'\0'); +bool end_of_stringp( struct cons_pointer arg ) { + return nilp( arg ) || + ( stringp( arg ) && + pointer2cell( arg ).payload.string.character == ( wint_t ) '\0' ); } /** @@ -656,8 +656,8 @@ lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( nilp( car ) && nilp( cdr ) ) { return NIL; } else if ( stringp( car ) && stringp( cdr ) && - end_of_stringp( c_cdr( car)) ) { - // \todo check that car is of length 1 + end_of_stringp( c_cdr( car ) ) ) { + // \todo check that car is of length 1 result = make_string( pointer2cell( car ).payload.string.character, cdr ); } else { @@ -691,7 +691,8 @@ lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, result = cell.payload.cons.car; break; case READTV: - result = make_string( fgetwc( cell.payload.stream.stream ), NIL ); + result = + make_string( url_fgetwc( cell.payload.stream.stream ), NIL ); break; case NILTV: break; @@ -734,7 +735,7 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, result = cell.payload.cons.cdr; break; case READTV: - fgetwc( cell.payload.stream.stream ); + url_fgetwc( cell.payload.stream.stream ); result = frame->arg[0]; break; case STRINGTV: @@ -839,7 +840,8 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, #ifdef DEBUG debug_print( L"entering lisp_read\n", DEBUG_IO ); #endif - URL_FILE *input = stdin; + URL_FILE *input; + struct cons_pointer in_stream = readp( frame->arg[0] ) ? frame->arg[0] : get_default_stream( true, env ); @@ -848,6 +850,8 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, debug_dump_object( in_stream, DEBUG_IO ); input = pointer2cell( in_stream ).payload.stream.stream; inc_ref( in_stream ); + } else { + input = file_to_url_file( stdin ); } struct cons_pointer result = read( frame, frame_pointer, input ); @@ -856,8 +860,11 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( readp( in_stream ) ) { dec_ref( in_stream ); + } else { + free( input ); } + return result; } @@ -922,7 +929,7 @@ lisp_print( 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 = NIL; - URL_FILE *output = stdout; + URL_FILE *output; struct cons_pointer out_stream = writep( frame->arg[1] ) ? frame->arg[1] : get_default_stream( false, env ); @@ -931,6 +938,8 @@ lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, debug_dump_object( out_stream, DEBUG_IO ); output = pointer2cell( out_stream ).payload.stream.stream; inc_ref( out_stream ); + } else { + output = file_to_url_file( stderr ); } debug_print( L"lisp_print: about to print\n", DEBUG_IO ); @@ -943,6 +952,8 @@ lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( writep( out_stream ) ) { dec_ref( out_stream ); + } else { + free( output ); } return result; @@ -1035,7 +1046,7 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, * @return the value of the last expression of the first successful `clause`. */ struct cons_pointer - lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, +lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; bool done = false; @@ -1165,7 +1176,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, * print as parent. */ while ( readp( input ) && writep( output ) - && !feof( pointer2cell( input ).payload.stream.stream ) ) { + && !url_feof( pointer2cell( input ).payload.stream.stream ) ) { /* OK, here's a really subtle problem: because lists are immutable, anything * bound in the oblist subsequent to this function being invoked isn't in the * environment. So, for example, changes to *prompt* or *log* made in the oblist @@ -1203,7 +1214,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, inc_ref( expr ); if ( exceptionp( expr ) - && feof( pointer2cell( input ).payload.stream.stream ) ) { + && url_feof( pointer2cell( input ).payload.stream.stream ) ) { /* suppress printing end of stream exception */ break; } @@ -1282,7 +1293,7 @@ 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 ); - URL_FILE *output = stdout; + URL_FILE *output; struct cons_pointer out_stream = writep( frame->arg[1] ) ? frame->arg[1] : get_default_stream( false, env ); @@ -1291,11 +1302,16 @@ struct cons_pointer lisp_inspect( struct stack_frame *frame, debug_dump_object( out_stream, DEBUG_IO ); output = pointer2cell( out_stream ).payload.stream.stream; inc_ref( out_stream ); + } else { + output = file_to_url_file( stdout ); } + dump_object( output, frame->arg[0] ); if ( writep( out_stream ) ) { dec_ref( out_stream ); + } else { + free( output ); } return frame->arg[0]; diff --git a/src/ops/print.c b/src/ops/print.c index d313960..8cb137e 100644 --- a/src/ops/print.c +++ b/src/ops/print.c @@ -40,7 +40,7 @@ void print_string_contents( URL_FILE * output, struct cons_pointer pointer ) { wchar_t c = cell->payload.string.character; if ( c != '\0' ) { - fputwc( c, output ); + url_fputwc( c, output ); } pointer = cell->payload.string.cdr; } @@ -52,9 +52,9 @@ void print_string_contents( URL_FILE * output, struct cons_pointer pointer ) { * characters. */ void print_string( URL_FILE * output, struct cons_pointer pointer ) { - fputwc( btowc( '"' ), output ); + url_fputwc( btowc( '"' ), output ); print_string_contents( output, pointer ); - fputwc( btowc( '"' ), output ); + url_fputwc( btowc( '"' ), output ); } /** @@ -70,7 +70,7 @@ print_list_contents( URL_FILE * output, struct cons_pointer pointer, switch ( cell->tag.value ) { case CONSTV: if ( initial_space ) { - fputwc( btowc( ' ' ), output ); + url_fputwc( btowc( ' ' ), output ); } print( output, cell->payload.cons.car ); @@ -79,23 +79,23 @@ print_list_contents( URL_FILE * output, struct cons_pointer pointer, case NILTV: break; default: - fwprintf( output, L" . " ); + url_fwprintf( output, L" . " ); print( output, pointer ); } } void print_list( URL_FILE * output, struct cons_pointer pointer ) { if ( print_use_colours ) { - fwprintf( output, L"%s(%s", "\x1B[31m", "\x1B[39m" ); + url_fwprintf( output, L"%s(%s", "\x1B[31m", "\x1B[39m" ); } else { - fputws( L"(", output ); + url_fputws( L"(", output ); }; print_list_contents( output, pointer, false ); if ( print_use_colours ) { - fwprintf( output, L"%s)%s", "\x1B[31m", "\x1B[39m" ); + url_fwprintf( output, L"%s)%s", "\x1B[31m", "\x1B[39m" ); } else { - fputws( L")", output ); + url_fputws( L")", output ); } } @@ -117,18 +117,18 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { print_list( output, pointer ); break; case EXCEPTIONTV: - fwprintf( output, L"\n%sException: ", - print_use_colours ? "\x1B[31m" : "" ); + url_fwprintf( output, L"\n%sException: ", + print_use_colours ? "\x1B[31m" : "" ); dump_stack_trace( output, pointer ); break; case FUNCTIONTV: - fwprintf( output, L"" ); + url_fwprintf( output, L"" ); break; case INTEGERTV:{ struct cons_pointer s = integer_to_string( pointer, 10 ); inc_ref( s ); if ( print_use_colours ) { - fputws( L"\x1B[34m", output ); + url_fputws( L"\x1B[34m", output ); } print_string_contents( output, s ); dec_ref( s ); @@ -147,7 +147,7 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { } break; case NILTV: - fwprintf( output, L"nil" ); + url_fwprintf( output, L"nil" ); break; case NLAMBDATV:{ struct cons_pointer to_print = @@ -163,11 +163,11 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { break; case RATIOTV: print( output, cell.payload.ratio.dividend ); - fputws( L"/", output ); + url_fputws( L"/", output ); print( output, cell.payload.ratio.divisor ); break; case READTV: - fwprintf( output, L"" ); + url_fwprintf( output, L"" ); break; case REALTV: /* \todo using the C heap is a bad plan because it will fragment. @@ -183,31 +183,31 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { } } if ( print_use_colours ) { - fputws( L"\x1B[34m", output ); + url_fputws( L"\x1B[34m", output ); } - fwprintf( output, L"%s", buffer ); + url_fwprintf( output, L"%s", buffer ); free( buffer ); break; case STRINGTV: if ( print_use_colours ) { - fputws( L"\x1B[36m", output ); + url_fputws( L"\x1B[36m", output ); } print_string( output, pointer ); break; case SYMBOLTV: if ( print_use_colours ) { - fputws( L"\x1B[1;33m", output ); + url_fputws( L"\x1B[1;33m", output ); } print_string_contents( output, pointer ); break; case SPECIALTV: - fwprintf( output, L"" ); + url_fwprintf( output, L"" ); break; case TRUETV: - fwprintf( output, L"t" ); + url_fwprintf( output, L"t" ); break; case WRITETV: - fwprintf( output, L"" ); + url_fwprintf( output, L"" ); break; default: fwprintf( stderr, @@ -219,12 +219,12 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { } if ( print_use_colours ) { - fputws( L"\x1B[39m", output ); + url_fputws( L"\x1B[39m", output ); } return pointer; } void println( URL_FILE * output ) { - fputws( L"\n", output ); + url_fputws( L"\n", output ); } diff --git a/src/ops/read.c b/src/ops/read.c index d2f79c4..989aa67 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -41,8 +41,8 @@ struct cons_pointer read_number( struct stack_frame *frame, URL_FILE * input, wint_t initial, bool seen_period ); struct cons_pointer read_list( struct stack_frame *frame, - struct cons_pointer frame_pointer, URL_FILE * input, - wint_t initial ); + struct cons_pointer frame_pointer, + URL_FILE * input, wint_t initial ); struct cons_pointer read_string( URL_FILE * input, wint_t initial ); struct cons_pointer read_symbol( URL_FILE * input, wint_t initial ); @@ -68,16 +68,18 @@ struct cons_pointer read_continuation( struct stack_frame *frame, wint_t c; for ( c = initial; - c == '\0' || iswblank( c ) || iswcntrl( c ); c = fgetwc( input ) ); + c == '\0' || iswblank( c ) || iswcntrl( c ); + c = url_fgetwc( input ) ); - if ( feof( input ) ) { + if ( url_feof( input ) ) { result = throw_exception( c_string_to_lisp_string ( L"End of file while reading" ), frame_pointer ); } else { switch ( c ) { case ';': - for ( c = fgetwc( input ); c != '\n'; c = fgetwc( input ) ); + for ( c = url_fgetwc( input ); c != '\n'; + c = url_fgetwc( input ) ); /* skip all characters from semi-colon to the end of the line */ break; case EOF: @@ -89,18 +91,19 @@ struct cons_pointer read_continuation( struct stack_frame *frame, result = c_quote( read_continuation ( frame, frame_pointer, input, - fgetwc( input ) ) ); + url_fgetwc( input ) ) ); break; case '(': result = - read_list( frame, frame_pointer, input, fgetwc( input ) ); + read_list( frame, frame_pointer, input, + url_fgetwc( input ) ); break; case '"': - result = read_string( input, fgetwc( input ) ); + result = read_string( input, url_fgetwc( input ) ); break; case '-':{ - wint_t next = fgetwc( input ); - ungetwc( next, input ); + wint_t next = url_fgetwc( input ); + url_ungetwc( next, input ); if ( iswdigit( next ) ) { result = read_number( frame, frame_pointer, input, c, @@ -112,9 +115,9 @@ struct cons_pointer read_continuation( struct stack_frame *frame, break; case '.': { - wint_t next = fgetwc( input ); + wint_t next = url_fgetwc( input ); if ( iswdigit( next ) ) { - ungetwc( next, input ); + url_ungetwc( next, input ); result = read_number( frame, frame_pointer, input, c, true ); @@ -123,13 +126,13 @@ struct cons_pointer read_continuation( struct stack_frame *frame, * really need to backtrack up a level. */ result = read_continuation( frame, frame_pointer, input, - fgetwc( input ) ); + url_fgetwc( input ) ); } else { read_symbol( input, c ); } } break; - //case ':': reserved for keywords and paths + //case ':': reserved for keywords and paths default: if ( iswdigit( c ) ) { result = @@ -173,14 +176,14 @@ struct cons_pointer read_number( struct stack_frame *frame, bool neg = initial == btowc( '-' ); if ( neg ) { - initial = fgetwc( input ); + initial = url_fgetwc( input ); } debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial, initial ); for ( c = initial; iswdigit( c ) - || c == L'.' || c == L'/' || c == L','; c = fgetwc( input ) ) { + || c == L'.' || c == L'/' || c == L','; c = url_fgetwc( input ) ) { switch ( c ) { case L'.': if ( seen_period || !nilp( dividend ) ) { @@ -229,7 +232,7 @@ struct cons_pointer read_number( struct stack_frame *frame, /* * push back the character read which was not a digit */ - ungetwc( c, input ); + url_ungetwc( c, input ); if ( seen_period ) { debug_print( L"read_number: converting result to real\n", DEBUG_IO ); @@ -279,7 +282,7 @@ struct cons_pointer read_list( struct stack_frame *frame, result = make_cons( car, read_list( frame, frame_pointer, input, - fgetwc( input ) ) ); + url_fgetwc( input ) ) ); } else { debug_print( L"End of list detected\n", DEBUG_IO ); } @@ -309,7 +312,8 @@ struct cons_pointer read_string( URL_FILE * input, wint_t initial ) { break; default: result = - make_string( initial, read_string( input, fgetwc( input ) ) ); + make_string( initial, + read_string( input, url_fgetwc( input ) ) ); break; } @@ -328,7 +332,8 @@ struct cons_pointer read_symbol( URL_FILE * input, wint_t initial ) { * THIS IS NOT A GOOD IDEA, but is legal */ result = - make_symbol( initial, read_symbol( input, fgetwc( input ) ) ); + make_symbol( initial, + read_symbol( input, url_fgetwc( input ) ) ); break; case ')': /* @@ -338,20 +343,20 @@ struct cons_pointer read_symbol( URL_FILE * input, wint_t initial ) { /* * push back the character read */ - ungetwc( initial, input ); + url_ungetwc( initial, input ); break; default: if ( iswprint( initial ) && !iswblank( initial ) ) { result = make_symbol( initial, - read_symbol( input, fgetwc( input ) ) ); + read_symbol( input, url_fgetwc( input ) ) ); } else { result = NIL; /* * push back the character read */ - ungetwc( initial, input ); + url_ungetwc( initial, input ); } break; } @@ -369,5 +374,6 @@ struct cons_pointer read( struct stack_frame *frame, struct cons_pointer frame_pointer, URL_FILE * input ) { - return read_continuation( frame, frame_pointer, input, fgetwc( input ) ); + return read_continuation( frame, frame_pointer, input, + url_fgetwc( input ) ); } diff --git a/src/ops/read.h b/src/ops/read.h index a1674d6..64f36b0 100644 --- a/src/ops/read.h +++ b/src/ops/read.h @@ -15,6 +15,7 @@ * read the next object on this input stream and return a cons_pointer to it. */ struct cons_pointer read( struct stack_frame *frame, - struct cons_pointer frame_pointer, URL_FILE * input ); + struct cons_pointer frame_pointer, + URL_FILE * input ); #endif From d9acb277bf463ef959744f66d60fb74bbf9cde48 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 27 Jan 2019 17:51:28 +0000 Subject: [PATCH 36/40] Tests now pass at least, all the ones that did before! --- src/init.c | 6 +++--- src/io/fopen.c | 4 +++- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/src/init.c b/src/init.c index a45e685..2814f1d 100644 --- a/src/init.c +++ b/src/init.c @@ -162,16 +162,16 @@ int main( int argc, char *argv[] ) { bind_function( L"inspect", &lisp_inspect ); bind_function( L"multiply", &lisp_multiply ); bind_function( L"negative?", &lisp_is_negative ); - bind_function( L"read", &lisp_read ); - bind_function( L"repl", &lisp_repl ); bind_function( L"oblist", &lisp_oblist ); bind_function( L"open", &lisp_open ); bind_function( L"print", &lisp_print ); bind_function( L"progn", &lisp_progn ); bind_function( L"read", &lisp_read ); - bind_function( L"read_char", &lisp_read_char ); + bind_function( L"read-char", &lisp_read_char ); + bind_function( L"repl", &lisp_repl ); bind_function( L"reverse", &lisp_reverse ); bind_function( L"set", &lisp_set ); + bind_function( L"slurp", &lisp_slurp ); bind_function( L"source", &lisp_source ); bind_function( L"subtract", &lisp_subtract ); bind_function( L"throw", &lisp_exception ); diff --git a/src/io/fopen.c b/src/io/fopen.c index 499fada..3b09957 100644 --- a/src/io/fopen.c +++ b/src/io/fopen.c @@ -47,6 +47,7 @@ #include +#include "debug.h" #include "fopen.h" /* we use a global one for convenience */ @@ -474,6 +475,7 @@ wint_t url_fgetwc( URL_FILE * input ) { break; } + debug_printf( DEBUG_IO, L"url_fgetwc returning %d (%C)\n", result, result); return result; } @@ -483,7 +485,7 @@ wint_t url_ungetwc( wint_t wc, URL_FILE * input ) { switch ( input->type ) { case CFTYPE_FILE: fwide( input->handle.file, 1 ); /* wide characters */ - result = fgetwc( input->handle.file ); /* passthrough */ + result = ungetwc( wc, input->handle.file ); /* passthrough */ break; case CFTYPE_CURL:{ From 3470f27585f20db741cf498b616d08c34dd5a1c4 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 27 Jan 2019 18:54:23 +0000 Subject: [PATCH 37/40] Can now read files from the filesystem. --- hi | 1 + src/io/io.c | 27 ++++++++++++++++++++------- unit-tests/slurp.sh | 13 +++++++++++++ 3 files changed, 34 insertions(+), 7 deletions(-) create mode 100644 hi create mode 100755 unit-tests/slurp.sh diff --git a/hi b/hi new file mode 100644 index 0000000..cf57f2a --- /dev/null +++ b/hi @@ -0,0 +1 @@ +Hello, this is used by `slurp.sh` test, please do not remove. diff --git a/src/io/io.c b/src/io/io.c index 5d2c652..e510580 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -31,7 +31,7 @@ char *lisp_string_to_c_string( struct cons_pointer s ) { int len = 0; for ( struct cons_pointer c = s; !nilp( c ); - c = pointer2cell( c ).payload.string.cdr ) { + c = pointer2cell( c ).payload.string.cdr ) { len++; } @@ -49,6 +49,10 @@ char *lisp_string_to_c_string( struct cons_pointer s ) { free( buffer ); } + debug_print(L"lisp_string_to_c_string( ", DEBUG_IO); + debug_print_object( s, DEBUG_IO); + debug_printf( DEBUG_IO, L") => '%s'\n", result); + return result; } @@ -110,6 +114,10 @@ lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer, } free( url ); + + if ( pointer2cell(result).payload.stream.stream == NULL) { + result = NIL; + } } return result; @@ -158,18 +166,23 @@ struct cons_pointer lisp_slurp( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; - struct cons_pointer cdr = NIL; if ( readp( frame->arg[0] ) ) { URL_FILE *stream = pointer2cell( frame->arg[0] ).payload.stream.stream; + struct cons_pointer cursor = make_string( url_fgetwc( stream ), NIL); + result = cursor; - for ( wint_t c = url_fgetwc( stream ); c != -1; + for ( wint_t c = url_fgetwc( stream ); !url_feof(stream); c = url_fgetwc( stream ) ) { - cdr = make_string( ( ( wchar_t ) c ), cdr ); + debug_print(L"slurp: cursor is: ", DEBUG_IO); + debug_dump_object( cursor, DEBUG_IO); + debug_print(L"; result is: ", DEBUG_IO); + debug_dump_object( result, DEBUG_IO); + debug_println( DEBUG_IO); - if ( nilp( result ) ) { - result = cdr; - } + struct cons_space_object * cell = &pointer2cell(cursor); + cursor = make_string( ( wchar_t ) c , NIL); + cell->payload.string.cdr = cursor; } } diff --git a/unit-tests/slurp.sh b/unit-tests/slurp.sh new file mode 100755 index 0000000..e285988 --- /dev/null +++ b/unit-tests/slurp.sh @@ -0,0 +1,13 @@ +#!/bin/bash + +expected='"Hello, this is used by `slurp.sh` test, please do not remove.' +actual=`echo '(slurp (open "hi"))' | target/psse | tail -2 | head -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" + exit 0 +else + echo "Fail: expected '$expected', got '$actual'" + exit 1 +fi From 8334e2bf1f3a92ff7af37adfb15fc977a361f772 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 28 Jan 2019 10:32:34 +0000 Subject: [PATCH 38/40] Still segfaults on read from URL. --- src/init.c | 4 ++++ src/io/fopen.c | 5 +---- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/init.c b/src/init.c index 2814f1d..1fba3f2 100644 --- a/src/init.c +++ b/src/init.c @@ -16,6 +16,9 @@ #include #include +/* libcurl, used for io */ +#include + #include "version.h" #include "conspage.h" #include "consspaceobject.h" @@ -84,6 +87,7 @@ int main( int argc, char *argv[] ) { bool show_prompt = false; setlocale( LC_ALL, "" ); + curl_global_init(CURL_GLOBAL_DEFAULT); while ( ( option = getopt( argc, argv, "cpdv:" ) ) != -1 ) { switch ( option ) { diff --git a/src/io/fopen.c b/src/io/fopen.c index 3b09957..a2eddab 100644 --- a/src/io/fopen.c +++ b/src/io/fopen.c @@ -460,14 +460,11 @@ wint_t url_fgetwc( URL_FILE * input ) { case CFTYPE_CURL:{ wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) ); - char *cbuff = calloc( 5, sizeof( char ) ); - url_fread( cbuff, sizeof( char ), 4, input ); - mbstowcs( wbuff, cbuff, 1 ); + mbstowcs( wbuff, (char *)&input->buffer[input->buffer_pos], 1 ); result = wbuff[0]; use_one_wide( input ); - free( cbuff ); free( wbuff ); } break; From b15c0e8f892283802f668d13ff9ec43f61f387d8 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 28 Jan 2019 15:02:46 +0000 Subject: [PATCH 39/40] Tactical commit --- src/arith/integer.c | 158 ++++++++++++++++++++++---------------------- src/init.c | 2 +- src/io/fopen.c | 103 +++++++++++++++++++++-------- src/io/io.c | 28 ++++---- 4 files changed, 167 insertions(+), 124 deletions(-) diff --git a/src/arith/integer.c b/src/arith/integer.c index 679bf37..1195c53 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -76,20 +76,16 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { * \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 val = nilp( c ) ? 0 : pointer2cell( c ).payload.integer.value; long int carry = is_first_cell ? 0 : ( MAX_INTEGER + 1 ); __int128_t result = ( __int128_t ) integerp( c ) ? - ( val == 0 ) ? - carry : - val : - op == '*' ? 1 : 0; + ( 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); + val, is_first_cell ? "true" : "false", + pointer2cell( c ).tag.bytes ); debug_print_128bit( result, DEBUG_ARITH ); debug_println( DEBUG_ARITH ); @@ -109,9 +105,8 @@ __int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) { * @return carry, if any, else 0. */ __int128_t int128_to_integer( __int128_t val, - struct cons_pointer less_significant, - struct cons_pointer new) -{ + struct cons_pointer less_significant, + struct cons_pointer new ) { struct cons_pointer cursor = NIL; __int128_t carry = 0; @@ -120,12 +115,12 @@ __int128_t int128_to_integer( __int128_t val, } else { carry = val >> 60; debug_printf( DEBUG_ARITH, - L"int128_to_integer: 64 bit overflow; setting carry to %ld\n", - ( int64_t ) carry ); + L"int128_to_integer: 64 bit overflow; setting carry to %ld\n", + ( int64_t ) carry ); val &= MAX_INTEGER; } - struct cons_space_object * newc = &pointer2cell( new); + struct cons_space_object *newc = &pointer2cell( new ); newc->payload.integer.value = val; if ( integerp( less_significant ) ) { @@ -137,19 +132,21 @@ __int128_t int128_to_integer( __int128_t val, return carry; } -struct cons_pointer make_integer_128(__int128_t val, - struct cons_pointer less_significant) { +struct cons_pointer make_integer_128( __int128_t val, + struct cons_pointer less_significant ) { struct cons_pointer result = NIL; do { if ( MAX_INTEGER >= val ) { - result = make_integer( (long int) val, less_significant); + result = make_integer( ( long int ) val, less_significant ); } else { - less_significant = make_integer( (long int)val & MAX_INTEGER, less_significant); + less_significant = + make_integer( ( long int ) val & MAX_INTEGER, + less_significant ); val = val >> 60; } - } while (nilp(result)); + } while ( nilp( result ) ); return result; } @@ -164,10 +161,10 @@ struct cons_pointer add_integers( struct cons_pointer a, struct cons_pointer cursor = NIL; debug_print( L"add_integers: a = ", DEBUG_ARITH ); - debug_print_object(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); + debug_print_object( b, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); __int128_t carry = 0; bool is_first_cell = true; @@ -194,8 +191,8 @@ struct cons_pointer add_integers( struct cons_pointer a, debug_print_128bit( rv, DEBUG_ARITH ); debug_print( L"\n", DEBUG_ARITH ); - struct cons_pointer new = make_integer( 0, NIL); - carry = int128_to_integer(rv, cursor, new); + struct cons_pointer new = make_integer( 0, NIL ); + carry = int128_to_integer( rv, cursor, new ); cursor = new; if ( nilp( result ) ) { @@ -215,14 +212,14 @@ struct cons_pointer add_integers( struct cons_pointer a, return result; } -struct cons_pointer base_partial(int depth) { - struct cons_pointer result = NIL; +struct cons_pointer base_partial( int depth ) { + struct cons_pointer result = NIL; - for (int i = 0; i < depth; i++) { - result = make_integer(0, result); - } + for ( int i = 0; i < depth; i++ ) { + result = make_integer( 0, result ); + } - return result; + return result; } /** @@ -236,69 +233,70 @@ struct cons_pointer base_partial(int depth) { struct cons_pointer multiply_integers( struct cons_pointer a, struct cons_pointer b ) { struct cons_pointer result = NIL; - bool neg = is_negative(a) != is_negative(b); + bool neg = is_negative( a ) != is_negative( b ); bool is_first_b = true; int oom = -1; debug_print( L"multiply_integers: a = ", DEBUG_ARITH ); - debug_print_object(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); + debug_print_object( b, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); if ( integerp( a ) && integerp( b ) ) { while ( !nilp( b ) ) { - bool is_first_d = true; - struct cons_pointer d = a; - struct cons_pointer partial = base_partial(++oom); - __int128_t carry = 0; + bool is_first_d = true; + struct cons_pointer d = a; + struct cons_pointer partial = base_partial( ++oom ); + __int128_t carry = 0; - while ( !nilp(d) || carry != 0) { - partial = make_integer(0, partial); - struct cons_pointer new = NIL; - __int128_t dv = cell_value( d, '+', is_first_d ); - __int128_t bv = cell_value( b, '+', is_first_b ); + while ( !nilp( d ) || carry != 0 ) { + partial = make_integer( 0, partial ); + struct cons_pointer new = NIL; + __int128_t dv = cell_value( d, '+', is_first_d ); + __int128_t bv = cell_value( b, '+', is_first_b ); - __int128_t rv = (dv * bv) + carry; + __int128_t rv = ( dv * bv ) + carry; - debug_print( L"multiply_integers: d = ", DEBUG_ARITH); - debug_print_object( d, DEBUG_ARITH); - debug_print( L"; dv = ", DEBUG_ARITH ); - debug_print_128bit( dv, 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"; acc = ", DEBUG_ARITH ); - debug_print_object( result, DEBUG_ARITH); - debug_print( L"; partial = ", DEBUG_ARITH ); - debug_print_object( partial, DEBUG_ARITH); - debug_print( L"\n", DEBUG_ARITH ); + debug_print( L"multiply_integers: d = ", DEBUG_ARITH ); + debug_print_object( d, DEBUG_ARITH ); + debug_print( L"; dv = ", DEBUG_ARITH ); + debug_print_128bit( dv, 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"; acc = ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); + debug_print( L"; partial = ", DEBUG_ARITH ); + debug_print_object( partial, DEBUG_ARITH ); + debug_print( L"\n", DEBUG_ARITH ); - new = make_integer_128(rv, base_partial(oom)); + new = make_integer_128( rv, base_partial( oom ) ); - if ( zerop(partial)) { - partial = new; - } else { - partial = add_integers(partial, new); + if ( zerop( partial ) ) { + partial = new; + } else { + partial = add_integers( partial, new ); + } + + d = integerp( d ) ? pointer2cell( d ).payload.integer. + more : NIL; + is_first_d = false; } - d = integerp(d) ? pointer2cell( d ).payload.integer.more : NIL; - is_first_d = false; - } - - if (nilp(result) || zerop(result)) { - result = partial; - } else { - struct cons_pointer old = result; - result = add_integers(partial, result); - //if (!eq(result, old)) dec_ref(old); - //if (!eq(result, partial)) dec_ref(partial); - } - b = pointer2cell( b ).payload.integer.more; - is_first_b = false; + if ( nilp( result ) || zerop( result ) ) { + result = partial; + } else { + struct cons_pointer old = result; + result = add_integers( partial, result ); + //if (!eq(result, old)) dec_ref(old); + //if (!eq(result, partial)) dec_ref(partial); + } + b = pointer2cell( b ).payload.integer.more; + is_first_b = false; } } @@ -365,8 +363,8 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, 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_print( L"; result is: ", DEBUG_IO ); + debug_print_object( result, DEBUG_IO ); debug_println( DEBUG_IO ); result = diff --git a/src/init.c b/src/init.c index 1fba3f2..c180b10 100644 --- a/src/init.c +++ b/src/init.c @@ -87,7 +87,7 @@ int main( int argc, char *argv[] ) { bool show_prompt = false; setlocale( LC_ALL, "" ); - curl_global_init(CURL_GLOBAL_DEFAULT); + curl_global_init( CURL_GLOBAL_DEFAULT ); while ( ( option = getopt( argc, argv, "cpdv:" ) ) != -1 ) { switch ( option ) { diff --git a/src/io/fopen.c b/src/io/fopen.c index a2eddab..3c26cd9 100644 --- a/src/io/fopen.c +++ b/src/io/fopen.c @@ -53,6 +53,8 @@ /* we use a global one for convenience */ static CURLM *multi_handle; +wint_t ungotten = 0; + /* curl calls this routine to get more data */ static size_t write_callback( char *buffer, size_t size, size_t nitems, void *userp ) { @@ -452,27 +454,69 @@ URL_FILE *file_to_url_file( FILE * f ) { wint_t url_fgetwc( URL_FILE * input ) { wint_t result = -1; - switch ( input->type ) { - case CFTYPE_FILE: - fwide( input->handle.file, 1 ); /* wide characters */ - result = fgetwc( input->handle.file ); /* passthrough */ - break; + debug_printf( DEBUG_IO, L"url_fgetwc: ungotten = %d\n", ungotten ); - case CFTYPE_CURL:{ - wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) ); + if ( ungotten != 0 ) { + /* TODO: not thread safe */ + result = ungotten; + ungotten = 0; + } else { + switch ( input->type ) { + case CFTYPE_FILE: + fwide( input->handle.file, 1 ); /* wide characters */ + result = fgetwc( input->handle.file ); /* passthrough */ + break; - mbstowcs( wbuff, (char *)&input->buffer[input->buffer_pos], 1 ); - result = wbuff[0]; - use_one_wide( input ); + case CFTYPE_CURL:{ + debug_print( L"url_fgetwc: stream is URL\n", DEBUG_IO ); - free( wbuff ); - } - break; - case CFTYPE_NONE: - break; + char *cbuff = + calloc( sizeof( wchar_t ) + 1, sizeof( char ) ); + wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) ); + + size_t count = 0; + + debug_print( L"url_fgetwc: about to call url_fgets\n", DEBUG_IO ); + url_fgets( cbuff, 1, input ); + debug_print( L"url_fgetwc: back from url_fgets\n", DEBUG_IO ); + int c = ( int ) cbuff[0]; + debug_printf( DEBUG_IO, L"url_fgetwc: (first) character = %d (%c)\n", c, c & 0xf7 ); + /* The value of each individual byte indicates its UTF-8 function, as follows: + * + * 00 to 7F hex (0 to 127): first and only byte of a sequence. + * 80 to BF hex (128 to 191): continuing byte in a multi-byte sequence. + * C2 to DF hex (194 to 223): first byte of a two-byte sequence. + * E0 to EF hex (224 to 239): first byte of a three-byte sequence. + * F0 to FF hex (240 to 255): first byte of a four-byte sequence. + */ + if ( c <= 0x07 ) { + count = 1; + } else if ( c >= '0xc2' && c <= '0xdf' ) { + count = 2; + } else if ( c >= '0xe0' && c <= '0xef' ) { + count = 3; + } else if ( c >= '0xf0' && c <= '0xff' ) { + count = 4; + } + + if ( count > 1 ) { + url_fgets( cbuff, --count, input ); + } + mbstowcs( wbuff, cbuff, 1 ); //(char *)(&input->buffer[input->buffer_pos]), 1 ); + result = wbuff[0]; + use_one_wide( input ); + + free( wbuff ); + free( cbuff ); + } + break; + case CFTYPE_NONE: + break; + } } - debug_printf( DEBUG_IO, L"url_fgetwc returning %d (%C)\n", result, result); + debug_printf( DEBUG_IO, L"url_fgetwc returning %d (%C)\n", result, + result ); return result; } @@ -482,22 +526,23 @@ wint_t url_ungetwc( wint_t wc, URL_FILE * input ) { switch ( input->type ) { case CFTYPE_FILE: fwide( input->handle.file, 1 ); /* wide characters */ - result = ungetwc( wc, input->handle.file ); /* passthrough */ + result = ungetwc( wc, input->handle.file ); /* passthrough */ break; case CFTYPE_CURL:{ - wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) ); - char *cbuff = calloc( 5, sizeof( char ) ); - - wbuff[0] = wc; - result = wcstombs( cbuff, wbuff, 1 ); - - input->buffer_pos -= strlen( cbuff ); - - free( cbuff ); - free( wbuff ); - - result = result > 0 ? wc : result; + ungotten = wc; +// wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) ); +// char *cbuff = calloc( 5, sizeof( char ) ); +// +// wbuff[0] = wc; +// result = wcstombs( cbuff, wbuff, 1 ); +// +// input->buffer_pos -= strlen( cbuff ); +// +// free( cbuff ); +// free( wbuff ); +// +// result = result > 0 ? wc : result; break; case CFTYPE_NONE: break; diff --git a/src/io/io.c b/src/io/io.c index e510580..4577a11 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -31,7 +31,7 @@ char *lisp_string_to_c_string( struct cons_pointer s ) { int len = 0; for ( struct cons_pointer c = s; !nilp( c ); - c = pointer2cell( c ).payload.string.cdr ) { + c = pointer2cell( c ).payload.string.cdr ) { len++; } @@ -49,9 +49,9 @@ char *lisp_string_to_c_string( struct cons_pointer s ) { free( buffer ); } - debug_print(L"lisp_string_to_c_string( ", DEBUG_IO); - debug_print_object( s, DEBUG_IO); - debug_printf( DEBUG_IO, L") => '%s'\n", result); + debug_print( L"lisp_string_to_c_string( ", DEBUG_IO ); + debug_print_object( s, DEBUG_IO ); + debug_printf( DEBUG_IO, L") => '%s'\n", result ); return result; } @@ -115,7 +115,7 @@ lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer, free( url ); - if ( pointer2cell(result).payload.stream.stream == NULL) { + if ( pointer2cell( result ).payload.stream.stream == NULL ) { result = NIL; } } @@ -169,19 +169,19 @@ lisp_slurp( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( readp( frame->arg[0] ) ) { URL_FILE *stream = pointer2cell( frame->arg[0] ).payload.stream.stream; - struct cons_pointer cursor = make_string( url_fgetwc( stream ), NIL); + struct cons_pointer cursor = make_string( url_fgetwc( stream ), NIL ); result = cursor; - for ( wint_t c = url_fgetwc( stream ); !url_feof(stream); + for ( wint_t c = url_fgetwc( stream ); !url_feof( stream ); c = url_fgetwc( stream ) ) { - debug_print(L"slurp: cursor is: ", DEBUG_IO); - debug_dump_object( cursor, DEBUG_IO); - debug_print(L"; result is: ", DEBUG_IO); - debug_dump_object( result, DEBUG_IO); - debug_println( DEBUG_IO); + debug_print( L"slurp: cursor is: ", DEBUG_IO ); + debug_dump_object( cursor, DEBUG_IO ); + debug_print( L"; result is: ", DEBUG_IO ); + debug_dump_object( result, DEBUG_IO ); + debug_println( DEBUG_IO ); - struct cons_space_object * cell = &pointer2cell(cursor); - cursor = make_string( ( wchar_t ) c , NIL); + struct cons_space_object *cell = &pointer2cell( cursor ); + cursor = make_string( ( wchar_t ) c, NIL ); cell->payload.string.cdr = cursor; } } From a640c9dff9c076190a7e83cea9ecb84aba35aaa5 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 28 Jan 2019 18:46:24 +0000 Subject: [PATCH 40/40] It works! --- .gitignore | 2 + lisp/slurp.lisp | 1 + src/debug.c | 2 +- src/io/fopen.c | 855 +++++++++++++++++++++--------------------- src/io/fopen.h | 4 - src/io/io.c | 131 ++++++- src/io/io.h | 4 + src/memory/conspage.c | 4 + src/ops/lispops.c | 2 +- src/ops/read.c | 1 + 10 files changed, 568 insertions(+), 438 deletions(-) create mode 100644 lisp/slurp.lisp diff --git a/.gitignore b/.gitignore index 6fa1cd9..ec1281e 100644 --- a/.gitignore +++ b/.gitignore @@ -34,3 +34,5 @@ utils_src/readprintwc/out *.dump *.bak + +src/io/fopen diff --git a/lisp/slurp.lisp b/lisp/slurp.lisp new file mode 100644 index 0000000..e927bcb --- /dev/null +++ b/lisp/slurp.lisp @@ -0,0 +1 @@ +(slurp (set! f (open "http://www.journeyman.cc/"))) diff --git a/src/debug.c b/src/debug.c index 14881f9..c8b9771 100644 --- a/src/debug.c +++ b/src/debug.c @@ -19,9 +19,9 @@ #include #include "consspaceobject.h" -#include "fopen.h" #include "debug.h" #include "dump.h" +#include "io.h" #include "print.h" /** diff --git a/src/io/fopen.c b/src/io/fopen.c index 3c26cd9..f0ea012 100644 --- a/src/io/fopen.c +++ b/src/io/fopen.c @@ -37,517 +37,510 @@ * This example requires libcurl 7.9.7 or later. */ -#include #include -#include #include #ifndef WIN32 #include #endif +#include +#include #include -#include "debug.h" -#include "fopen.h" +enum fcurl_type_e { + CFTYPE_NONE = 0, + CFTYPE_FILE = 1, + CFTYPE_CURL = 2 +}; + +struct fcurl_data +{ + enum fcurl_type_e type; /* type of handle */ + union { + CURL *curl; + FILE *file; + } handle; /* handle */ + + char *buffer; /* buffer to store cached data*/ + size_t buffer_len; /* currently allocated buffers length */ + size_t buffer_pos; /* end of data in buffer*/ + int still_running; /* Is background url fetch still in progress */ +}; + +typedef struct fcurl_data URL_FILE; + +/* exported functions */ +URL_FILE *url_fopen(const char *url, const char *operation); +int url_fclose(URL_FILE *file); +int url_feof(URL_FILE *file); +size_t url_fread(void *ptr, size_t size, size_t nmemb, URL_FILE *file); +char *url_fgets(char *ptr, size_t size, URL_FILE *file); +void url_rewind(URL_FILE *file); /* we use a global one for convenience */ static CURLM *multi_handle; -wint_t ungotten = 0; - /* curl calls this routine to get more data */ -static size_t write_callback( char *buffer, - size_t size, size_t nitems, void *userp ) { - char *newbuff; - size_t rembuff; +static size_t write_callback(char *buffer, + size_t size, + size_t nitems, + void *userp) +{ + char *newbuff; + size_t rembuff; - URL_FILE *url = ( URL_FILE * ) userp; - size *= nitems; + URL_FILE *url = (URL_FILE *)userp; + size *= nitems; - rembuff = url->buffer_len - url->buffer_pos; /* remaining space in buffer */ + rembuff = url->buffer_len - url->buffer_pos; /* remaining space in buffer */ - if ( size > rembuff ) { - /* not enough space in buffer */ - newbuff = realloc( url->buffer, url->buffer_len + ( size - rembuff ) ); - if ( newbuff == NULL ) { - fprintf( stderr, "callback buffer grow failed\n" ); - size = rembuff; - } else { - /* realloc succeeded increase buffer size */ - url->buffer_len += size - rembuff; - url->buffer = newbuff; - } + if(size > rembuff) { + /* not enough space in buffer */ + newbuff = realloc(url->buffer, url->buffer_len + (size - rembuff)); + if(newbuff == NULL) { + fprintf(stderr, "callback buffer grow failed\n"); + size = rembuff; } + else { + /* realloc succeeded increase buffer size*/ + url->buffer_len += size - rembuff; + url->buffer = newbuff; + } + } - memcpy( &url->buffer[url->buffer_pos], buffer, size ); - url->buffer_pos += size; + memcpy(&url->buffer[url->buffer_pos], buffer, size); + url->buffer_pos += size; - return size; + return size; } /* use to attempt to fill the read buffer up to requested number of bytes */ -static int fill_buffer( URL_FILE * file, size_t want ) { - fd_set fdread; - fd_set fdwrite; - fd_set fdexcep; - struct timeval timeout; - int rc; - CURLMcode mc; /* curl_multi_fdset() return code */ +static int fill_buffer(URL_FILE *file, size_t want) +{ + fd_set fdread; + fd_set fdwrite; + fd_set fdexcep; + struct timeval timeout; + int rc; + CURLMcode mc; /* curl_multi_fdset() return code */ - /* only attempt to fill buffer if transactions still running and buffer - * doesn't exceed required size already - */ - if ( ( !file->still_running ) || ( file->buffer_pos > want ) ) - return 0; + /* only attempt to fill buffer if transactions still running and buffer + * doesn't exceed required size already + */ + if((!file->still_running) || (file->buffer_pos > want)) + return 0; - /* attempt to fill buffer */ - do { - int maxfd = -1; - long curl_timeo = -1; + /* attempt to fill buffer */ + do { + int maxfd = -1; + long curl_timeo = -1; - FD_ZERO( &fdread ); - FD_ZERO( &fdwrite ); - FD_ZERO( &fdexcep ); + FD_ZERO(&fdread); + FD_ZERO(&fdwrite); + FD_ZERO(&fdexcep); - /* set a suitable timeout to fail on */ - timeout.tv_sec = 60; /* 1 minute */ - timeout.tv_usec = 0; + /* set a suitable timeout to fail on */ + timeout.tv_sec = 60; /* 1 minute */ + timeout.tv_usec = 0; - curl_multi_timeout( multi_handle, &curl_timeo ); - if ( curl_timeo >= 0 ) { - timeout.tv_sec = curl_timeo / 1000; - if ( timeout.tv_sec > 1 ) - timeout.tv_sec = 1; - else - timeout.tv_usec = ( curl_timeo % 1000 ) * 1000; - } + curl_multi_timeout(multi_handle, &curl_timeo); + if(curl_timeo >= 0) { + timeout.tv_sec = curl_timeo / 1000; + if(timeout.tv_sec > 1) + timeout.tv_sec = 1; + else + timeout.tv_usec = (curl_timeo % 1000) * 1000; + } - /* get file descriptors from the transfers */ - mc = curl_multi_fdset( multi_handle, &fdread, &fdwrite, &fdexcep, - &maxfd ); + /* get file descriptors from the transfers */ + mc = curl_multi_fdset(multi_handle, &fdread, &fdwrite, &fdexcep, &maxfd); - if ( mc != CURLM_OK ) { - fprintf( stderr, "curl_multi_fdset() failed, code %d.\n", mc ); - break; - } + if(mc != CURLM_OK) { + fprintf(stderr, "curl_multi_fdset() failed, code %d.\n", mc); + break; + } - /* On success the value of maxfd is guaranteed to be >= -1. We call - select(maxfd + 1, ...); specially in case of (maxfd == -1) there are - no fds ready yet so we call select(0, ...) --or Sleep() on Windows-- - to sleep 100ms, which is the minimum suggested value in the - curl_multi_fdset() doc. */ + /* On success the value of maxfd is guaranteed to be >= -1. We call + select(maxfd + 1, ...); specially in case of (maxfd == -1) there are + no fds ready yet so we call select(0, ...) --or Sleep() on Windows-- + to sleep 100ms, which is the minimum suggested value in the + curl_multi_fdset() doc. */ - if ( maxfd == -1 ) { + if(maxfd == -1) { #ifdef _WIN32 - Sleep( 100 ); - rc = 0; + Sleep(100); + rc = 0; #else - /* Portable sleep for platforms other than Windows. */ - struct timeval wait = { 0, 100 * 1000 }; /* 100ms */ - rc = select( 0, NULL, NULL, NULL, &wait ); + /* Portable sleep for platforms other than Windows. */ + struct timeval wait = { 0, 100 * 1000 }; /* 100ms */ + rc = select(0, NULL, NULL, NULL, &wait); #endif - } else { - /* Note that on some platforms 'timeout' may be modified by select(). - If you need access to the original value save a copy beforehand. */ - rc = select( maxfd + 1, &fdread, &fdwrite, &fdexcep, &timeout ); - } + } + else { + /* Note that on some platforms 'timeout' may be modified by select(). + If you need access to the original value save a copy beforehand. */ + rc = select(maxfd + 1, &fdread, &fdwrite, &fdexcep, &timeout); + } - switch ( rc ) { - case -1: - /* select error */ - break; + switch(rc) { + case -1: + /* select error */ + break; - case 0: - default: - /* timeout or readable/writable sockets */ - curl_multi_perform( multi_handle, &file->still_running ); - break; - } - } while ( file->still_running && ( file->buffer_pos < want ) ); - - return 1; + case 0: + default: + /* timeout or readable/writable sockets */ + curl_multi_perform(multi_handle, &file->still_running); + break; + } + } while(file->still_running && (file->buffer_pos < want)); + return 1; } /* use to remove want bytes from the front of a files buffer */ -static int use_buffer( URL_FILE * file, size_t want ) { - /* sort out buffer */ - if ( ( file->buffer_pos - want ) <= 0 ) { - /* ditch buffer - write will recreate */ - free( file->buffer ); - file->buffer = NULL; - file->buffer_pos = 0; - file->buffer_len = 0; - } else { - /* move rest down make it available for later */ - memmove( file->buffer, - &file->buffer[want], ( file->buffer_pos - want ) ); +static int use_buffer(URL_FILE *file, size_t want) +{ + /* sort out buffer */ + if((file->buffer_pos - want) <= 0) { + /* ditch buffer - write will recreate */ + free(file->buffer); + file->buffer = NULL; + file->buffer_pos = 0; + file->buffer_len = 0; + } + else { + /* move rest down make it available for later */ + memmove(file->buffer, + &file->buffer[want], + (file->buffer_pos - want)); - file->buffer_pos -= want; - } - return 0; + file->buffer_pos -= want; + } + return 0; } -/** - * consume one wide character on the buffer of this file. - * - * @param file the url or file from which the character is consumed. - */ -static int use_one_wide( URL_FILE * file ) { - int c = ( int ) file->buffer[file->buffer_pos]; - size_t count = 0; +URL_FILE *url_fopen(const char *url, const char *operation) +{ + /* this code could check for URLs or types in the 'url' and + basically use the real fopen() for standard files */ - /* The value of each individual byte indicates its UTF-8 function, as follows: - * - * 00 to 7F hex (0 to 127): first and only byte of a sequence. - * 80 to BF hex (128 to 191): continuing byte in a multi-byte sequence. - * C2 to DF hex (194 to 223): first byte of a two-byte sequence. - * E0 to EF hex (224 to 239): first byte of a three-byte sequence. - * F0 to FF hex (240 to 255): first byte of a four-byte sequence. - */ - if ( c <= '0x07' ) { - count = 1; - } else if ( c >= '0xc2' && c <= '0xdf' ) { - count = 2; - } else if ( c >= '0xe0' && c <= '0xef' ) { - count = 3; - } else if ( c >= '0xf0' && c <= '0xff' ) { - count = 4; + URL_FILE *file; + (void)operation; + + file = calloc(1, sizeof(URL_FILE)); + if(!file) + return NULL; + + file->handle.file = fopen(url, operation); + if(file->handle.file) + file->type = CFTYPE_FILE; /* marked as URL */ + + else { + file->type = CFTYPE_CURL; /* marked as URL */ + file->handle.curl = curl_easy_init(); + + curl_easy_setopt(file->handle.curl, CURLOPT_URL, url); + curl_easy_setopt(file->handle.curl, CURLOPT_WRITEDATA, file); + curl_easy_setopt(file->handle.curl, CURLOPT_VERBOSE, 0L); + curl_easy_setopt(file->handle.curl, CURLOPT_WRITEFUNCTION, write_callback); + + if(!multi_handle) + multi_handle = curl_multi_init(); + + curl_multi_add_handle(multi_handle, file->handle.curl); + + /* lets start the fetch */ + curl_multi_perform(multi_handle, &file->still_running); + + if((file->buffer_pos == 0) && (!file->still_running)) { + /* if still_running is 0 now, we should return NULL */ + + /* make sure the easy handle is not in the multi handle anymore */ + curl_multi_remove_handle(multi_handle, file->handle.curl); + + /* cleanup */ + curl_easy_cleanup(file->handle.curl); + + free(file); + + file = NULL; } - - return use_buffer( file, c ); + } + return file; } -URL_FILE *url_fopen( const char *url, const char *operation ) { - /* this code could check for URLs or types in the 'url' and - basically use the real fopen() for standard files */ +int url_fclose(URL_FILE *file) +{ + int ret = 0;/* default is good return */ - URL_FILE *file; - ( void ) operation; + switch(file->type) { + case CFTYPE_FILE: + ret = fclose(file->handle.file); /* passthrough */ + break; - file = calloc( 1, sizeof( URL_FILE ) ); - if ( !file ) - return NULL; + case CFTYPE_CURL: + /* make sure the easy handle is not in the multi handle anymore */ + curl_multi_remove_handle(multi_handle, file->handle.curl); - file->handle.file = fopen( url, operation ); - if ( file->handle.file ) - file->type = CFTYPE_FILE; /* marked as URL */ + /* cleanup */ + curl_easy_cleanup(file->handle.curl); + break; - else { - file->type = CFTYPE_CURL; /* marked as URL */ - file->handle.curl = curl_easy_init( ); + default: /* unknown or supported type - oh dear */ + ret = EOF; + errno = EBADF; + break; + } - curl_easy_setopt( file->handle.curl, CURLOPT_URL, url ); - curl_easy_setopt( file->handle.curl, CURLOPT_WRITEDATA, file ); - curl_easy_setopt( file->handle.curl, CURLOPT_VERBOSE, 0L ); - curl_easy_setopt( file->handle.curl, CURLOPT_WRITEFUNCTION, - write_callback ); + free(file->buffer);/* free any allocated buffer space */ + free(file); - if ( !multi_handle ) - multi_handle = curl_multi_init( ); - - curl_multi_add_handle( multi_handle, file->handle.curl ); - - /* lets start the fetch */ - curl_multi_perform( multi_handle, &file->still_running ); - - if ( ( file->buffer_pos == 0 ) && ( !file->still_running ) ) { - /* if still_running is 0 now, we should return NULL */ - - /* make sure the easy handle is not in the multi handle anymore */ - curl_multi_remove_handle( multi_handle, file->handle.curl ); - - /* cleanup */ - curl_easy_cleanup( file->handle.curl ); - - free( file ); - - file = NULL; - } - } - return file; + return ret; } -int url_fclose( URL_FILE * file ) { - int ret = 0; /* default is good return */ +int url_feof(URL_FILE *file) +{ + int ret = 0; - switch ( file->type ) { - case CFTYPE_FILE: - ret = fclose( file->handle.file ); /* passthrough */ - break; + switch(file->type) { + case CFTYPE_FILE: + ret = feof(file->handle.file); + break; - case CFTYPE_CURL: - /* make sure the easy handle is not in the multi handle anymore */ - curl_multi_remove_handle( multi_handle, file->handle.curl ); + case CFTYPE_CURL: + if((file->buffer_pos == 0) && (!file->still_running)) + ret = 1; + break; - /* cleanup */ - curl_easy_cleanup( file->handle.curl ); - break; - - default: /* unknown or supported type - oh dear */ - ret = EOF; - errno = EBADF; - break; - } - - free( file->buffer ); /* free any allocated buffer space */ - free( file ); - - return ret; + default: /* unknown or supported type - oh dear */ + ret = -1; + errno = EBADF; + break; + } + return ret; } -int url_feof( URL_FILE * file ) { - int ret = 0; +size_t url_fread(void *ptr, size_t size, size_t nmemb, URL_FILE *file) +{ + size_t want; - switch ( file->type ) { - case CFTYPE_FILE: - ret = feof( file->handle.file ); - break; + switch(file->type) { + case CFTYPE_FILE: + want = fread(ptr, size, nmemb, file->handle.file); + break; - case CFTYPE_CURL: - if ( ( file->buffer_pos == 0 ) && ( !file->still_running ) ) - ret = 1; - break; + case CFTYPE_CURL: + want = nmemb * size; - default: /* unknown or supported type - oh dear */ - ret = -1; - errno = EBADF; - break; - } - return ret; + fill_buffer(file, want); + + /* check if there's data in the buffer - if not fill_buffer() + * either errored or EOF */ + if(!file->buffer_pos) + return 0; + + /* ensure only available data is considered */ + if(file->buffer_pos < want) + want = file->buffer_pos; + + /* xfer data to caller */ + memcpy(ptr, file->buffer, want); + + use_buffer(file, want); + + want = want / size; /* number of items */ + break; + + default: /* unknown or supported type - oh dear */ + want = 0; + errno = EBADF; + break; + + } + return want; } -size_t url_fread( void *ptr, size_t size, size_t nmemb, URL_FILE * file ) { - size_t want; +char *url_fgets(char *ptr, size_t size, URL_FILE *file) +{ + size_t want = size - 1;/* always need to leave room for zero termination */ + size_t loop; - switch ( file->type ) { - case CFTYPE_FILE: - want = fread( ptr, size, nmemb, file->handle.file ); - break; + switch(file->type) { + case CFTYPE_FILE: + ptr = fgets(ptr, (int)size, file->handle.file); + break; - case CFTYPE_CURL: - want = nmemb * size; + case CFTYPE_CURL: + fill_buffer(file, want); - fill_buffer( file, want ); + /* check if there's data in the buffer - if not fill either errored or + * EOF */ + if(!file->buffer_pos) + return NULL; - /* check if there's data in the buffer - if not fill_buffer() - * either errored or EOF */ - if ( !file->buffer_pos ) - return 0; + /* ensure only available data is considered */ + if(file->buffer_pos < want) + want = file->buffer_pos; - /* ensure only available data is considered */ - if ( file->buffer_pos < want ) - want = file->buffer_pos; - - /* xfer data to caller */ - memcpy( ptr, file->buffer, want ); - - use_buffer( file, want ); - - want = want / size; /* number of items */ - break; - - default: /* unknown or supported type - oh dear */ - want = 0; - errno = EBADF; - break; - - } - return want; -} - -char *url_fgets( char *ptr, size_t size, URL_FILE * file ) { - size_t want = size - 1; /* always need to leave room for zero termination */ - size_t loop; - - switch ( file->type ) { - case CFTYPE_FILE: - ptr = fgets( ptr, ( int ) size, file->handle.file ); - break; - - case CFTYPE_CURL: - fill_buffer( file, want ); - - /* check if there's data in the buffer - if not fill either errored or - * EOF */ - if ( !file->buffer_pos ) - return NULL; - - /* ensure only available data is considered */ - if ( file->buffer_pos < want ) - want = file->buffer_pos; - - /*buffer contains data */ - /* look for newline or eof */ - for ( loop = 0; loop < want; loop++ ) { - if ( file->buffer[loop] == '\n' ) { - want = loop + 1; /* include newline */ - break; - } - } - - /* xfer data to caller */ - memcpy( ptr, file->buffer, want ); - ptr[want] = 0; /* always null terminate */ - - use_buffer( file, want ); - - break; - - default: /* unknown or supported type - oh dear */ - ptr = NULL; - errno = EBADF; - break; + /*buffer contains data */ + /* look for newline or eof */ + for(loop = 0; loop < want; loop++) { + if(file->buffer[loop] == '\n') { + want = loop + 1;/* include newline */ + break; + } } - return ptr; /*success */ + /* xfer data to caller */ + memcpy(ptr, file->buffer, want); + ptr[want] = 0;/* always null terminate */ + + use_buffer(file, want); + + break; + + default: /* unknown or supported type - oh dear */ + ptr = NULL; + errno = EBADF; + break; + } + + return ptr;/*success */ } -void url_rewind( URL_FILE * file ) { - switch ( file->type ) { - case CFTYPE_FILE: - rewind( file->handle.file ); /* passthrough */ - break; +void url_rewind(URL_FILE *file) +{ + switch(file->type) { + case CFTYPE_FILE: + rewind(file->handle.file); /* passthrough */ + break; - case CFTYPE_CURL: - /* halt transaction */ - curl_multi_remove_handle( multi_handle, file->handle.curl ); + case CFTYPE_CURL: + /* halt transaction */ + curl_multi_remove_handle(multi_handle, file->handle.curl); - /* restart */ - curl_multi_add_handle( multi_handle, file->handle.curl ); + /* restart */ + curl_multi_add_handle(multi_handle, file->handle.curl); - /* ditch buffer - write will recreate - resets stream pos */ - free( file->buffer ); - file->buffer = NULL; - file->buffer_pos = 0; - file->buffer_len = 0; + /* ditch buffer - write will recreate - resets stream pos*/ + free(file->buffer); + file->buffer = NULL; + file->buffer_pos = 0; + file->buffer_len = 0; - break; + break; - default: /* unknown or supported type - oh dear */ - break; - } + default: /* unknown or supported type - oh dear */ + break; + } } -/** - * given this file handle f, return a new url_file handle wrapping it. - * - * @param f the file to be wrapped; - * @return the new handle, or null if no such handle could be allocated. - */ -URL_FILE *file_to_url_file( FILE * f ) { - URL_FILE *result = ( URL_FILE * ) malloc( sizeof( URL_FILE ) ); +#ifdef FOPEN_STANDALONE +#define FGETSFILE "fgets.test" +#define FREADFILE "fread.test" +#define REWINDFILE "rewind.test" - if ( result != NULL ) { - result->type = CFTYPE_FILE, result->handle.file = f; - } +/* Small main program to retrieve from a url using fgets and fread saving the + * output to two test files (note the fgets method will corrupt binary files if + * they contain 0 chars */ +int main(int argc, char *argv[]) +{ + URL_FILE *handle; + FILE *outf; - return result; -} - - -/** - * get one wide character from the buffer. - * - * @param file the stream to read from; - * @return the next wide character on the stream, or zero if no more. - */ -wint_t url_fgetwc( URL_FILE * input ) { - wint_t result = -1; - - debug_printf( DEBUG_IO, L"url_fgetwc: ungotten = %d\n", ungotten ); - - if ( ungotten != 0 ) { - /* TODO: not thread safe */ - result = ungotten; - ungotten = 0; - } else { - switch ( input->type ) { - case CFTYPE_FILE: - fwide( input->handle.file, 1 ); /* wide characters */ - result = fgetwc( input->handle.file ); /* passthrough */ - break; - - case CFTYPE_CURL:{ - debug_print( L"url_fgetwc: stream is URL\n", DEBUG_IO ); - - char *cbuff = - calloc( sizeof( wchar_t ) + 1, sizeof( char ) ); - wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) ); - - size_t count = 0; - - debug_print( L"url_fgetwc: about to call url_fgets\n", DEBUG_IO ); - url_fgets( cbuff, 1, input ); - debug_print( L"url_fgetwc: back from url_fgets\n", DEBUG_IO ); - int c = ( int ) cbuff[0]; - debug_printf( DEBUG_IO, L"url_fgetwc: (first) character = %d (%c)\n", c, c & 0xf7 ); - /* The value of each individual byte indicates its UTF-8 function, as follows: - * - * 00 to 7F hex (0 to 127): first and only byte of a sequence. - * 80 to BF hex (128 to 191): continuing byte in a multi-byte sequence. - * C2 to DF hex (194 to 223): first byte of a two-byte sequence. - * E0 to EF hex (224 to 239): first byte of a three-byte sequence. - * F0 to FF hex (240 to 255): first byte of a four-byte sequence. - */ - if ( c <= 0x07 ) { - count = 1; - } else if ( c >= '0xc2' && c <= '0xdf' ) { - count = 2; - } else if ( c >= '0xe0' && c <= '0xef' ) { - count = 3; - } else if ( c >= '0xf0' && c <= '0xff' ) { - count = 4; - } - - if ( count > 1 ) { - url_fgets( cbuff, --count, input ); - } - mbstowcs( wbuff, cbuff, 1 ); //(char *)(&input->buffer[input->buffer_pos]), 1 ); - result = wbuff[0]; - use_one_wide( input ); - - free( wbuff ); - free( cbuff ); - } - break; - case CFTYPE_NONE: - break; - } - } - - debug_printf( DEBUG_IO, L"url_fgetwc returning %d (%C)\n", result, - result ); - return result; -} - -wint_t url_ungetwc( wint_t wc, URL_FILE * input ) { - wint_t result = -1; - - switch ( input->type ) { - case CFTYPE_FILE: - fwide( input->handle.file, 1 ); /* wide characters */ - result = ungetwc( wc, input->handle.file ); /* passthrough */ - break; - - case CFTYPE_CURL:{ - ungotten = wc; -// wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) ); -// char *cbuff = calloc( 5, sizeof( char ) ); -// -// wbuff[0] = wc; -// result = wcstombs( cbuff, wbuff, 1 ); -// -// input->buffer_pos -= strlen( cbuff ); -// -// free( cbuff ); -// free( wbuff ); -// -// result = result > 0 ? wc : result; - break; - case CFTYPE_NONE: - break; - } - } - - return result; + size_t nread; + char buffer[256]; + const char *url; + + CURL *curl; + CURLcode res; + + curl_global_init(CURL_GLOBAL_DEFAULT); + + curl = curl_easy_init(); + + + if(argc < 2) + url = "http://192.168.7.3/testfile";/* default to testurl */ + else + url = argv[1];/* use passed url */ + + /* copy from url line by line with fgets */ + outf = fopen(FGETSFILE, "wb+"); + if(!outf) { + perror("couldn't open fgets output file\n"); + return 1; + } + + handle = url_fopen(url, "r"); + if(!handle) { + printf("couldn't url_fopen() %s\n", url); + fclose(outf); + return 2; + } + + while(!url_feof(handle)) { + url_fgets(buffer, sizeof(buffer), handle); + fwrite(buffer, 1, strlen(buffer), outf); + } + + url_fclose(handle); + + fclose(outf); + + + /* Copy from url with fread */ + outf = fopen(FREADFILE, "wb+"); + if(!outf) { + perror("couldn't open fread output file\n"); + return 1; + } + + handle = url_fopen("testfile", "r"); + if(!handle) { + printf("couldn't url_fopen() testfile\n"); + fclose(outf); + return 2; + } + + do { + nread = url_fread(buffer, 1, sizeof(buffer), handle); + fwrite(buffer, 1, nread, outf); + } while(nread); + + url_fclose(handle); + + fclose(outf); + + + /* Test rewind */ + outf = fopen(REWINDFILE, "wb+"); + if(!outf) { + perror("couldn't open fread output file\n"); + return 1; + } + + handle = url_fopen("testfile", "r"); + if(!handle) { + printf("couldn't url_fopen() testfile\n"); + fclose(outf); + return 2; + } + + nread = url_fread(buffer, 1, sizeof(buffer), handle); + fwrite(buffer, 1, nread, outf); + url_rewind(handle); + + buffer[0]='\n'; + fwrite(buffer, 1, 1, outf); + + nread = url_fread(buffer, 1, sizeof(buffer), handle); + fwrite(buffer, 1, nread, outf); + + url_fclose(handle); + + fclose(outf); + + return 0;/* all done */ } +#endif diff --git a/src/io/fopen.h b/src/io/fopen.h index f952a65..5f87bd2 100644 --- a/src/io/fopen.h +++ b/src/io/fopen.h @@ -80,8 +80,4 @@ size_t url_fread( void *ptr, size_t size, size_t nmemb, URL_FILE * file ); char *url_fgets( char *ptr, size_t size, URL_FILE * file ); void url_rewind( URL_FILE * file ); -wint_t url_fgetwc( URL_FILE * file ); -wint_t url_ungetwc( wint_t wc, URL_FILE * input ); -URL_FILE *file_to_url_file( FILE * f ); - #endif diff --git a/src/io/io.c b/src/io/io.c index 4577a11..d7c2024 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -15,6 +15,12 @@ #include "fopen.h" #include "lispops.h" +/** + * Allow a one-character unget facility. This may not be enough - we may need + * to allocate a buffer. + */ +wint_t ungotten = 0; + /** * Convert this lisp string-like-thing (also works for symbols, and, later * keywords) into a UTF-8 string. NOTE that the returned value has been @@ -56,6 +62,129 @@ char *lisp_string_to_c_string( struct cons_pointer s ) { return result; } + +/** + * given this file handle f, return a new url_file handle wrapping it. + * + * @param f the file to be wrapped; + * @return the new handle, or null if no such handle could be allocated. + */ +URL_FILE *file_to_url_file( FILE * f ) { + URL_FILE *result = ( URL_FILE * ) malloc( sizeof( URL_FILE ) ); + + if ( result != NULL ) { + result->type = CFTYPE_FILE, result->handle.file = f; + } + + return result; +} + + +/** + * get one wide character from the buffer. + * + * @param file the stream to read from; + * @return the next wide character on the stream, or zero if no more. + */ +wint_t url_fgetwc( URL_FILE * input ) { + wint_t result = -1; + + if ( ungotten != 0 ) { + /* TODO: not thread safe */ + result = ungotten; + ungotten = 0; + } else { + switch ( input->type ) { + case CFTYPE_FILE: + fwide( input->handle.file, 1 ); /* wide characters */ + result = fgetwc( input->handle.file ); /* passthrough */ + break; + + case CFTYPE_CURL:{ + char *cbuff = + calloc( sizeof( wchar_t ) + 2, sizeof( char ) ); + wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) ); + + size_t count = 0; + + debug_print( L"url_fgetwc: about to call url_fgets\n", DEBUG_IO ); + url_fgets( cbuff, 2, input ); + debug_print( L"url_fgetwc: back from url_fgets\n", DEBUG_IO ); + int c = ( int ) cbuff[0]; + debug_printf( DEBUG_IO, + L"url_fgetwc: cbuff is '%s'; (first) character = %d (%c)\n", + cbuff, c, c & 0xf7 ); + /* The value of each individual byte indicates its UTF-8 function, as follows: + * + * 00 to 7F hex (0 to 127): first and only byte of a sequence. + * 80 to BF hex (128 to 191): continuing byte in a multi-byte sequence. + * C2 to DF hex (194 to 223): first byte of a two-byte sequence. + * E0 to EF hex (224 to 239): first byte of a three-byte sequence. + * F0 to FF hex (240 to 255): first byte of a four-byte sequence. + */ + if ( c <= 0x07 ) { + count = 1; + } else if ( c >= '0xc2' && c <= '0xdf' ) { + count = 2; + } else if ( c >= '0xe0' && c <= '0xef' ) { + count = 3; + } else if ( c >= '0xf0' && c <= '0xff' ) { + count = 4; + } + + if ( count > 1 ) { + url_fgets( (char *)&cbuff[1], count, input ); + } + mbstowcs( wbuff, cbuff, 1 ); //(char *)(&input->buffer[input->buffer_pos]), 1 ); + result = wbuff[0]; + + free( wbuff ); + free( cbuff ); + } + break; + case CFTYPE_NONE: + break; + } + } + + debug_printf( DEBUG_IO, L"url_fgetwc returning %d (%C)\n", result, + result ); + return result; +} + +wint_t url_ungetwc( wint_t wc, URL_FILE * input ) { + wint_t result = -1; + + switch ( input->type ) { + case CFTYPE_FILE: + fwide( input->handle.file, 1 ); /* wide characters */ + result = ungetwc( wc, input->handle.file ); /* passthrough */ + break; + + case CFTYPE_CURL:{ + ungotten = wc; +// wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) ); +// char *cbuff = calloc( 5, sizeof( char ) ); +// +// wbuff[0] = wc; +// result = wcstombs( cbuff, wbuff, 1 ); +// +// input->buffer_pos -= strlen( cbuff ); +// +// free( cbuff ); +// free( wbuff ); +// +// result = result > 0 ? wc : result; + break; + case CFTYPE_NONE: + break; + } + } + + return result; +} + + /** * Function, sort-of: close the file indicated by my first arg, and return * nil. If the first arg is not a stream, does nothing. All other args are @@ -172,7 +301,7 @@ lisp_slurp( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer cursor = make_string( url_fgetwc( stream ), NIL ); result = cursor; - for ( wint_t c = url_fgetwc( stream ); !url_feof( stream ); + for ( wint_t c = url_fgetwc( stream ); !url_feof( stream ) && c != 0; c = url_fgetwc( stream ) ) { debug_print( L"slurp: cursor is: ", DEBUG_IO ); debug_dump_object( cursor, DEBUG_IO ); diff --git a/src/io/io.h b/src/io/io.h index 06dcaed..d46f8b1 100644 --- a/src/io/io.h +++ b/src/io/io.h @@ -11,6 +11,10 @@ #ifndef __psse_io_h #define __psse_io_h +URL_FILE *file_to_url_file( FILE * f ); +wint_t url_fgetwc( URL_FILE * input ); +wint_t url_ungetwc( wint_t wc, URL_FILE * input ); + struct cons_pointer lisp_close( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); diff --git a/src/memory/conspage.c b/src/memory/conspage.c index 7a1a0d8..54d14e9 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -166,6 +166,10 @@ void free_cell( struct cons_pointer pointer ) { dec_ref( cell->payload.ratio.dividend ); dec_ref( cell->payload.ratio.divisor ); break; + case READTV: + case WRITETV: + url_fclose( cell->payload.stream.stream); + break; case SPECIALTV: dec_ref( cell->payload.special.source ); break; diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 4bfe6f0..1220835 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -29,9 +29,9 @@ #include "debug.h" #include "dump.h" #include "equal.h" -#include "fopen.h" #include "integer.h" #include "intern.h" +#include "io.h" #include "lispops.h" #include "print.h" #include "read.h" diff --git a/src/ops/read.c b/src/ops/read.c index 989aa67..69899c0 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -22,6 +22,7 @@ #include "dump.h" #include "integer.h" #include "intern.h" +#include "io.h" #include "lispops.h" #include "peano.h" #include "print.h"