diff --git a/src/conspage.c b/src/conspage.c index 2e4d90a..0805ee3 100644 --- a/src/conspage.c +++ b/src/conspage.c @@ -90,9 +90,9 @@ void make_cons_page( ) { initialised_cons_pages++; } else { - fprintf( stderr, - "FATAL: Failed to allocate memory for cons page %d\n", - initialised_cons_pages ); + 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,19 +123,21 @@ 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", - cell->count, pointer.page, pointer.offset ); + 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", - pointer.page, pointer.offset ); + 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, - result.page, result.offset ); + 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!" ); } } diff --git a/src/consspaceobject.c b/src/consspaceobject.c index 8a5371d..84c39f5 100644 --- a/src/consspaceobject.c +++ b/src/consspaceobject.c @@ -80,9 +80,8 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { 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); + cell.payload.cons.cdr.page, + 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 ); diff --git a/src/init.c b/src/init.c index 33e0a29..d39e707 100644 --- a/src/init.c +++ b/src/init.c @@ -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 ); diff --git a/src/lispops.c b/src/lispops.c index dc33db3..783432f 100644 --- a/src/lispops.c +++ b/src/lispops.c @@ -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. */ diff --git a/src/lispops.h b/src/lispops.h index e808a1a..716fdf6 100644 --- a/src/lispops.h +++ b/src/lispops.h @@ -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 diff --git a/src/stack.c b/src/stack.c index bed6307..1b887b1 100644 --- a/src/stack.c +++ b/src/stack.c @@ -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; } diff --git a/unit-tests/apply.sh b/unit-tests/apply.sh index 1ee19b0..ea90436 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 -1` +actual=`echo "(apply add '(1))"| target/psse 2> /dev/null | head -1` if [ "${expected}" = "${actual}" ] then