diff --git a/lisp/defun.lisp b/lisp/defun.lisp index 83f65c2..e86df35 100644 --- a/lisp/defun.lisp +++ b/lisp/defun.lisp @@ -4,8 +4,8 @@ (nlambda form (cond ((symbolp (car form)) - (set! (car form) (apply lambda (cdr form))))) - (t nil))) + (set (car form) (apply lambda (cdr form)))) + (t nil)))) (defun! square (x) (* x x)) diff --git a/src/conspage.c b/src/conspage.c index afa8bf4..ad83680 100644 --- a/src/conspage.c +++ b/src/conspage.c @@ -127,6 +127,33 @@ void dump_pages( FILE * output ) { void free_cell( struct cons_pointer pointer ) { struct cons_space_object *cell = &pointer2cell( pointer ); + switch ( cell->tag.value ) { + /* for all the types of cons-space object which point to other + * cons-space objects, cascade the decrement. */ + case CONSTV: + dec_ref( cell->payload.cons.car ); + dec_ref( cell->payload.cons.cdr ); + break; + case EXCEPTIONTV: + dec_ref( cell->payload.exception.message ); + break; + case FUNCTIONTV: + dec_ref( cell->payload.function.source ); + break; + case LAMBDATV: + case NLAMBDATV: + dec_ref( cell->payload.lambda.args ); + dec_ref( cell->payload.lambda.body ); + break; + case SPECIALTV: + dec_ref( cell->payload.special.source ); + break; + case STRINGTV: + case SYMBOLTV: + dec_ref( cell->payload.string.cdr ); + break; + } + if ( !check_tag( pointer, FREETAG ) ) { if ( cell->count == 0 ) { fwprintf( stderr, L"Freeing cell " ); diff --git a/src/consspaceobject.c b/src/consspaceobject.c index 0e8f455..0fe28e3 100644 --- a/src/consspaceobject.c +++ b/src/consspaceobject.c @@ -177,6 +177,9 @@ struct cons_pointer make_exception( struct cons_pointer message, struct cons_pointer pointer = allocate_cell( EXCEPTIONTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); + inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */ + + inc_ref( message ); cell->payload.exception.message = message; cell->payload.exception.frame = frame; @@ -206,6 +209,9 @@ struct cons_pointer make_lambda( struct cons_pointer args, struct cons_pointer body ) { struct cons_pointer pointer = allocate_cell( LAMBDATAG ); struct cons_space_object *cell = &pointer2cell( pointer ); + + inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */ + inc_ref( args ); inc_ref( body ); cell->payload.lambda.args = args; @@ -221,6 +227,9 @@ struct cons_pointer make_lambda( struct cons_pointer args, struct cons_pointer make_nlambda( struct cons_pointer args, struct cons_pointer body ) { struct cons_pointer pointer = allocate_cell( NLAMBDATAG ); + + inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */ + struct cons_space_object *cell = &pointer2cell( pointer ); inc_ref( args ); inc_ref( body ); diff --git a/src/equal.c b/src/equal.c index 0f0597c..ebb085e 100644 --- a/src/equal.c +++ b/src/equal.c @@ -80,8 +80,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { && ( 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 ) ) ); + && end_of_string( cell_b->payload.string. + cdr ) ) ); break; case INTEGERTV: result = diff --git a/src/init.c b/src/init.c index b69177d..70e2499 100644 --- a/src/init.c +++ b/src/init.c @@ -92,8 +92,10 @@ int main( int argc, char *argv[] ) { bind_function( "eval", &lisp_eval ); bind_function( "multiply", &lisp_multiply ); bind_function( "read", &lisp_read ); + bind_function( "oblist", &lisp_oblist ); bind_function( "print", &lisp_print ); bind_function( "progn", &lisp_progn ); + bind_function( "set", &lisp_set ); bind_function( "subtract", &lisp_subtract ); bind_function( "type", &lisp_type ); @@ -112,11 +114,6 @@ int main( int argc, char *argv[] ) { bind_special( "quote", &lisp_quote ); bind_special( "set!", &lisp_set_shriek ); - - /* bind the oblist last, at this stage. Something clever needs to be done - * here and I'm not sure what it is. */ - deep_bind( c_string_to_lisp_symbol( "oblist" ), oblist ); - repl( stdin, stdout, stderr, show_prompt ); if ( dump_at_end ) { diff --git a/src/intern.c b/src/intern.c index 12f9da3..100589a 100644 --- a/src/intern.c +++ b/src/intern.c @@ -4,11 +4,11 @@ * For now this implements an oblist and shallow binding; local environments can * be consed onto the front of the oblist. Later, this won't do; bindings will happen * in namespaces, which will probably be implemented as hash tables. - * + * * Doctrine is that cons cells are immutable, and life is a lot more simple if they are; * so when a symbol is rebound in the master oblist, what in fact we do is construct * a new oblist without the previous binding but with the new binding. Anything which, - * prior to this action, held a pointer to the old oblist (as all current threads' + * prior to this action, held a pointer to the old oblist (as all current threads' * environments must do) continues to hold a pointer to the old oblist, and consequently * doesn't see the change. This is probably good but does mean you cannot use bindings * on the oblist to signal between threads. @@ -26,12 +26,12 @@ #include "print.h" /** - * The object list. What is added to this during system setup is 'global', that is, + * The object list. What is added to this during system setup is 'global', that is, * visible to all sessions/threads. What is added during a session/thread is local to * that session/thread (because shallow binding). There must be some way for a user to * make the contents of their own environment persistent between threads but I don't * know what it is yet. At some stage there must be a way to rebind deep values so - * they're visible to all users/threads, but again I don't yet have any idea how + * they're visible to all users/threads, but again I don't yet have any idea how * that will work. */ struct cons_pointer oblist = NIL; @@ -114,8 +114,8 @@ bind( struct cons_pointer key, struct cons_pointer value, } /** - * Binds this key to this value in the global oblist, but doesn't affect the - * current environment. May not be useful except in bootstrapping (and even + * Binds this key to this value in the global oblist, but doesn't affect the + * current environment. May not be useful except in bootstrapping (and even * there it may not be especially useful). */ struct cons_pointer @@ -133,10 +133,9 @@ struct cons_pointer intern( struct cons_pointer key, struct cons_pointer environment ) { struct cons_pointer result = environment; struct cons_pointer canonical = internedp( key, environment ); - if ( nilp( canonical ) ) { /* - * not currently bound + * not currently bound */ result = bind( key, NIL, environment ); } diff --git a/src/lispops.c b/src/lispops.c index fe71c60..cf70d8a 100644 --- a/src/lispops.c +++ b/src/lispops.c @@ -63,7 +63,7 @@ struct cons_pointer c_car( struct cons_pointer arg ) { struct cons_pointer c_cdr( struct cons_pointer arg ) { struct cons_pointer result = NIL; - if ( consp( arg ) ) { + if ( consp( arg ) || stringp( arg ) || symbolp( arg ) ) { result = pointer2cell( arg ).payload.cons.cdr; } @@ -115,6 +115,16 @@ struct cons_pointer eval_forms( struct stack_frame *frame, eval_forms( frame, c_cdr( list ), env ) ) : NIL; } +/** + * Return the object list (root namespace). + * + * (oblist) + */ +struct cons_pointer +lisp_oblist( struct stack_frame *frame, struct cons_pointer env ) { + return oblist; +} + /** * used to construct the body for `lambda` and `nlambda` expressions. @@ -123,12 +133,18 @@ struct cons_pointer compose_body( struct stack_frame *frame ) { struct cons_pointer body = !nilp( frame->arg[args_in_frame - 1] ) ? frame->more : NIL; - for ( int i = args_in_frame - 1; i >= 0; i-- ) { - if ( !nilp( frame->arg[i] ) ) { + for ( int i = args_in_frame - 1; i > 0; i-- ) { + if ( !nilp( body ) ) { + body = make_cons( frame->arg[i], body ); + } else if ( !nilp( frame->arg[i] ) ) { body = make_cons( frame->arg[i], body ); } } + fputws( L"compose_body returning ", stderr ); + print( stderr, body ); + fputws( L"\n", stderr ); + return body; } @@ -169,7 +185,7 @@ struct cons_pointer eval_lambda( struct cons_space_object cell, struct stack_frame *frame, struct cons_pointer env ) { struct cons_pointer result = NIL; - fwprintf( stderr, L"eval_lambda called" ); + fwprintf( stderr, L"eval_lambda called\n" ); struct cons_pointer new_env = env; struct cons_pointer names = cell.payload.lambda.args; @@ -278,7 +294,9 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) { { struct stack_frame *next = make_special_frame( frame, args, env ); - result = ( *fn_cell.payload.special.executable ) ( next, env ); + fputws( L"Stack frame for nlambda\n", stderr ); + dump_frame( stderr, next ); + result = eval_lambda( fn_cell, next, env ); if ( !exceptionp( result ) ) { /* if we're returning an exception, we should NOT free the * stack frame. Corollary is, when we free an exception, we @@ -440,13 +458,45 @@ lisp_quote( struct stack_frame *frame, struct cons_pointer env ) { return frame->arg[0]; } + +/** + * (set name value) + * (set name value namespace) + * + * Function. + * `namespace` defaults to the oblist. + * Binds the value of `name` in the `namespace` to value of `value`, altering + * the namespace in so doing. `namespace` defaults to the value of `oblist`. + */ +struct cons_pointer +lisp_set( struct stack_frame *frame, struct cons_pointer env ) { + struct cons_pointer result = NIL; + struct cons_pointer namespace = + nilp( frame->arg[2] ) ? oblist : frame->arg[2]; + + if ( symbolp( frame->arg[0] ) ) { + deep_bind( frame->arg[0], frame->arg[1] ); + result = frame->arg[1]; + } else { + result = + make_exception( make_cons + ( c_string_to_lisp_string + ( "The first argument to `set!` is not a symbol: " ), + make_cons( frame->arg[0], NIL ) ), frame ); + } + + return result; +} + + /** * (set! symbol value) * (set! symbol value namespace) * * Special form. * `namespace` defaults to the oblist. - * Binds `symbol` to `value` in the namespace, altering the namespace in so doing. + * Binds `symbol` in the `namespace` to value of `value`, altering + * the namespace in so doing. `namespace` defaults to the value of `oblist`. */ struct cons_pointer lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ) { @@ -455,13 +505,15 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ) { nilp( frame->arg[2] ) ? oblist : frame->arg[2]; if ( symbolp( frame->arg[0] ) ) { - deep_bind( frame->arg[0], eval_form( frame, frame->arg[1], env ) ); - result = frame->arg[1]; + struct cons_pointer val = eval_form( frame, frame->arg[1], env ); + deep_bind( frame->arg[0], val ); + result = val; } else { result = - make_exception( c_string_to_lisp_string - ( "The first argument to `set!` is not a symbol" ), - frame ); + make_exception( make_cons + ( c_string_to_lisp_string + ( "The first argument to `set!` is not a symbol: " ), + make_cons( frame->arg[0], NIL ) ), frame ); } return result; @@ -670,15 +722,16 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) { if ( consp( clause_pointer ) ) { struct cons_space_object cell = pointer2cell( clause_pointer ); - result = eval_form( frame, c_car( clause_pointer ), env); + result = eval_form( frame, c_car( clause_pointer ), env ); if ( !nilp( result ) ) { - struct cons_pointer vals = eval_forms( frame, c_cdr( clause_pointer ), env ); + struct cons_pointer vals = + eval_forms( frame, c_cdr( clause_pointer ), env ); - while (consp( vals)) { - result = c_car(vals); - vals = c_cdr(vals); - } + while ( consp( vals ) ) { + result = c_car( vals ); + vals = c_cdr( vals ); + } done = true; } @@ -698,6 +751,11 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) { /** * TODO: make this do something sensible somehow. + * This requires that a frame be a heap-space object with a cons-space + * object pointing to it. Then this should become a normal lisp function + * which expects a normally bound frame and environment, such that + * frame->arg[0] is the message, and frame->arg[1] is the cons-space + * pointer to the frame in which the exception occurred. */ struct cons_pointer lisp_throw( struct cons_pointer message, struct stack_frame *frame ) { diff --git a/src/lispops.h b/src/lispops.h index a0b82cf..122e149 100644 --- a/src/lispops.h +++ b/src/lispops.h @@ -71,6 +71,12 @@ struct cons_pointer lisp_eval( struct stack_frame *frame, struct cons_pointer lisp_apply( struct stack_frame *frame, struct cons_pointer env ); +struct cons_pointer +lisp_oblist( struct stack_frame *frame, struct cons_pointer env ); + +struct cons_pointer +lisp_set( struct stack_frame *frame, struct cons_pointer env ); + struct cons_pointer lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ); diff --git a/src/print.c b/src/print.c index e3002f8..42bf8b4 100644 --- a/src/print.c +++ b/src/print.c @@ -132,8 +132,8 @@ void print( FILE * output, struct cons_pointer pointer ) { case LAMBDATV: print( output, make_cons( c_string_to_lisp_symbol( "lambda" ), make_cons( cell.payload.lambda.args, - cell.payload.lambda. - body ) ) ); + cell.payload. + lambda.body ) ) ); break; case NILTV: fwprintf( output, L"nil" ); @@ -141,8 +141,8 @@ void print( FILE * output, struct cons_pointer pointer ) { case NLAMBDATV: print( output, make_cons( c_string_to_lisp_symbol( "nlambda" ), make_cons( cell.payload.lambda.args, - cell.payload.lambda. - body ) ) ); + cell.payload. + lambda.body ) ) ); break; case READTV: fwprintf( output, L"(Input stream)" ); @@ -173,8 +173,9 @@ void print( FILE * output, struct cons_pointer pointer ) { print_string( output, pointer ); break; case SYMBOLTV: - if ( print_use_colours ) + if ( print_use_colours ) { fputws( L"\x1B[1;33m", output ); + } print_string_contents( output, pointer ); break; case SPECIALTV: @@ -185,10 +186,10 @@ void print( FILE * output, struct cons_pointer pointer ) { break; default: fwprintf( stderr, - L"%sError: Unrecognised tag value %d (%c%c%c%c)%s\n", - "\x1B[31m", + L"%sError: Unrecognised tag value %d (%c%c%c%c)\n", + print_use_colours ? "\x1B[31m" : "", cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1], - cell.tag.bytes[2], cell.tag.bytes[3], "\x1B[39m" ); + cell.tag.bytes[2], cell.tag.bytes[3] ); break; } diff --git a/src/repl.c b/src/repl.c index 596cb61..40f6300 100644 --- a/src/repl.c +++ b/src/repl.c @@ -97,10 +97,12 @@ repl( FILE * in_stream, FILE * out_stream, FILE * error_stream, struct cons_pointer val = repl_eval( input ); - /* suppress the 'end of stream' exception */ - if ( !exceptionp( val ) && - !feof( pointer2cell( input_stream ).payload.stream. - stream ) ) { + if ( feof( pointer2cell( input_stream ).payload.stream.stream ) ) { + /* suppress the 'end of stream' exception */ + if ( !exceptionp( val ) ) { + repl_print( output_stream, val ); + } + } else { repl_print( output_stream, val ); } } diff --git a/src/stack.c b/src/stack.c index ea1f911..cf75df8 100644 --- a/src/stack.c +++ b/src/stack.c @@ -169,9 +169,10 @@ void dump_frame( FILE * output, struct stack_frame *frame ) { for ( int arg = 0; arg < args_in_frame; arg++ ) { struct cons_space_object cell = pointer2cell( frame->arg[arg] ); - fwprintf( output, L"Arg %d:\t%c%c%c%c\t", arg, + fwprintf( output, L"Arg %d:\t%c%c%c%c\tcount: %10u\tvalue: ", arg, cell.tag.bytes[0], - cell.tag.bytes[1], cell.tag.bytes[2], cell.tag.bytes[3] ); + cell.tag.bytes[1], cell.tag.bytes[2], cell.tag.bytes[3], + cell.count ); print( output, frame->arg[arg] ); fputws( L"\n", output ); diff --git a/unit-tests/lambda.sh b/unit-tests/lambda.sh new file mode 100644 index 0000000..c1197e0 --- /dev/null +++ b/unit-tests/lambda.sh @@ -0,0 +1,16 @@ +#!/bin/bash + +expected='(lambda (l) l)(1 2 3 4 5 6 7 8 9 10)' +actual=`target/psse 2>/dev/null <