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

Better exceptions, investigation on failure to read/print wide chars.

Browse source
This commit is contained in:
Simon Brooke 2018-12-25 15:32:45 +00:00
parent 9ff2f14c7d
commit ae8ba67ed7
13 changed files with 217 additions and 183 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
.gitignore vendored
View file

@ -28,3 +28,5 @@ log*
\.project \.project
\.settings/language\.settings\.xml \.settings/language\.settings\.xml
utils_src/readprintwc/out

8
src/arith/peano.c
View file

@ -130,7 +130,7 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1,
print( stderr, arg1 ); print( stderr, arg1 );
fputws( L"; arg2 = ", stderr ); fputws( L"; arg2 = ", stderr );
print( stderr, arg2 ); print( stderr, arg2 );
fputws( L")\n", stderr); fputws( L")\n", stderr );
#endif #endif
if ( zerop( arg1 ) ) { if ( zerop( arg1 ) ) {
@ -264,7 +264,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
print( stderr, arg1 ); print( stderr, arg1 );
fputws( L"; arg2 = ", stderr ); fputws( L"; arg2 = ", stderr );
print( stderr, arg2 ); print( stderr, arg2 );
fputws( L")\n", stderr); fputws( L")\n", stderr );
#endif #endif
if ( zerop( arg1 ) ) { if ( zerop( arg1 ) ) {
@ -406,8 +406,8 @@ struct cons_pointer inverse( struct stack_frame *frame,
case RATIOTV: case RATIOTV:
result = make_ratio( frame, result = make_ratio( frame,
make_integer( 0 - make_integer( 0 -
to_long_int( cell.payload. to_long_int( cell.payload.ratio.
ratio.dividend ) ), dividend ) ),
cell.payload.ratio.divisor ); cell.payload.ratio.divisor );
break; break;
case REALTV: case REALTV:

240
src/arith/ratio.c
View file

@ -58,27 +58,28 @@ struct cons_pointer simplify_ratio( struct stack_frame *frame,
struct cons_pointer arg ) { struct cons_pointer arg ) {
struct cons_pointer result = arg; struct cons_pointer result = arg;
if (ratiop(arg)) { if ( ratiop( arg ) ) {
int64_t ddrv = int64_t ddrv =
pointer2cell( pointer2cell( arg ).payload.ratio.dividend ). pointer2cell( pointer2cell( arg ).payload.ratio.dividend ).payload.
payload.integer.value, drrv = integer.value, drrv =
pointer2cell( pointer2cell( arg ).payload.ratio.divisor ). pointer2cell( pointer2cell( arg ).payload.ratio.divisor ).payload.
payload.integer.value, gcd = greatest_common_divisor( ddrv, drrv ); integer.value, gcd = greatest_common_divisor( ddrv, drrv );
if ( gcd > 1 ) { if ( gcd > 1 ) {
if ( drrv / gcd == 1 ) { if ( drrv / gcd == 1 ) {
result = make_integer( ddrv / gcd ); result = make_integer( ddrv / gcd );
} else { } else {
result = result =
make_ratio( frame, make_integer( ddrv / gcd ), make_ratio( frame, make_integer( ddrv / gcd ),
make_integer( drrv / gcd ) ); make_integer( drrv / gcd ) );
}
} }
} else {
result =
lisp_throw( make_cons( c_string_to_lisp_string
( "Shouldn't happen: bad arg to simplify_ratio" ),
arg ), frame );
} }
} else {
result = lisp_throw(
c_string_to_lisp_string( "Shouldn't happen: bad arg to simplify_ratio" ),
frame );
}
return result; return result;
} }
@ -100,58 +101,61 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame,
print( stderr, arg1 ); print( stderr, arg1 );
fputws( L"; arg2 = ", stderr ); fputws( L"; arg2 = ", stderr );
print( stderr, arg2 ); print( stderr, arg2 );
fputws( L")\n", stderr); fputws( L")\n", stderr );
#endif #endif
if ( ratiop(arg1) && ratiop(arg2)) { if ( ratiop( arg1 ) && ratiop( arg2 ) ) {
struct cons_space_object cell1 = pointer2cell( arg1 ); struct cons_space_object cell1 = pointer2cell( arg1 );
struct cons_space_object cell2 = pointer2cell( arg2 ); struct cons_space_object cell2 = pointer2cell( arg2 );
int64_t dd1v = int64_t dd1v =
pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value, pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value,
dd2v = dd2v =
pointer2cell( cell2.payload.ratio.dividend ).payload.integer.value, pointer2cell( cell2.payload.ratio.dividend ).payload.integer.value,
dr1v = dr1v =
pointer2cell( cell1.payload.ratio.divisor ).payload.integer.value, pointer2cell( cell1.payload.ratio.divisor ).payload.integer.value,
dr2v = dr2v =
pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value, pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value,
lcm = least_common_multiple( dr1v, dr2v ), lcm = least_common_multiple( dr1v, dr2v ),
m1 = lcm / dr1v, m2 = lcm / dr2v; m1 = lcm / dr1v, m2 = lcm / dr2v;
#ifdef DEBUG #ifdef DEBUG
fwprintf( stderr, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 ); fwprintf( stderr, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 );
#endif #endif
if ( dr1v == dr2v ) { if ( dr1v == dr2v ) {
r = make_ratio( frame, r = make_ratio( frame,
make_integer( dd1v + dd2v ), make_integer( dd1v + dd2v ),
cell1.payload.ratio.divisor ); 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 ),
r1 = make_ratio( frame, dd1vm, dr1vm ),
r2 = make_ratio( frame, dd2vm, dr2vm );
r = add_ratio_ratio( frame, r1, r2 );
/* because the references on dd1vm, dr1vm, dd2vm and dr2vm were
* never incremented except when making r1 and r2, decrementing
* r1 and r2 should be enought to garbage collect them. */
dec_ref( r1 );
dec_ref( r2 );
}
result = simplify_ratio( frame, r );
if ( !eq( r, result ) ) {
dec_ref( r );
}
} else { } else {
struct cons_pointer dd1vm = make_integer( dd1v * m1 ), result =
dr1vm = make_integer( dr1v * m1 ), lisp_throw( make_cons( c_string_to_lisp_string
dd2vm = make_integer( dd2v * m2 ), ( "Shouldn't happen: bad arg to add_ratio_ratio" ),
dr2vm = make_integer( dr2v * m2 ), make_cons( arg1,
r1 = make_ratio( frame, dd1vm, dr1vm ), make_cons( arg2, NIL ) ) ),
r2 = make_ratio( frame, dd2vm, dr2vm ); frame );
r = add_ratio_ratio( frame, r1, r2 );
/* because the references on dd1vm, dr1vm, dd2vm and dr2vm were
* never incremented except when making r1 and r2, decrementing
* r1 and r2 should be enought to garbage collect them. */
dec_ref( r1 );
dec_ref( r2 );
} }
result = simplify_ratio( frame, r );
if ( !eq( r, result ) ) {
dec_ref( r );
}
} else {
result = lisp_throw(
c_string_to_lisp_string( "Shouldn't happen: bad arg to add_ratio_ratio" ),
frame );
}
#ifdef DEBUG #ifdef DEBUG
fputws( L" => ", stderr ); fputws( L" => ", stderr );
print( stderr, result ); print( stderr, result );
@ -170,23 +174,26 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame,
struct cons_pointer add_integer_ratio( struct stack_frame *frame, struct cons_pointer add_integer_ratio( struct stack_frame *frame,
struct cons_pointer intarg, struct cons_pointer intarg,
struct cons_pointer ratarg ) { struct cons_pointer ratarg ) {
struct cons_pointer result; struct cons_pointer result;
if (integerp(intarg) && ratiop(ratarg)) { if ( integerp( intarg ) && ratiop( ratarg ) ) {
struct cons_pointer one = make_integer( 1 ), struct cons_pointer one = make_integer( 1 ),
ratio = make_ratio( frame, intarg, one ); ratio = make_ratio( frame, intarg, one );
result = add_ratio_ratio( frame, ratio, ratarg ); result = add_ratio_ratio( frame, ratio, ratarg );
dec_ref( one ); dec_ref( one );
dec_ref( ratio ); dec_ref( ratio );
} else { } else {
result = lisp_throw( result =
c_string_to_lisp_string( "Shouldn't happen: bad arg to add_integer_ratio" ), lisp_throw( make_cons( c_string_to_lisp_string
frame ); ( "Shouldn't happen: bad arg to add_integer_ratio" ),
} make_cons( intarg,
make_cons( ratarg, NIL ) ) ),
frame );
}
return result; return result;
} }
/** /**
@ -198,10 +205,10 @@ struct cons_pointer divide_ratio_ratio( struct stack_frame *frame,
struct cons_pointer arg1, struct cons_pointer arg1,
struct cons_pointer arg2 ) { struct cons_pointer arg2 ) {
struct cons_pointer i = make_ratio( frame, struct cons_pointer i = make_ratio( frame,
pointer2cell( arg2 ).payload. pointer2cell( arg2 ).payload.ratio.
ratio.divisor, divisor,
pointer2cell( arg2 ).payload. pointer2cell( arg2 ).payload.ratio.
ratio.dividend ), result = dividend ), result =
multiply_ratio_ratio( frame, arg1, i ); multiply_ratio_ratio( frame, arg1, i );
dec_ref( i ); dec_ref( i );
@ -226,33 +233,35 @@ struct cons_pointer multiply_ratio_ratio( struct
print( stderr, arg1 ); print( stderr, arg1 );
fputws( L"; arg2 = ", stderr ); fputws( L"; arg2 = ", stderr );
print( stderr, arg2 ); print( stderr, arg2 );
fputws( L")\n", stderr); fputws( L")\n", stderr );
#endif #endif
if ( ratiop(arg1) && ratiop(arg2)) { if ( ratiop( arg1 ) && ratiop( arg2 ) ) {
struct cons_space_object cell1 = pointer2cell( arg1 ); struct cons_space_object cell1 = pointer2cell( arg1 );
struct cons_space_object cell2 = pointer2cell( arg2 ); struct cons_space_object cell2 = pointer2cell( arg2 );
int64_t dd1v = int64_t dd1v =
pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value, pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value,
dd2v = dd2v =
pointer2cell( cell2.payload.ratio.dividend ).payload.integer.value, pointer2cell( cell2.payload.ratio.dividend ).payload.integer.value,
dr1v = dr1v =
pointer2cell( cell1.payload.ratio.divisor ).payload.integer.value, pointer2cell( cell1.payload.ratio.divisor ).payload.integer.value,
dr2v = dr2v =
pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value, pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value,
ddrv = dd1v * dd2v, drrv = dr1v * dr2v; ddrv = dd1v * dd2v, drrv = dr1v * dr2v;
struct cons_pointer unsimplified = make_ratio( frame, make_integer( ddrv ), struct cons_pointer unsimplified =
make_integer( drrv ) ); make_ratio( frame, make_integer( ddrv ),
result = simplify_ratio( frame, unsimplified ); make_integer( drrv ) );
result = simplify_ratio( frame, unsimplified );
if ( !eq( unsimplified, result ) ) { if ( !eq( unsimplified, result ) ) {
dec_ref( unsimplified ); dec_ref( unsimplified );
}
} else {
result =
lisp_throw( c_string_to_lisp_string
( "Shouldn't happen: bad arg to multiply_ratio_ratio" ),
frame );
} }
} else {
result = lisp_throw(
c_string_to_lisp_string( "Shouldn't happen: bad arg to multiply_ratio_ratio" ),
frame );
}
return result; return result;
} }
@ -265,20 +274,21 @@ struct cons_pointer multiply_ratio_ratio( struct
struct cons_pointer multiply_integer_ratio( struct stack_frame *frame, struct cons_pointer multiply_integer_ratio( struct stack_frame *frame,
struct cons_pointer intarg, struct cons_pointer intarg,
struct cons_pointer ratarg ) { struct cons_pointer ratarg ) {
struct cons_pointer result; struct cons_pointer result;
if (integerp(intarg) && ratiop(ratarg)) { if ( integerp( intarg ) && ratiop( ratarg ) ) {
struct cons_pointer one = make_integer( 1 ), struct cons_pointer one = make_integer( 1 ),
ratio = make_ratio( frame, intarg, one ); ratio = make_ratio( frame, intarg, one );
result = multiply_ratio_ratio( frame, ratio, ratarg ); result = multiply_ratio_ratio( frame, ratio, ratarg );
dec_ref( one ); dec_ref( one );
dec_ref( ratio ); dec_ref( ratio );
} else { } else {
result = lisp_throw( result =
c_string_to_lisp_string( "Shouldn't happen: bad arg to multiply_integer_ratio" ), lisp_throw( c_string_to_lisp_string
frame ); ( "Shouldn't happen: bad arg to multiply_integer_ratio" ),
} frame );
}
return result; return result;
} }
@ -319,8 +329,8 @@ struct cons_pointer make_ratio( struct stack_frame *frame,
} else { } else {
result = result =
lisp_throw( c_string_to_lisp_string lisp_throw( c_string_to_lisp_string
( "Dividend and divisor of a ratio must be integers" ), ( "Dividend and divisor of a ratio must be integers" ),
frame ); frame );
} }
#ifdef DEBUG #ifdef DEBUG
dump_object( stderr, result ); dump_object( stderr, result );

16
src/arith/ratio.h
View file

@ -12,37 +12,37 @@
#define __ratio_h #define __ratio_h
struct cons_pointer simplify_ratio( struct stack_frame *frame, struct cons_pointer simplify_ratio( struct stack_frame *frame,
struct cons_pointer arg ) ; struct cons_pointer arg );
struct cons_pointer add_ratio_ratio( struct stack_frame *frame, struct cons_pointer add_ratio_ratio( struct stack_frame *frame,
struct cons_pointer arg1, struct cons_pointer arg1,
struct cons_pointer arg2 ) ; struct cons_pointer arg2 );
struct cons_pointer add_integer_ratio( struct stack_frame *frame, struct cons_pointer add_integer_ratio( struct stack_frame *frame,
struct cons_pointer intarg, struct cons_pointer intarg,
struct cons_pointer ratarg ) ; struct cons_pointer ratarg );
struct cons_pointer divide_ratio_ratio( struct stack_frame *frame, struct cons_pointer divide_ratio_ratio( struct stack_frame *frame,
struct cons_pointer arg1, struct cons_pointer arg1,
struct cons_pointer arg2 ) ; struct cons_pointer arg2 );
struct cons_pointer multiply_ratio_ratio( struct struct cons_pointer multiply_ratio_ratio( struct
stack_frame stack_frame
*frame, struct *frame, struct
cons_pointer arg1, struct cons_pointer arg1, struct
cons_pointer arg2 ) ; cons_pointer arg2 );
struct cons_pointer multiply_integer_ratio( struct stack_frame *frame, struct cons_pointer multiply_integer_ratio( struct stack_frame *frame,
struct cons_pointer intarg, struct cons_pointer intarg,
struct cons_pointer ratarg ) ; struct cons_pointer ratarg );
struct cons_pointer subtract_ratio_ratio( struct stack_frame *frame, struct cons_pointer subtract_ratio_ratio( struct stack_frame *frame,
struct cons_pointer arg1, struct cons_pointer arg1,
struct cons_pointer arg2 ) ; struct cons_pointer arg2 );
struct cons_pointer make_ratio( struct stack_frame *frame, struct cons_pointer make_ratio( struct stack_frame *frame,
struct cons_pointer dividend, struct cons_pointer dividend,
struct cons_pointer divisor ) ; struct cons_pointer divisor );
#endif #endif

2
src/arith/real.c
View file

@ -26,5 +26,5 @@ struct cons_pointer make_real( long double value ) {
dump_object( stderr, result ); dump_object( stderr, result );
#endif #endif
return result; return result;
} }

1
src/init.c
View file

@ -111,6 +111,7 @@ int main( int argc, char *argv[] ) {
*/ */
bind_special( "cond", &lisp_cond ); bind_special( "cond", &lisp_cond );
bind_special( "lambda", &lisp_lambda ); bind_special( "lambda", &lisp_lambda );
/* bind_special( "λ", &lisp_lambda ); */
bind_special( "nlambda", &lisp_nlambda ); bind_special( "nlambda", &lisp_nlambda );
bind_special( "progn", &lisp_progn ); bind_special( "progn", &lisp_progn );
bind_special( "quote", &lisp_quote ); bind_special( "quote", &lisp_quote );

8
src/memory/consspaceobject.c
View file

@ -136,10 +136,10 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
case RATIOTV: case RATIOTV:
fwprintf( output, fwprintf( output,
L"\t\tRational cell: value %ld/%ld, count %u\n", L"\t\tRational cell: value %ld/%ld, count %u\n",
pointer2cell( cell.payload.ratio.dividend ). pointer2cell( cell.payload.ratio.dividend ).payload.
payload.integer.value, integer.value,
pointer2cell( cell.payload.ratio.divisor ). pointer2cell( cell.payload.ratio.divisor ).payload.
payload.integer.value, cell.count ); integer.value, cell.count );
break; break;
case READTV: case READTV:
fwprintf( output, L"\t\tInput stream\n" ); fwprintf( output, L"\t\tInput stream\n" );

4
src/ops/equal.c
View file

@ -80,8 +80,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
&& ( equal( cell_a->payload.string.cdr, && ( equal( cell_a->payload.string.cdr,
cell_b->payload.string.cdr ) cell_b->payload.string.cdr )
|| ( end_of_string( cell_a->payload.string.cdr ) || ( end_of_string( cell_a->payload.string.cdr )
&& end_of_string( cell_b->payload. && end_of_string( cell_b->payload.string.
string.cdr ) ) ); cdr ) ) );
break; break;
case INTEGERTV: case INTEGERTV:
result = result =

39
src/ops/lispops.c
View file

@ -172,7 +172,7 @@ void log_binding( struct cons_pointer name, struct cons_pointer val ) {
#ifdef DEBUG #ifdef DEBUG
fputws( L"\n\tBinding ", stderr ); fputws( L"\n\tBinding ", stderr );
print( stderr, name ); print( stderr, name );
fputws( L" to ", stderr); fputws( L" to ", stderr );
print( stderr, val ); print( stderr, val );
fputws( L"\"\n", stderr ); fputws( L"\"\n", stderr );
#endif #endif
@ -657,25 +657,25 @@ lisp_read( struct stack_frame *frame, struct cons_pointer env ) {
/** /**
* reverse a sequence. * reverse a sequence.
*/ */
struct cons_pointer c_reverse( struct cons_pointer arg) { struct cons_pointer c_reverse( struct cons_pointer arg ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
for (struct cons_pointer p = arg; sequencep(p); p = c_cdr(p)) { for ( struct cons_pointer p = arg; sequencep( p ); p = c_cdr( p ) ) {
struct cons_space_object o = pointer2cell(p); struct cons_space_object o = pointer2cell( p );
switch (o.tag.value) { switch ( o.tag.value ) {
case CONSTV: case CONSTV:
result = make_cons(o.payload.cons.car, result); result = make_cons( o.payload.cons.car, result );
break; break;
case STRINGTV: case STRINGTV:
result = make_string(o.payload.string.character, result); result = make_string( o.payload.string.character, result );
break; break;
case SYMBOLTV: case SYMBOLTV:
result = make_symbol(o.payload.string.character, result); result = make_symbol( o.payload.string.character, result );
break; break;
}
} }
}
return result; return result;
} }
@ -683,8 +683,9 @@ struct cons_pointer c_reverse( struct cons_pointer arg) {
* (reverse sequence) * (reverse sequence)
* Return a sequence like this sequence but with the members in the reverse order. * 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 env ) { struct cons_pointer lisp_reverse( struct stack_frame *frame,
return c_reverse( frame->arg[0]); struct cons_pointer env ) {
return c_reverse( frame->arg[0] );
} }

4
src/ops/lispops.h
View file

@ -40,7 +40,7 @@ struct cons_pointer c_car( struct cons_pointer arg );
*/ */
struct cons_pointer c_cdr( struct cons_pointer arg ); struct cons_pointer c_cdr( struct cons_pointer arg );
struct cons_pointer c_reverse( struct cons_pointer arg); struct cons_pointer c_reverse( struct cons_pointer arg );
/** /**
* Useful building block; evaluate this single form in the context of this * Useful building block; evaluate this single form in the context of this
@ -123,7 +123,7 @@ struct cons_pointer lisp_print( struct stack_frame *frame,
struct cons_pointer lisp_read( struct stack_frame *frame, struct cons_pointer lisp_read( struct stack_frame *frame,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer lisp_reverse( struct stack_frame *frame,
struct cons_pointer env ); struct cons_pointer env );
/** /**
* Function: Get the Lisp type of the single argument. * Function: Get the Lisp type of the single argument.
* @param frame My stack frame. * @param frame My stack frame.

15
src/ops/print.c
View file

@ -118,7 +118,12 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
case EXCEPTIONTV: case EXCEPTIONTV:
fwprintf( output, L"\n%sException: ", fwprintf( output, L"\n%sException: ",
print_use_colours ? "\x1B[31m" : "" ); print_use_colours ? "\x1B[31m" : "" );
print_string_contents( output, cell.payload.exception.message ); if ( stringp( cell.payload.exception.message ) ) {
print_string_contents( output,
cell.payload.exception.message );
} else {
print( output, cell.payload.exception.message );
}
break; break;
case FUNCTIONTV: case FUNCTIONTV:
fwprintf( output, L"(Function)" ); fwprintf( output, L"(Function)" );
@ -132,8 +137,8 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
case LAMBDATV: case LAMBDATV:
print( output, make_cons( c_string_to_lisp_symbol( "lambda" ), print( output, make_cons( c_string_to_lisp_symbol( "lambda" ),
make_cons( cell.payload.lambda.args, make_cons( cell.payload.lambda.args,
cell.payload.lambda. cell.payload.
body ) ) ); lambda.body ) ) );
break; break;
case NILTV: case NILTV:
fwprintf( output, L"nil" ); fwprintf( output, L"nil" );
@ -141,8 +146,8 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
case NLAMBDATV: case NLAMBDATV:
print( output, make_cons( c_string_to_lisp_symbol( "nlambda" ), print( output, make_cons( c_string_to_lisp_symbol( "nlambda" ),
make_cons( cell.payload.lambda.args, make_cons( cell.payload.lambda.args,
cell.payload.lambda. cell.payload.
body ) ) ); lambda.body ) ) );
break; break;
case RATIOTV: case RATIOTV:
print( output, cell.payload.ratio.dividend ); print( output, cell.payload.ratio.dividend );

44
src/ops/read.c
View file

@ -86,15 +86,15 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
case '"': case '"':
result = read_string( input, fgetwc( input ) ); result = read_string( input, fgetwc( input ) );
break; break;
case '-': { case '-':{
wint_t next = fgetwc( input ); wint_t next = fgetwc( input );
ungetwc( next, input ); ungetwc( next, input );
if ( iswdigit( next ) ) { if ( iswdigit( next ) ) {
result = read_number( frame, input, c, false ); result = read_number( frame, input, c, false );
} else { } else {
result = read_symbol( input, c ); result = read_symbol( input, c );
} }
} }
break; break;
case '.': case '.':
{ {
@ -119,11 +119,12 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
result = read_symbol( input, c ); result = read_symbol( input, c );
} else { } else {
result = result =
make_exception( c_string_to_lisp_string make_exception( make_cons( c_string_to_lisp_string
( "Unrecognised start of input character" ), ( "Unrecognised start of input character" ),
make_string( c, NIL ) ),
frame ); frame );
} }
break; break;
} }
} }
@ -142,14 +143,11 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input,
int64_t dividend = 0; int64_t dividend = 0;
int places_of_decimals = 0; int places_of_decimals = 0;
wint_t c; wint_t c;
bool negative = initial == btowc( '-'); bool negative = initial == btowc( '-' );
if (negative) { if ( negative ) {
initial = fgetwc( input ); initial = fgetwc( input );
} }
#ifdef DEBUG #ifdef DEBUG
fwprintf( stderr, L"read_number starting '%c' (%d)\n", initial, initial ); fwprintf( stderr, L"read_number starting '%c' (%d)\n", initial, initial );
#endif #endif
@ -171,7 +169,7 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input,
} else { } else {
dividend = negative ? 0 - accumulator : accumulator; dividend = negative ? 0 - accumulator : accumulator;
accumulator = 0; accumulator = 0;
} }
} else { } else {
accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' ); accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' );
@ -193,9 +191,9 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input,
if ( seen_period ) { if ( seen_period ) {
long double rv = ( long double ) long double rv = ( long double )
( accumulator / pow( 10, places_of_decimals ) ); ( accumulator / pow( 10, places_of_decimals ) );
if (negative) { if ( negative ) {
rv = 0 - rv; rv = 0 - rv;
} }
#ifdef DEBUG #ifdef DEBUG
fwprintf( stderr, L"read_numer returning %Lf\n", rv ); fwprintf( stderr, L"read_numer returning %Lf\n", rv );
#endif #endif
@ -205,9 +203,9 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input,
make_ratio( frame, make_integer( dividend ), make_ratio( frame, make_integer( dividend ),
make_integer( accumulator ) ); make_integer( accumulator ) );
} else { } else {
if (negative) { if ( negative ) {
accumulator = 0 - accumulator; accumulator = 0 - accumulator;
} }
result = make_integer( accumulator ); result = make_integer( accumulator );
} }
@ -224,15 +222,15 @@ struct cons_pointer read_list( struct
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
if ( initial != ')' ) { if ( initial != ')' ) {
#ifdef DEBUG #ifdef DEBUG
fwprintf( stderr, fwprintf( stderr,
L"read_list starting '%C' (%d)\n", initial, initial ); L"read_list starting '%C' (%d)\n", initial, initial );
#endif #endif
struct cons_pointer car = read_continuation( frame, input, struct cons_pointer car = read_continuation( frame, input,
initial ); initial );
result = make_cons( car, read_list( frame, input, fgetwc( input ) ) ); result = make_cons( car, read_list( frame, input, fgetwc( input ) ) );
} }
#ifdef DEBUG #ifdef DEBUG
else { else {
fwprintf( stderr, L"End of list detected\n" ); fwprintf( stderr, L"End of list detected\n" );
} }
#endif #endif

17
utils_src/readprintwc/readprintwc.c Normal file
View file

@ -0,0 +1,17 @@
#include <stdio.h>
#include <stdlib.h>
#include <wchar.h>
#include <wctype.h>
int main( int argc, char *argv[] ) {
fwide( stdin, 1 );
fwide( stdout, 1 );
for (wchar_t c = fgetwc( stdin ); !feof( stdin); c = fgetwc( stdin )) {
if (c != '\n') {
fwprintf( stdout, L"Read character %d, %C\t", (int)c, c);
fputwc( c, stdout);
fputws(L"\n", stdout);
}
}
}