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

All tests passing except 'apply', which is genuinely broken; I'm not yet sure

Browse source 
what's wrong.
This commit is contained in:
Simon Brooke 2017-10-15 14:17:54 +01:00
parent f988147bb2
commit ba4a31c25a
7 changed files with 59 additions and 31 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

22
src/conspage.c
View file

@ -90,8 +90,8 @@ void make_cons_page( ) {
initialised_cons_pages++;
} else {
fprintf( stderr,
"FATAL: Failed to allocate memory for cons page %d\n",
fwprintf( stderr,
L"FATAL: Failed to allocate memory for cons page %d\n",
initialised_cons_pages );
exit( 1 );
}
@ -103,7 +103,7 @@ void make_cons_page( ) {
*/
void dump_pages( FILE * output ) {
for ( int i = 0; i < initialised_cons_pages; i++ ) {
fprintf( output, "\nDUMPING PAGE %d\n", i );
fwprintf( output, L"\nDUMPING PAGE %d\n", i );
for ( int j = 0; j < CONSPAGESIZE; j++ ) {
dump_object( output, ( struct cons_pointer ) {
@ -123,18 +123,20 @@ void free_cell( struct cons_pointer pointer ) {
if ( !check_tag( pointer, FREETAG ) ) {
if ( cell->count == 0 ) {
fwprintf( stderr, L"Freeing cell\n" );
dump_object( stderr, pointer );
strncpy( &cell->tag.bytes[0], FREETAG, 4 );
cell->payload.free.car = NIL;
cell->payload.free.cdr = freelist;
freelist = pointer;
} else {
fprintf( stderr,
"Attempt to free cell with %d dangling references at page %d, offset %d\n",
fwprintf( stderr,
L"Attempt to free cell with %d dangling references at page %d, offset %d\n",
cell->count, pointer.page, pointer.offset );
}
} else {
fprintf( stderr,
"Attempt to free cell which is already FREE at page %d, offset %d\n",
fwprintf( stderr,
L"Attempt to free cell which is already FREE at page %d, offset %d\n",
pointer.page, pointer.offset );
}
}
@ -166,12 +168,12 @@ struct cons_pointer allocate_cell( char *tag ) {
cell->payload.cons.cdr = NIL;
#ifdef DEBUG
fprintf( stderr,
"Allocated cell of type '%s' at %d, %d \n", tag,
fwprintf( stderr,
L"Allocated cell of type '%s' at %d, %d \n", tag,
result.page, result.offset );
#endif
} else {
fprintf( stderr, "WARNING: Allocating non-free cell!" );
fwprintf( stderr, L"WARNING: Allocating non-free cell!" );
}
}

12
src/consspaceobject.c
View file

@ -81,8 +81,7 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
cell.payload.cons.car.page,
cell.payload.cons.car.offset,
cell.payload.cons.cdr.page,
cell.payload.cons.cdr.offset,
cell.count);
cell.payload.cons.cdr.offset, cell.count );
break;
case INTEGERTV:
fwprintf( output,
@ -102,8 +101,7 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
L"\t\tString cell: character '%1c' (%1d) next at page %2d offset %3d, count %u\n",
cell.payload.string.character,
cell.payload.string.cdr.page,
cell.payload.string.cdr.offset,
cell.count );
cell.payload.string.cdr.offset, cell.count );
fwprintf( output, L"\t\t value: " );
print( output, pointer );
fwprintf( output, L"\n" );
@ -113,8 +111,7 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
L"\t\tSymbol cell: character '%1c' (%1d) next at page %2d offset %3d, count %u\n",
cell.payload.string.character,
cell.payload.string.cdr.page,
cell.payload.string.cdr.offset,
cell.count );
cell.payload.string.cdr.offset, cell.count );
fwprintf( output, L"\t\t value:" );
print( output, pointer );
fwprintf( output, L"\n" );
@ -208,8 +205,7 @@ struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) {
*/
struct cons_pointer
make_special( struct cons_pointer src, struct cons_pointer ( *executable )
( struct stack_frame * frame,
struct cons_pointer env ) ) {
( struct stack_frame * frame, struct cons_pointer env ) ) {
struct cons_pointer pointer = allocate_cell( SPECIALTAG );
struct cons_space_object *cell = &pointer2cell( pointer );

4
src/init.c
View file

@ -30,8 +30,7 @@ void bind_function( char *name, struct cons_pointer ( *executable )
}
void bind_special( char *name, struct cons_pointer ( *executable )
( struct cons_pointer s_expr, struct cons_pointer env,
struct stack_frame * frame ) ) {
( struct stack_frame * frame, struct cons_pointer env ) ) {
deep_bind( c_string_to_lisp_symbol( name ),
make_special( NIL, executable ) );
}
@ -87,6 +86,7 @@ int main( int argc, char *argv[] ) {
bind_function( "equal", &lisp_equal );
bind_function( "read", &lisp_read );
bind_function( "print", &lisp_print );
bind_function( "type", &lisp_type );
bind_function( "add", &lisp_add );
bind_function( "multiply", &lisp_multiply );

30
src/lispops.c
View file

@ -80,6 +80,7 @@ eval_cons( struct stack_frame *frame, struct cons_pointer env ) {
struct stack_frame *fn_frame = make_empty_frame( frame, env );
fn_frame->arg[0] = c_car( frame->arg[0] );
inc_ref( fn_frame->arg[0] );
struct cons_pointer fn_pointer = lisp_eval( fn_frame, env );
free_stack_frame( fn_frame );
@ -187,6 +188,7 @@ lisp_apply( struct stack_frame *frame, struct cons_pointer env ) {
struct stack_frame *fn_frame = make_empty_frame( frame, env );
fn_frame->arg[0] = frame->arg[0];
inc_ref( fn_frame->arg[0] );
struct cons_pointer fn_pointer = lisp_eval( fn_frame, env );
free_stack_frame( fn_frame );
@ -256,8 +258,7 @@ lisp_car( struct stack_frame *frame, struct cons_pointer env ) {
result = make_string( cell.payload.string.character, NIL );
} else {
struct cons_pointer message =
c_string_to_lisp_string
( "Attempt to take CAR of non sequence" );
c_string_to_lisp_string( "Attempt to take CAR of non sequence" );
result = lisp_throw( message, frame );
}
@ -281,8 +282,7 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer env ) {
result = cell.payload.string.cdr;
} else {
struct cons_pointer message =
c_string_to_lisp_string
( "Attempt to take CDR of non sequence" );
c_string_to_lisp_string( "Attempt to take CDR of non sequence" );
result = lisp_throw( message, frame );
}
@ -333,6 +333,7 @@ lisp_read( struct stack_frame *frame, struct cons_pointer env ) {
return read( input );
}
/**
* (print expr)
* (print expr write-stream)
@ -352,6 +353,27 @@ lisp_print( struct stack_frame *frame, struct cons_pointer env ) {
return NIL;
}
/**
* 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.
*/
struct cons_pointer
lisp_type( struct stack_frame *frame, struct cons_pointer env ) {
char *buffer = malloc( TAGLENGTH + 1 );
memset( buffer, 0, TAGLENGTH + 1 );
struct cons_space_object cell = pointer2cell( frame->arg[0] );
strncpy( buffer, cell.tag.bytes, TAGLENGTH );
struct cons_pointer result = c_string_to_lisp_string( buffer );
free( buffer );
return result;
}
/**
* TODO: make this do something sensible somehow.
*/

8
src/lispops.h
View file

@ -48,6 +48,14 @@ struct cons_pointer lisp_read( struct stack_frame *frame,
struct cons_pointer env );
struct cons_pointer lisp_print( struct stack_frame *frame,
struct cons_pointer env );
/**
* 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.
*/
struct cons_pointer
lisp_type( struct stack_frame *frame, struct cons_pointer env );
/*
* neither, at this stage, really

2
src/stack.c
View file

@ -84,8 +84,8 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous,
struct stack_frame *arg_frame = make_empty_frame( previous, env );
arg_frame->arg[0] = cell.payload.cons.car;
result->arg[i] = lisp_eval( arg_frame, env );
free_stack_frame( arg_frame );
inc_ref( result->arg[i] );
free_stack_frame( arg_frame );
args = cell.payload.cons.cdr;
}

2
unit-tests/apply.sh
View file

@ -1,7 +1,7 @@
#!/bin/bash
expected='1'
actual=`echo "(apply 'add '(1))"| target/psse 2> /dev/null | head -1`
actual=`echo "(apply add '(1))"| target/psse 2> /dev/null | head -1`
if [ "${expected}" = "${actual}" ]
then