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

Improved (for me) formatting on Mac

Browse source 
Don't yet know whether this will work on Linux.
This commit is contained in:
Simon Brooke 2018-12-08 14:09:57 +00:00
parent 27fd678888
commit 9bfc9074b0
9 changed files with 368 additions and 319 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Makefile
View file

@ -11,7 +11,7 @@ TESTS := $(shell find unit-tests -name *.sh)
INC_DIRS := $(shell find $(SRC_DIRS) -type d) INC_DIRS := $(shell find $(SRC_DIRS) -type d)
INC_FLAGS := $(addprefix -I,$(INC_DIRS)) INC_FLAGS := $(addprefix -I,$(INC_DIRS))
INDENT_FLAGS := -nbad -bap -nbc -br -brf -brs -c33 -cd33 -ncdb -ce -ci4 -cli0 \ INDENT_FLAGS := -nbad -bap -nbc -br -brf -brs -c33 -cd33 -ncdb -ce -ci4 -cli4 \
-d0 -di1 -nfc1 -i4 -ip0 -l75 -lp -npcs \ -d0 -di1 -nfc1 -i4 -ip0 -l75 -lp -npcs \
-npsl -nsc -nsob -nss -nut -prs -l79 -ts2 -npsl -nsc -nsob -nss -nut -prs -l79 -ts2

68
src/conspage.c
View file

@ -56,40 +56,40 @@ void make_cons_page( ) {
&conspages[initialised_cons_pages]->cell[i]; &conspages[initialised_cons_pages]->cell[i];
if ( initialised_cons_pages == 0 && i < 3 ) { if ( initialised_cons_pages == 0 && i < 3 ) {
switch ( i ) { switch ( i ) {
case 0: case 0:
/* /*
* initialise cell as NIL * initialise cell as NIL
*/ */
strncpy( &cell->tag.bytes[0], NILTAG, TAGLENGTH ); strncpy( &cell->tag.bytes[0], NILTAG, TAGLENGTH );
cell->count = MAXREFERENCE; cell->count = MAXREFERENCE;
cell->payload.free.car = NIL; cell->payload.free.car = NIL;
cell->payload.free.cdr = NIL; cell->payload.free.cdr = NIL;
fwprintf( stderr, L"Allocated special cell NIL\n" ); fwprintf( stderr, L"Allocated special cell NIL\n" );
break; break;
case 1: case 1:
/* /*
* initialise cell as T * initialise cell as T
*/ */
strncpy( &cell->tag.bytes[0], TRUETAG, TAGLENGTH ); strncpy( &cell->tag.bytes[0], TRUETAG, TAGLENGTH );
cell->count = MAXREFERENCE; cell->count = MAXREFERENCE;
cell->payload.free.car = ( struct cons_pointer ) { cell->payload.free.car = ( struct cons_pointer ) {
0, 1 0, 1
}; };
cell->payload.free.cdr = ( struct cons_pointer ) { cell->payload.free.cdr = ( struct cons_pointer ) {
0, 1 0, 1
}; };
fwprintf( stderr, L"Allocated special cell T\n" ); fwprintf( stderr, L"Allocated special cell T\n" );
break; break;
case 2: case 2:
/* /*
* initialise cell as λ * initialise cell as λ
*/ */
strncpy( &cell->tag.bytes[0], LAMBDATAG, TAGLENGTH ); strncpy( &cell->tag.bytes[0], LAMBDATAG, TAGLENGTH );
cell->count = MAXREFERENCE; cell->count = MAXREFERENCE;
cell->payload.string.character = ( wint_t ) L'λ'; cell->payload.string.character = ( wint_t ) L'λ';
cell->payload.free.cdr = NIL; cell->payload.free.cdr = NIL;
fwprintf( stderr, L"Allocated special cell LAMBDA\n" ); fwprintf( stderr, L"Allocated special cell LAMBDA\n" );
break; break;
} }
} else { } else {
/* /*

79
src/consspaceobject.c
View file

@ -100,45 +100,46 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
cell.tag.value, pointer.page, pointer.offset, cell.count ); cell.tag.value, pointer.page, pointer.offset, cell.count );
switch ( cell.tag.value ) { switch ( cell.tag.value ) {
case CONSTV: case CONSTV:
fwprintf( output, fwprintf( output,
L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u\n", L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u\n",
cell.payload.cons.car.page, cell.payload.cons.car.page,
cell.payload.cons.car.offset, cell.payload.cons.car.offset,
cell.payload.cons.cdr.page, cell.payload.cons.cdr.page,
cell.payload.cons.cdr.offset, cell.count ); cell.payload.cons.cdr.offset, cell.count );
break; break;
case EXCEPTIONTV: case EXCEPTIONTV:
fwprintf( output, L"\t\tException cell: " ); fwprintf( output, L"\t\tException cell: " );
print( output, cell.payload.exception.message ); print( output, cell.payload.exception.message );
fwprintf( output, L"\n" ); fwprintf( output, L"\n" );
/* TODO: dump the stack trace */ /* TODO: dump the stack trace */
for ( struct stack_frame * frame = cell.payload.exception.frame; for ( struct stack_frame * frame = cell.payload.exception.frame;
frame != NULL; frame = frame->previous ) { frame != NULL; frame = frame->previous ) {
dump_frame( output, frame ); dump_frame( output, frame );
} }
break; break;
case FREETV: case FREETV:
fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n", fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n",
cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset ); cell.payload.cons.cdr.page,
break; cell.payload.cons.cdr.offset );
case INTEGERTV: break;
fwprintf( output, case INTEGERTV:
L"\t\tInteger cell: value %ld, count %u\n", fwprintf( output,
cell.payload.integer.value, cell.count ); L"\t\tInteger cell: value %ld, count %u\n",
break; cell.payload.integer.value, cell.count );
case READTV: break;
fwprintf( output, L"\t\tInput stream\n" ); case READTV:
case REALTV: fwprintf( output, L"\t\tInput stream\n" );
fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n", case REALTV:
cell.payload.real.value, cell.count ); fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n",
break; cell.payload.real.value, cell.count );
case STRINGTV: break;
dump_string_cell( output, L"String", pointer ); case STRINGTV:
break; dump_string_cell( output, L"String", pointer );
case SYMBOLTV: break;
dump_string_cell( output, L"Symbol", pointer ); case SYMBOLTV:
break; dump_string_cell( output, L"Symbol", pointer );
break;
} }
} }

74
src/equal.c
View file

@ -59,44 +59,46 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
struct cons_space_object *cell_b = &pointer2cell( b ); struct cons_space_object *cell_b = &pointer2cell( b );
switch ( cell_a->tag.value ) { switch ( cell_a->tag.value ) {
case CONSTV: case CONSTV:
result = result =
equal( cell_a->payload.cons.car, cell_b->payload.cons.car ) equal( cell_a->payload.cons.car, cell_b->payload.cons.car )
&& equal( cell_a->payload.cons.cdr, cell_b->payload.cons.cdr ); && equal( cell_a->payload.cons.cdr,
break; cell_b->payload.cons.cdr );
case STRINGTV: break;
case SYMBOLTV: case STRINGTV:
/* case SYMBOLTV:
* slightly complex because a string may or may not have a '\0'
* cell at the end, but I'll ignore that for now. I think in
* practice only the empty string will.
*/
result =
cell_a->payload.string.character ==
cell_b->payload.string.character
&& ( equal( cell_a->payload.string.cdr,
cell_b->payload.string.cdr )
|| ( end_of_string( cell_a->payload.string.cdr )
&& end_of_string( cell_b->payload.string.cdr ) ) );
break;
case INTEGERTV:
case REALTV:
{
double num_a = numeric_value( a );
double num_b = numeric_value( b );
double max =
fabs( num_a ) >
fabs( num_b ) ? fabs( num_a ) : fabs( num_b );
/* /*
* not more different than one part in a million - close enough * slightly complex because a string may or may not have a '\0'
* cell at the end, but I'll ignore that for now. I think in
* practice only the empty string will.
*/ */
result = fabs( num_a - num_b ) < ( max / 1000000.0 ); result =
} cell_a->payload.string.character ==
break; cell_b->payload.string.character
default: && ( equal( cell_a->payload.string.cdr,
result = false; cell_b->payload.string.cdr )
break; || ( end_of_string( cell_a->payload.string.cdr )
&& end_of_string( cell_b->payload.string.
cdr ) ) );
break;
case INTEGERTV:
case REALTV:
{
double num_a = numeric_value( a );
double num_b = numeric_value( b );
double max =
fabs( num_a ) >
fabs( num_b ) ? fabs( num_a ) : fabs( num_b );
/*
* not more different than one part in a million - close enough
*/
result = fabs( num_a - num_b ) < ( max / 1000000.0 );
}
break;
default:
result = false;
break;
} }
/* /*

18
src/init.c
View file

@ -48,15 +48,15 @@ int main( int argc, char *argv[] ) {
while ( ( option = getopt( argc, argv, "pd" ) ) != -1 ) { while ( ( option = getopt( argc, argv, "pd" ) ) != -1 ) {
switch ( option ) { switch ( option ) {
case 'd': case 'd':
dump_at_end = true; dump_at_end = true;
break; break;
case 'p': case 'p':
show_prompt = true; show_prompt = true;
break; break;
default: default:
fwprintf( stderr, L"Unexpected option %c\n", option ); fwprintf( stderr, L"Unexpected option %c\n", option );
break; break;
} }
} }

139
src/lispops.c
View file

@ -96,6 +96,38 @@ struct cons_pointer eval_form( struct stack_frame *parent,
return result; return result;
} }
/**
* The Lisp interpreter.
*
* @param frame the stack frame in which the expression is to be interpreted;
* @param lexpr the lambda expression to be interpreted;
* @param env the environment in which it is to be intepreted.
*/
struct cons_pointer
lisp_lambda( struct stack_frame *frame, struct cons_pointer lexpr,
struct cons_pointer env ) {
struct cons_pointer result = NIL;
struct cons_pointer should_be_lambda =
eval_form( frame, c_car( lexpr ), env );
if ( lambdap( should_be_lambda ) ) {
struct cons_pointer new_env = env;
} else {
char *buffer = malloc( 1024 );
memset( buffer, '\0', 1024 );
sprintf( buffer,
"Expected lambda, but found cell with tag %d (%c%c%c%c)",
fn_cell.tag.value, fn_cell.tag.bytes[0],
fn_cell.tag.bytes[1], fn_cell.tag.bytes[2],
fn_cell.tag.bytes[3] );
struct cons_pointer message = c_string_to_lisp_string( buffer );
free( buffer );
result = lisp_throw( message, frame );
}
return result;
}
/** /**
* Internal guts of apply. * Internal guts of apply.
@ -118,35 +150,43 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer args = c_cdr( frame->arg[0] ); struct cons_pointer args = c_cdr( frame->arg[0] );
switch ( fn_cell.tag.value ) { switch ( fn_cell.tag.value ) {
case SPECIALTV: case SPECIALTV:
{ {
struct stack_frame *next = make_special_frame( frame, args, env ); struct stack_frame *next =
result = ( *fn_cell.payload.special.executable ) ( next, env ); make_special_frame( frame, args, env );
free_stack_frame( next ); result = ( *fn_cell.payload.special.executable ) ( next, env );
} free_stack_frame( next );
break; }
break;
case FUNCTIONTV: case FUNCTIONTV:
{ {
struct stack_frame *next = make_stack_frame( frame, args, env ); struct stack_frame *next =
result = ( *fn_cell.payload.special.executable ) ( next, env ); make_stack_frame( frame, args, env );
free_stack_frame( next ); result = ( *fn_cell.payload.special.executable ) ( next, env );
} free_stack_frame( next );
break; }
break;
default: case CONSTV:
{ {
char *buffer = malloc( 1024 ); result = lisp_lambda( frame, fn_pointer, env );
memset( buffer, '\0', 1024 ); }
sprintf( buffer, break;
"Unexpected cell with tag %d (%c%c%c%c) in function position", default:
fn_cell.tag.value, fn_cell.tag.bytes[0], {
fn_cell.tag.bytes[1], fn_cell.tag.bytes[2], char *buffer = malloc( 1024 );
fn_cell.tag.bytes[3] ); memset( buffer, '\0', 1024 );
struct cons_pointer message = c_string_to_lisp_string( buffer ); sprintf( buffer,
free( buffer ); "Unexpected cell with tag %d (%c%c%c%c) in function position",
result = lisp_throw( message, frame ); fn_cell.tag.value, fn_cell.tag.bytes[0],
} fn_cell.tag.bytes[1], fn_cell.tag.bytes[2],
fn_cell.tag.bytes[3] );
struct cons_pointer message =
c_string_to_lisp_string( buffer );
free( buffer );
result = lisp_throw( message, frame );
}
} }
return result; return result;
@ -193,30 +233,31 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
dump_frame( stderr, frame ); dump_frame( stderr, frame );
switch ( cell.tag.value ) { switch ( cell.tag.value ) {
case CONSTV: case CONSTV:
result = c_apply( frame, env ); result = c_apply( frame, env );
break; break;
case SYMBOLTV: case SYMBOLTV:
{ {
struct cons_pointer canonical = internedp( frame->arg[0], env ); struct cons_pointer canonical =
if ( nilp( canonical ) ) { internedp( frame->arg[0], env );
struct cons_pointer message = if ( nilp( canonical ) ) {
c_string_to_lisp_string struct cons_pointer message =
( "Attempt to take value of unbound symbol." ); c_string_to_lisp_string
result = lisp_throw( message, frame ); ( "Attempt to take value of unbound symbol." );
} else { result = lisp_throw( message, frame );
result = c_assoc( canonical, env ); } else {
result = c_assoc( canonical, env );
}
} }
} break;
break; /*
/* * the Clojure practice of having a map serve in the function place of
* 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
* 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
* 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
* long run I don't want an interpreter, and if I can get away without * so much the better.
* so much the better. */
*/
} }
fputws( L"Eval returning ", stderr ); fputws( L"Eval returning ", stderr );

44
src/peano.c
View file

@ -42,17 +42,17 @@ lisp_add( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_space_object current = pointer2cell( frame->arg[i] ); struct cons_space_object current = pointer2cell( frame->arg[i] );
switch ( current.tag.value ) { switch ( current.tag.value ) {
case INTEGERTV: case INTEGERTV:
i_accumulator += current.payload.integer.value; i_accumulator += current.payload.integer.value;
d_accumulator += numeric_value( frame->arg[i] ); d_accumulator += numeric_value( frame->arg[i] );
break; break;
case REALTV: case REALTV:
d_accumulator += current.payload.real.value; d_accumulator += current.payload.real.value;
is_int = false; is_int = false;
break; break;
default: default:
lisp_throw( c_string_to_lisp_string( "Cannot add: not a number" ), lisp_throw( c_string_to_lisp_string
frame ); ( "Cannot add: not a number" ), frame );
} }
if ( !nilp( frame->more ) ) { if ( !nilp( frame->more ) ) {
@ -87,17 +87,17 @@ lisp_multiply( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_space_object arg = pointer2cell( frame->arg[i] ); struct cons_space_object arg = pointer2cell( frame->arg[i] );
switch ( arg.tag.value ) { switch ( arg.tag.value ) {
case INTEGERTV: case INTEGERTV:
i_accumulator *= arg.payload.integer.value; i_accumulator *= arg.payload.integer.value;
d_accumulator *= numeric_value( frame->arg[i] ); d_accumulator *= numeric_value( frame->arg[i] );
break; break;
case REALTV: case REALTV:
d_accumulator *= arg.payload.real.value; d_accumulator *= arg.payload.real.value;
is_int = false; is_int = false;
break; break;
default: default:
lisp_throw( c_string_to_lisp_string lisp_throw( c_string_to_lisp_string
( "Cannot multiply: not a number" ), frame ); ( "Cannot multiply: not a number" ), frame );
} }
if ( !nilp( frame->more ) ) { if ( !nilp( frame->more ) ) {

128
src/print.c
View file

@ -49,19 +49,19 @@ print_list_contents( FILE * output, struct cons_pointer pointer,
struct cons_space_object *cell = &pointer2cell( pointer ); struct cons_space_object *cell = &pointer2cell( pointer );
switch ( cell->tag.value ) { switch ( cell->tag.value ) {
case CONSTV: case CONSTV:
if ( initial_space ) { if ( initial_space ) {
fputwc( btowc( ' ' ), output ); fputwc( btowc( ' ' ), output );
} }
print( output, cell->payload.cons.car ); print( output, cell->payload.cons.car );
print_list_contents( output, cell->payload.cons.cdr, true ); print_list_contents( output, cell->payload.cons.cdr, true );
break; break;
case NILTV: case NILTV:
break; break;
default: default:
fwprintf( output, L" . " ); fwprintf( output, L" . " );
print( output, pointer ); print( output, pointer );
} }
} }
@ -80,58 +80,58 @@ void print( FILE * output, struct cons_pointer pointer ) {
* statement can ultimately be replaced by a switch, which will be neater. * statement can ultimately be replaced by a switch, which will be neater.
*/ */
switch ( cell.tag.value ) { switch ( cell.tag.value ) {
case CONSTV: case CONSTV:
print_list( output, pointer ); print_list( output, pointer );
break; break;
case EXCEPTIONTV: case EXCEPTIONTV:
fwprintf( output, L"\nException: " ); fwprintf( output, L"\nException: " );
print_string_contents( output, cell.payload.exception.message ); print_string_contents( output, cell.payload.exception.message );
break; break;
case INTEGERTV: case INTEGERTV:
fwprintf( output, L"%ld", cell.payload.integer.value ); fwprintf( output, L"%ld", cell.payload.integer.value );
break; break;
case LAMBDATV: case LAMBDATV:
fwprintf( output, L"lambda" /* "λ" */ ); fwprintf( output, L"lambda" /* "λ" */ );
break; break;
case NILTV: case NILTV:
fwprintf( output, L"nil" ); fwprintf( output, L"nil" );
break; break;
case REALTV: 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 * As soon as I have working vector space I'll use a special purpose
* vector space object */ * vector space object */
buffer = ( char * ) malloc( 24 ); buffer = ( char * ) malloc( 24 );
memset( buffer, 0, 24 ); memset( buffer, 0, 24 );
/* format it really long, then clear the trailing zeros */ /* format it really long, then clear the trailing zeros */
sprintf( buffer, "%-.23Lg", cell.payload.real.value ); sprintf( buffer, "%-.23Lg", cell.payload.real.value );
if ( strchr( buffer, '.' ) != NULL ) { if ( strchr( buffer, '.' ) != NULL ) {
for ( int i = strlen( buffer ) - 1; buffer[i] == '0'; i-- ) { for ( int i = strlen( buffer ) - 1; buffer[i] == '0'; i-- ) {
buffer[i] = '\0'; buffer[i] = '\0';
}
} }
} fwprintf( output, L"%s", buffer );
fwprintf( output, L"%s", buffer ); free( buffer );
free( buffer ); break;
break; case STRINGTV:
case STRINGTV: print_string( output, pointer );
print_string( output, pointer ); break;
break; case SYMBOLTV:
case SYMBOLTV: print_string_contents( output, pointer );
print_string_contents( output, pointer ); break;
break; case TRUETV:
case TRUETV: fwprintf( output, L"t" );
fwprintf( output, L"t" ); break;
break; case FUNCTIONTV:
case FUNCTIONTV: fwprintf( output, L"(Function)" );
fwprintf( output, L"(Function)" ); break;
break; case SPECIALTV:
case SPECIALTV: fwprintf( output, L"(Special form)" );
fwprintf( output, L"(Special form)" ); break;
break; default:
default: fwprintf( stderr,
fwprintf( stderr, L"Error: Unrecognised tag value %d (%c%c%c%c)\n",
L"Error: Unrecognised tag value %d (%c%c%c%c)\n", cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1],
cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1], cell.tag.bytes[2], cell.tag.bytes[3] );
cell.tag.bytes[2], cell.tag.bytes[3] ); break;
break;
} }
} }

135
src/read.c
View file

@ -60,40 +60,42 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
c == '\0' || iswblank( c ) || iswcntrl( c ); c = fgetwc( input ) ); c == '\0' || iswblank( c ) || iswcntrl( c ); c = fgetwc( input ) );
switch ( c ) { switch ( c ) {
case EOF: case EOF:
result = lisp_throw( c_string_to_lisp_string result = lisp_throw( c_string_to_lisp_string
( "End of input while reading" ), frame ); ( "End of input while reading" ), frame );
break; break;
case '\'': case '\'':
result = c_quote( read_continuation( frame, input, fgetwc( input ) ) ); result =
break; c_quote( read_continuation( frame, input, fgetwc( input ) ) );
case '(': break;
result = read_list( frame, input, fgetwc( input ) ); case '(':
break; result = read_list( frame, input, fgetwc( input ) );
case '"': break;
result = read_string( input, fgetwc( input ) ); case '"':
break; result = read_string( input, fgetwc( input ) );
default: break;
if ( c == '.' ) { default:
wint_t next = fgetwc( input ); if ( c == '.' ) {
if ( iswdigit( next ) ) { wint_t next = fgetwc( input );
ungetwc( next, input ); if ( iswdigit( next ) ) {
ungetwc( next, input );
result = read_number( input, c );
} else if ( iswblank( next ) ) {
/* dotted pair. TODO: this isn't right, we
* really need to backtrack up a level. */
result =
read_continuation( frame, input, fgetwc( input ) );
} else {
read_symbol( input, c );
}
} else if ( iswdigit( c ) ) {
result = read_number( input, c ); result = read_number( input, c );
} else if ( iswblank( next ) ) { } else if ( iswprint( c ) ) {
/* dotted pair. TODO: this isn't right, we result = read_symbol( input, c );
* really need to backtrack up a level. */
result = read_continuation( frame, input, fgetwc( input ) );
} else { } else {
read_symbol( input, c ); fwprintf( stderr,
L"Unrecognised start of input character %c\n", c );
} }
} else if ( iswdigit( c ) ) {
result = read_number( input, c );
} else if ( iswprint( c ) ) {
result = read_symbol( input, c );
} else {
fwprintf( stderr, L"Unrecognised start of input character %c\n",
c );
}
} }
return result; return result;
@ -177,15 +179,16 @@ struct cons_pointer read_string( FILE * input, wint_t initial ) {
struct cons_pointer result; struct cons_pointer result;
switch ( initial ) { switch ( initial ) {
case '\0': case '\0':
result = make_string( initial, NIL ); result = make_string( initial, NIL );
break; break;
case '"': case '"':
result = make_string( '\0', NIL ); result = make_string( '\0', NIL );
break; break;
default: default:
result = make_string( initial, read_string( input, fgetwc( input ) ) ); result =
break; make_string( initial, read_string( input, fgetwc( input ) ) );
break;
} }
return result; return result;
@ -196,37 +199,39 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
struct cons_pointer result; struct cons_pointer result;
switch ( initial ) { switch ( initial ) {
case '\0': case '\0':
result = make_symbol( initial, NIL ); result = make_symbol( initial, NIL );
break; break;
case '"': case '"':
/* /*
* THIS IS NOT A GOOD IDEA, but is legal * THIS IS NOT A GOOD IDEA, but is legal
*/ */
result = make_symbol( initial, read_symbol( input, fgetwc( input ) ) );
break;
case ')':
/*
* unquoted strings may not include right-parenthesis
*/
result = make_symbol( '\0', NIL );
/*
* push back the character read
*/
ungetwc( initial, input );
break;
default:
if ( iswprint( initial ) && !iswblank( initial ) ) {
result = result =
make_symbol( initial, read_symbol( input, fgetwc( input ) ) ); make_symbol( initial, read_symbol( input, fgetwc( input ) ) );
} else { break;
result = NIL; case ')':
/*
* unquoted strings may not include right-parenthesis
*/
result = make_symbol( '\0', NIL );
/* /*
* push back the character read * push back the character read
*/ */
ungetwc( initial, input ); ungetwc( initial, input );
} break;
break; default:
if ( iswprint( initial ) && !iswblank( initial ) ) {
result =
make_symbol( initial,
read_symbol( input, fgetwc( input ) ) );
} else {
result = NIL;
/*
* push back the character read
*/
ungetwc( initial, input );
}
break;
} }
fputws( L"Read symbol '", stderr ); fputws( L"Read symbol '", stderr );