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_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 \
-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];
if ( initialised_cons_pages == 0 && i < 3 ) {
switch ( i ) {
case 0:
/*
* initialise cell as NIL
*/
strncpy( &cell->tag.bytes[0], NILTAG, TAGLENGTH );
cell->count = MAXREFERENCE;
cell->payload.free.car = NIL;
cell->payload.free.cdr = NIL;
fwprintf( stderr, L"Allocated special cell NIL\n" );
break;
case 1:
/*
* initialise cell as T
*/
strncpy( &cell->tag.bytes[0], TRUETAG, TAGLENGTH );
cell->count = MAXREFERENCE;
cell->payload.free.car = ( struct cons_pointer ) {
0, 1
};
cell->payload.free.cdr = ( struct cons_pointer ) {
0, 1
};
fwprintf( stderr, L"Allocated special cell T\n" );
break;
case 2:
/*
* initialise cell as λ
*/
strncpy( &cell->tag.bytes[0], LAMBDATAG, TAGLENGTH );
cell->count = MAXREFERENCE;
cell->payload.string.character = ( wint_t ) L'λ';
cell->payload.free.cdr = NIL;
fwprintf( stderr, L"Allocated special cell LAMBDA\n" );
break;
case 0:
/*
* initialise cell as NIL
*/
strncpy( &cell->tag.bytes[0], NILTAG, TAGLENGTH );
cell->count = MAXREFERENCE;
cell->payload.free.car = NIL;
cell->payload.free.cdr = NIL;
fwprintf( stderr, L"Allocated special cell NIL\n" );
break;
case 1:
/*
* initialise cell as T
*/
strncpy( &cell->tag.bytes[0], TRUETAG, TAGLENGTH );
cell->count = MAXREFERENCE;
cell->payload.free.car = ( struct cons_pointer ) {
0, 1
};
cell->payload.free.cdr = ( struct cons_pointer ) {
0, 1
};
fwprintf( stderr, L"Allocated special cell T\n" );
break;
case 2:
/*
* initialise cell as λ
*/
strncpy( &cell->tag.bytes[0], LAMBDATAG, TAGLENGTH );
cell->count = MAXREFERENCE;
cell->payload.string.character = ( wint_t ) L'λ';
cell->payload.free.cdr = NIL;
fwprintf( stderr, L"Allocated special cell LAMBDA\n" );
break;
}
} 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 );
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\n",
cell.payload.cons.car.page,
cell.payload.cons.car.offset,
cell.payload.cons.cdr.page,
cell.payload.cons.cdr.offset, cell.count );
break;
case EXCEPTIONTV:
fwprintf( output, L"\t\tException cell: " );
print( output, cell.payload.exception.message );
fwprintf( output, L"\n" );
/* TODO: dump the stack trace */
for ( struct stack_frame * frame = cell.payload.exception.frame;
frame != NULL; frame = frame->previous ) {
dump_frame( output, frame );
}
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 );
break;
case INTEGERTV:
fwprintf( output,
L"\t\tInteger cell: value %ld, count %u\n",
cell.payload.integer.value, cell.count );
break;
case READTV:
fwprintf( output, L"\t\tInput stream\n" );
case REALTV:
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 );
break;
case SYMBOLTV:
dump_string_cell( output, L"Symbol", pointer );
break;
case CONSTV:
fwprintf( output,
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.offset,
cell.payload.cons.cdr.page,
cell.payload.cons.cdr.offset, cell.count );
break;
case EXCEPTIONTV:
fwprintf( output, L"\t\tException cell: " );
print( output, cell.payload.exception.message );
fwprintf( output, L"\n" );
/* TODO: dump the stack trace */
for ( struct stack_frame * frame = cell.payload.exception.frame;
frame != NULL; frame = frame->previous ) {
dump_frame( output, frame );
}
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 );
break;
case INTEGERTV:
fwprintf( output,
L"\t\tInteger cell: value %ld, count %u\n",
cell.payload.integer.value, cell.count );
break;
case READTV:
fwprintf( output, L"\t\tInput stream\n" );
case REALTV:
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 );
break;
case SYMBOLTV:
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 );
switch ( cell_a->tag.value ) {
case CONSTV:
result =
equal( cell_a->payload.cons.car, cell_b->payload.cons.car )
&& equal( cell_a->payload.cons.cdr, cell_b->payload.cons.cdr );
break;
case 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 );
case CONSTV:
result =
equal( cell_a->payload.cons.car, cell_b->payload.cons.car )
&& equal( cell_a->payload.cons.cdr,
cell_b->payload.cons.cdr );
break;
case STRINGTV:
case SYMBOLTV:
/*
* 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 );
}
break;
default:
result = false;
break;
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
*/
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 ) {
switch ( option ) {
case 'd':
dump_at_end = true;
break;
case 'p':
show_prompt = true;
break;
default:
fwprintf( stderr, L"Unexpected option %c\n", option );
break;
case 'd':
dump_at_end = true;
break;
case 'p':
show_prompt = true;
break;
default:
fwprintf( stderr, L"Unexpected option %c\n", option );
break;
}
}

139
src/lispops.c
View file

@ -96,6 +96,38 @@ struct cons_pointer eval_form( struct stack_frame *parent,
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.
@ -118,35 +150,43 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer args = c_cdr( frame->arg[0] );
switch ( fn_cell.tag.value ) {
case SPECIALTV:
{
struct stack_frame *next = make_special_frame( frame, args, env );
result = ( *fn_cell.payload.special.executable ) ( next, env );
free_stack_frame( next );
}
break;
case SPECIALTV:
{
struct stack_frame *next =
make_special_frame( frame, args, env );
result = ( *fn_cell.payload.special.executable ) ( next, env );
free_stack_frame( next );
}
break;
case FUNCTIONTV:
{
struct stack_frame *next = make_stack_frame( frame, args, env );
result = ( *fn_cell.payload.special.executable ) ( next, env );
free_stack_frame( next );
}
break;
case FUNCTIONTV:
{
struct stack_frame *next =
make_stack_frame( frame, args, env );
result = ( *fn_cell.payload.special.executable ) ( next, env );
free_stack_frame( next );
}
break;
default:
{
char *buffer = malloc( 1024 );
memset( buffer, '\0', 1024 );
sprintf( buffer,
"Unexpected cell with tag %d (%c%c%c%c) in function position",
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 );
}
case CONSTV:
{
result = lisp_lambda( frame, fn_pointer, env );
}
break;
default:
{
char *buffer = malloc( 1024 );
memset( buffer, '\0', 1024 );
sprintf( buffer,
"Unexpected cell with tag %d (%c%c%c%c) in function position",
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;
@ -193,30 +233,31 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
dump_frame( stderr, frame );
switch ( cell.tag.value ) {
case CONSTV:
result = c_apply( frame, env );
break;
case CONSTV:
result = c_apply( frame, env );
break;
case SYMBOLTV:
{
struct cons_pointer canonical = internedp( frame->arg[0], env );
if ( nilp( canonical ) ) {
struct cons_pointer message =
c_string_to_lisp_string
( "Attempt to take value of unbound symbol." );
result = lisp_throw( message, frame );
} else {
result = c_assoc( canonical, env );
case SYMBOLTV:
{
struct cons_pointer canonical =
internedp( frame->arg[0], env );
if ( nilp( canonical ) ) {
struct cons_pointer message =
c_string_to_lisp_string
( "Attempt to take value of unbound symbol." );
result = lisp_throw( message, frame );
} else {
result = c_assoc( canonical, env );
}
}
}
break;
/*
* 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.
*/
break;
/*
* 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.
*/
}
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] );
switch ( current.tag.value ) {
case INTEGERTV:
i_accumulator += current.payload.integer.value;
d_accumulator += numeric_value( frame->arg[i] );
break;
case REALTV:
d_accumulator += current.payload.real.value;
is_int = false;
break;
default:
lisp_throw( c_string_to_lisp_string( "Cannot add: not a number" ),
frame );
case INTEGERTV:
i_accumulator += current.payload.integer.value;
d_accumulator += numeric_value( frame->arg[i] );
break;
case REALTV:
d_accumulator += current.payload.real.value;
is_int = false;
break;
default:
lisp_throw( c_string_to_lisp_string
( "Cannot add: not a number" ), frame );
}
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] );
switch ( arg.tag.value ) {
case INTEGERTV:
i_accumulator *= arg.payload.integer.value;
d_accumulator *= numeric_value( frame->arg[i] );
break;
case REALTV:
d_accumulator *= arg.payload.real.value;
is_int = false;
break;
default:
lisp_throw( c_string_to_lisp_string
( "Cannot multiply: not a number" ), frame );
case INTEGERTV:
i_accumulator *= arg.payload.integer.value;
d_accumulator *= numeric_value( frame->arg[i] );
break;
case REALTV:
d_accumulator *= arg.payload.real.value;
is_int = false;
break;
default:
lisp_throw( c_string_to_lisp_string
( "Cannot multiply: not a number" ), frame );
}
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 );
switch ( cell->tag.value ) {
case CONSTV:
if ( initial_space ) {
fputwc( btowc( ' ' ), output );
}
print( output, cell->payload.cons.car );
case CONSTV:
if ( initial_space ) {
fputwc( btowc( ' ' ), output );
}
print( output, cell->payload.cons.car );
print_list_contents( output, cell->payload.cons.cdr, true );
break;
case NILTV:
break;
default:
fwprintf( output, L" . " );
print( output, pointer );
print_list_contents( output, cell->payload.cons.cdr, true );
break;
case NILTV:
break;
default:
fwprintf( output, L" . " );
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.
*/
switch ( cell.tag.value ) {
case CONSTV:
print_list( output, pointer );
break;
case EXCEPTIONTV:
fwprintf( output, L"\nException: " );
print_string_contents( output, cell.payload.exception.message );
break;
case INTEGERTV:
fwprintf( output, L"%ld", cell.payload.integer.value );
break;
case LAMBDATV:
fwprintf( output, L"lambda" /* "λ" */ );
break;
case NILTV:
fwprintf( output, L"nil" );
break;
case REALTV:
/* 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 );
memset( buffer, 0, 24 );
/* format it really long, then clear the trailing zeros */
sprintf( buffer, "%-.23Lg", cell.payload.real.value );
if ( strchr( buffer, '.' ) != NULL ) {
for ( int i = strlen( buffer ) - 1; buffer[i] == '0'; i-- ) {
buffer[i] = '\0';
case CONSTV:
print_list( output, pointer );
break;
case EXCEPTIONTV:
fwprintf( output, L"\nException: " );
print_string_contents( output, cell.payload.exception.message );
break;
case INTEGERTV:
fwprintf( output, L"%ld", cell.payload.integer.value );
break;
case LAMBDATV:
fwprintf( output, L"lambda" /* "λ" */ );
break;
case NILTV:
fwprintf( output, L"nil" );
break;
case REALTV:
/* 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 );
memset( buffer, 0, 24 );
/* format it really long, then clear the trailing zeros */
sprintf( buffer, "%-.23Lg", cell.payload.real.value );
if ( strchr( buffer, '.' ) != NULL ) {
for ( int i = strlen( buffer ) - 1; buffer[i] == '0'; i-- ) {
buffer[i] = '\0';
}
}
}
fwprintf( output, L"%s", buffer );
free( buffer );
break;
case STRINGTV:
print_string( output, pointer );
break;
case SYMBOLTV:
print_string_contents( output, pointer );
break;
case TRUETV:
fwprintf( output, L"t" );
break;
case FUNCTIONTV:
fwprintf( output, L"(Function)" );
break;
case SPECIALTV:
fwprintf( output, L"(Special form)" );
break;
default:
fwprintf( stderr,
L"Error: Unrecognised tag value %d (%c%c%c%c)\n",
cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1],
cell.tag.bytes[2], cell.tag.bytes[3] );
break;
fwprintf( output, L"%s", buffer );
free( buffer );
break;
case STRINGTV:
print_string( output, pointer );
break;
case SYMBOLTV:
print_string_contents( output, pointer );
break;
case TRUETV:
fwprintf( output, L"t" );
break;
case FUNCTIONTV:
fwprintf( output, L"(Function)" );
break;
case SPECIALTV:
fwprintf( output, L"(Special form)" );
break;
default:
fwprintf( stderr,
L"Error: Unrecognised tag value %d (%c%c%c%c)\n",
cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1],
cell.tag.bytes[2], cell.tag.bytes[3] );
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 ) );
switch ( c ) {
case EOF:
result = lisp_throw( c_string_to_lisp_string
( "End of input while reading" ), frame );
break;
case '\'':
result = c_quote( read_continuation( frame, input, fgetwc( input ) ) );
break;
case '(':
result = read_list( frame, input, fgetwc( input ) );
break;
case '"':
result = read_string( input, fgetwc( input ) );
break;
default:
if ( c == '.' ) {
wint_t next = fgetwc( input );
if ( iswdigit( next ) ) {
ungetwc( next, input );
case EOF:
result = lisp_throw( c_string_to_lisp_string
( "End of input while reading" ), frame );
break;
case '\'':
result =
c_quote( read_continuation( frame, input, fgetwc( input ) ) );
break;
case '(':
result = read_list( frame, input, fgetwc( input ) );
break;
case '"':
result = read_string( input, fgetwc( input ) );
break;
default:
if ( c == '.' ) {
wint_t next = fgetwc( 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 );
} 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 if ( iswprint( c ) ) {
result = read_symbol( input, c );
} 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;
@ -177,15 +179,16 @@ struct cons_pointer read_string( FILE * input, wint_t initial ) {
struct cons_pointer result;
switch ( initial ) {
case '\0':
result = make_string( initial, NIL );
break;
case '"':
result = make_string( '\0', NIL );
break;
default:
result = make_string( initial, read_string( input, fgetwc( input ) ) );
break;
case '\0':
result = make_string( initial, NIL );
break;
case '"':
result = make_string( '\0', NIL );
break;
default:
result =
make_string( initial, read_string( input, fgetwc( input ) ) );
break;
}
return result;
@ -196,37 +199,39 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
struct cons_pointer result;
switch ( initial ) {
case '\0':
result = make_symbol( initial, NIL );
break;
case '"':
/*
* 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 ) ) {
case '\0':
result = make_symbol( initial, NIL );
break;
case '"':
/*
* THIS IS NOT A GOOD IDEA, but is legal
*/
result =
make_symbol( initial, read_symbol( input, fgetwc( input ) ) );
} else {
result = NIL;
break;
case ')':
/*
* unquoted strings may not include right-parenthesis
*/
result = make_symbol( '\0', NIL );
/*
* push back the character read
*/
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 );