diff --git a/src/consspaceobject.h b/src/consspaceobject.h index c17ded5..0b50e07 100644 --- a/src/consspaceobject.h +++ b/src/consspaceobject.h @@ -34,6 +34,13 @@ #define CONSTAG "CONS" #define CONSTV 1397641027 +/** + * An exception. + */ +#define EXCEPTIONTAG "EXEP" +/* TODO: this is wrong */ +#define EXCEPTIONTV 1346721861 + /** * An unallocated cell on the free list - should never be encountered by a Lisp * function. 1162170950 @@ -117,13 +124,6 @@ /* TODO: this is wrong */ #define WRITETV 1414091351 -/** - * An exception. - */ -#define EXCEPTIONTAG "EXEP" -/* TODO: this is wrong */ -#define EXCEPTIONTV 1346721861 - /** * a cons pointer which points to the special NIL cell */ diff --git a/src/equal.c b/src/equal.c index d06903f..ef0b897 100644 --- a/src/equal.c +++ b/src/equal.c @@ -78,8 +78,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: case REALTV: diff --git a/src/init.c b/src/init.c index 67a5fbb..e4a320f 100644 --- a/src/init.c +++ b/src/init.c @@ -53,7 +53,7 @@ int main( int argc, char *argv[] ) { break; case 'p': show_prompt = true; - print_use_colours = true; + print_use_colours = true; break; default: fwprintf( stderr, L"Unexpected option %c\n", option ); @@ -74,6 +74,7 @@ int main( int argc, char *argv[] ) { */ deep_bind( c_string_to_lisp_symbol( "nil" ), NIL ); deep_bind( c_string_to_lisp_symbol( "t" ), TRUE ); + /* lambda is even more privileged than a special form */ deep_bind( c_string_to_lisp_symbol( "lambda" ), LAMBDA ); /* diff --git a/src/lispops.c b/src/lispops.c index 9815816..ee59c40 100644 --- a/src/lispops.c +++ b/src/lispops.c @@ -104,26 +104,53 @@ struct cons_pointer eval_form( struct stack_frame *parent, * @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 ) { +lisp_lambda( struct stack_frame *frame, struct cons_pointer env ) { struct cons_pointer result = NIL; + struct cons_pointer lexpr = frame->arg[0]; struct cons_pointer should_be_lambda = eval_form( frame, c_car( lexpr ), env ); + dump_frame( stderr, frame ); + if ( lambdap( should_be_lambda ) ) { struct cons_pointer new_env = env; + struct cons_pointer args = c_car( c_cdr( lexpr ) ); + struct cons_pointer body = c_cdr( c_cdr( lexpr ) ); + + for ( int i = 1; i < args_in_frame && consp( args ); i++ ) { + args = c_cdr( args ); + struct cons_pointer arg = c_car( args ); + print( stderr, c_string_to_lisp_string( "\n\tBinding " ) ); + print( stderr, arg ); + print( stderr, c_string_to_lisp_string( " to " ) ); + print( stderr, frame->arg[i] ); + + new_env = make_cons( make_cons( arg, frame->arg[i] ), new_env ); + } + + while ( !nilp( body ) ) { + struct cons_pointer sexpr = c_car( body ); + body = c_cdr( body ); + + result = eval_form( frame, sexpr, new_env ); + } } else { - char *buffer = malloc( 1024 ); - struct cons_space_object not_lambda = pointer2cell( should_be_lambda ); - memset( buffer, '\0', 1024 ); - sprintf( buffer, - "Expected lambda, but found cell with tag %d (%c%c%c%c)", - not_lambda.tag.value, not_lambda.tag.bytes[0], - not_lambda.tag.bytes[1], not_lambda.tag.bytes[2], - not_lambda.tag.bytes[3] ); - struct cons_pointer message = c_string_to_lisp_string( buffer ); - free( buffer ); - result = lisp_throw( message, frame ); + if ( exceptionp( should_be_lambda ) ) { + result = should_be_lambda; + } else { + char *buffer = malloc( 1024 ); + struct cons_space_object not_lambda = + pointer2cell( should_be_lambda ); + memset( buffer, '\0', 1024 ); + sprintf( buffer, + "Expected lambda, but found cell with tag %d (%c%c%c%c)", + not_lambda.tag.value, not_lambda.tag.bytes[0], + not_lambda.tag.bytes[1], not_lambda.tag.bytes[2], + not_lambda.tag.bytes[3] ); + struct cons_pointer message = c_string_to_lisp_string( buffer ); + free( buffer ); + result = lisp_throw( message, frame ); + } } return result; } @@ -159,7 +186,6 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) { free_stack_frame( next ); } break; - case FUNCTIONTV: { struct stack_frame *next = @@ -168,12 +194,17 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) { free_stack_frame( next ); } break; - case CONSTV: { - result = lisp_lambda( frame, fn_pointer, env ); + fwprintf( stdout, + L"Treating cons as lambda expression (apply)\n" ); + result = lisp_lambda( frame, env ); } break; + case EXCEPTIONTV: + /* just pass exceptions straight back */ + result = fn_pointer; + break; default: { char *buffer = malloc( 1024 ); @@ -235,7 +266,14 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) { switch ( cell.tag.value ) { case CONSTV: - result = c_apply( frame, env ); + print( stderr, frame->arg[0] ); + if ( lambdap( c_car( frame->arg[0] ) ) ) { + fwprintf( stdout, + L"Treating cons as lambda expression (eval)\n" ); + result = lisp_lambda( frame, env ); + } else { + result = c_apply( frame, env ); + } break; case SYMBOLTV: diff --git a/src/lispops.h b/src/lispops.h index 6fd6e6b..fac1ec0 100644 --- a/src/lispops.h +++ b/src/lispops.h @@ -37,6 +37,16 @@ struct cons_pointer lisp_eval( struct stack_frame *frame, struct cons_pointer env ); struct cons_pointer lisp_apply( struct stack_frame *frame, struct cons_pointer env ); + /** + * 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 env ); + struct cons_pointer lisp_quote( struct stack_frame *frame, struct cons_pointer env ); diff --git a/src/print.c b/src/print.c index 31971a2..d57afc2 100644 --- a/src/print.c +++ b/src/print.c @@ -22,20 +22,34 @@ #include "integer.h" #include "print.h" +/** + * Whether or not we colorise output. + * TODO: this should be a Lisp symbol binding, not a C variable. + */ int print_use_colours = 0; +/** + * print all the characters in the symbol or string indicated by `pointer` + * onto this `output`; if `pointer` does not indicate a string or symbol, + * don't print anything but just return. + */ void print_string_contents( FILE * output, struct cons_pointer pointer ) { - if ( stringp( pointer ) || symbolp( pointer ) ) { + while ( stringp( pointer ) || symbolp( pointer ) ) { struct cons_space_object *cell = &pointer2cell( pointer ); wint_t c = cell->payload.string.character; if ( c != '\0' ) { fputwc( c, output ); } - print_string_contents( output, cell->payload.string.cdr ); + pointer = cell->payload.string.cdr; } } +/** + * print all the characters in the string indicated by `pointer` onto + * the stream at this `output`, prepending and appending double quote + * characters. + */ void print_string( FILE * output, struct cons_pointer pointer ) { fputwc( btowc( '"' ), output ); print_string_contents( output, pointer ); @@ -43,7 +57,9 @@ void print_string( FILE * output, struct cons_pointer pointer ) { } /** - * Print a single list cell (cons cell). + * Print a single list cell (cons cell) indicated by `pointer` to the + * stream indicated by `output`. if `initial_space` is `true`, prepend + * a space character. */ void print_list_contents( FILE * output, struct cons_pointer pointer, @@ -83,6 +99,10 @@ void print_list( FILE * output, struct cons_pointer pointer ) { } +/** + * Print the cons-space object indicated by `pointer` to the stream indicated + * by `output`. + */ void print( FILE * output, struct cons_pointer pointer ) { struct cons_space_object cell = pointer2cell( pointer ); char *buffer;