diff --git a/src/consspaceobject.c b/src/consspaceobject.c index 84c39f5..39caac7 100644 --- a/src/consspaceobject.c +++ b/src/consspaceobject.c @@ -98,7 +98,8 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { break; case STRINGTV: fwprintf( output, - L"\t\tString cell: character '%1c' (%1d) next at page %2d offset %3d, count %u\n", + L"\t\tString cell: character '%c' (%d) next at page %d offset %d, count %u\n", + cell.payload.string.character, cell.payload.string.character, cell.payload.string.cdr.page, cell.payload.string.cdr.offset, cell.count ); @@ -108,7 +109,8 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { break; case SYMBOLTV: fwprintf( output, - L"\t\tSymbol cell: character '%1c' (%1d) next at page %2d offset %3d, count %u\n", + L"\t\tSymbol cell: character '%c' (%d) next at page %d offset %d, count %u\n", + cell.payload.string.character, cell.payload.string.character, cell.payload.string.cdr.page, cell.payload.string.cdr.offset, cell.count ); diff --git a/src/equal.c b/src/equal.c index 23de51c..3f74d51 100644 --- a/src/equal.c +++ b/src/equal.c @@ -37,6 +37,16 @@ bool same_type( struct cons_pointer a, struct cons_pointer b ) { } +/** + * Some string will be null terminated and some will be NIL terminated... ooops! + * @param string the string to test + * @return true if it's the end of a string. + */ +bool end_of_string( struct cons_pointer string) { + return nilp( string) || + pointer2cell(string).payload.string.character == '\0'; +} + /** * Deep, and thus expensive, equality: true if these two objects have * identical structure, else false. @@ -64,8 +74,10 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { result = cell_a->payload.string.character == cell_b->payload.string.character - && equal( cell_a->payload.string.cdr, - cell_b->payload.string.cdr ); + && (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: diff --git a/src/init.c b/src/init.c index d4e9dbf..d267dec 100644 --- a/src/init.c +++ b/src/init.c @@ -100,6 +100,7 @@ int main( int argc, char *argv[] ) { /* * primitive special forms */ + bind_special( "cond", &lisp_cond ); bind_special( "eval", &lisp_eval ); bind_special( "quote", &lisp_quote ); diff --git a/src/intern.c b/src/intern.c index 31b7e2e..95400ae 100644 --- a/src/intern.c +++ b/src/intern.c @@ -19,9 +19,11 @@ #include -#include "equal.h" #include "conspage.h" #include "consspaceobject.h" +#include "equal.h" +#include "lispops.h" +#include "print.h" /** * The object list. What is added to this during system setup is 'global', that is, @@ -47,15 +49,29 @@ struct cons_pointer internedp( struct cons_pointer key, struct cons_pointer store ) { struct cons_pointer result = NIL; - for ( struct cons_pointer next = store; - nilp( result ) && consp( next ); - next = pointer2cell( next ).payload.cons.cdr ) { - struct cons_space_object entry = - pointer2cell( pointer2cell( next ).payload.cons.car ); + if (symbolp(key)) { + for ( struct cons_pointer next = store; + nilp( result ) && consp( next ); + next = pointer2cell( next ).payload.cons.cdr ) { + struct cons_space_object entry = + pointer2cell( pointer2cell( next ).payload.cons.car ); - if ( equal( key, entry.payload.cons.car ) ) { - result = entry.payload.cons.car; + fputws( L"Internedp: checking whether `", stderr); + print(stderr, key); + fputws( L"` equals `", stderr); + print( stderr, entry.payload.cons.car); + fputws( L"`\n", stderr); + + if ( equal( key, entry.payload.cons.car ) ) { + result = entry.payload.cons.car; + } } + } else { + fputws(L"`", stderr); + print( stderr, key ); + fputws( L"` is a ", stderr); + print( stderr, c_type( key)); + fputws( L", not a SYMB", stderr); } return result; diff --git a/src/lispops.c b/src/lispops.c index 1866b34..6c442c2 100644 --- a/src/lispops.c +++ b/src/lispops.c @@ -73,6 +73,30 @@ struct cons_pointer c_cdr( struct cons_pointer arg ) { } +/** + * Useful building block; evaluate this single form in the context of this + * parent stack frame and this environment. + * @param parent the parent stack frame. + * @param form the form to be evaluated. + * @param env the evaluation environment. + * @return the result of evaluating the form. + */ +struct cons_pointer eval_form( struct stack_frame *parent, struct cons_pointer form, struct cons_pointer env) { + fputws(L"eval_form: ", stderr); + print( stderr, form); + fputws(L"\n", stderr); + + struct cons_pointer result = NIL; + struct stack_frame * next = make_empty_frame(parent, env); + next->arg[0] = form; + inc_ref( next->arg[0] ); + result = lisp_eval(next, env); + free_stack_frame( next); + + return result; +} + + /** * Internal guts of apply. * @param frame the stack frame, expected to have only one argument, a list @@ -131,6 +155,26 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) { return result; } + +/** + * Get the Lisp type of the single argument. + * @param pointer a pointer to the object whose type is requested. + * @return As a Lisp string, the tag of the object which is at that pointer. + */ +struct cons_pointer +c_type( struct cons_pointer pointer) { + char *buffer = malloc( TAGLENGTH + 1 ); + memset( buffer, 0, TAGLENGTH + 1 ); + struct cons_space_object cell = pointer2cell( pointer ); + strncpy( buffer, cell.tag.bytes, TAGLENGTH ); + + struct cons_pointer result = c_string_to_lisp_string( buffer ); + free( buffer ); + + return result; +} + + /** * (eval s_expr) * @@ -373,17 +417,10 @@ lisp_print( struct stack_frame *frame, struct cons_pointer env ) { */ 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; + return c_type( frame->arg[0] ); } + /** * Function; evaluate the forms which are listed in my single argument * sequentially and return the value of the last. This function is called 'do' @@ -401,11 +438,7 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer env ) { while ( consp(remaining)) { struct cons_space_object cell = pointer2cell( remaining ); - struct stack_frame * next = make_empty_frame(frame, env); - next->arg[0] = cell.payload.cons.car; - inc_ref( next->arg[0] ); - result = lisp_eval(next, env); - free_stack_frame( next); + result = eval_form(frame, cell.payload.cons.car, env); remaining = cell.payload.cons.cdr; } @@ -413,6 +446,48 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer env ) { return result; } +/** + * Special form: conditional. Each arg is expected to be a list; if the first + * item in such a list evaluates to non-NIL, the remaining items in that list + * are evaluated in turn and the value of the last returned. If no arg (clause) + * has a first element which evaluates to non NIL, then NIL is returned. + * @param frame My stack frame. + * @param env My environment (ignored). + * @return the value of the last form of the first successful clause. + */ +struct cons_pointer +lisp_cond( struct stack_frame *frame, struct cons_pointer env ) { + struct cons_pointer result = NIL; + bool done = false; + + for (int i = 0; i < args_in_frame && !done; i++) { + struct cons_pointer clause_pointer = frame->arg[i]; + fputws(L"Cond clause: ", stderr); + print( stderr, clause_pointer); + + if (consp(clause_pointer)) { + struct cons_space_object cell = pointer2cell( clause_pointer ); + + if (!nilp( eval_form(frame, cell.payload.cons.car, env))) { + struct stack_frame * next = make_empty_frame(frame, env); + next->arg[0] = cell.payload.cons.cdr; + inc_ref(next->arg[0]); + result = lisp_progn( next, env); + done = true; + } + } else if (nilp(clause_pointer)) { + done = true; + } else { + lisp_throw( + c_string_to_lisp_string( "Arguments to `cond` must be lists"), + frame); + } + } + /* TODO: if there are more than 8 caluses we need to continue into the + * remainder */ + + return result; +} /** * TODO: make this do something sensible somehow. diff --git a/src/lispops.h b/src/lispops.h index cbfba60..955ca60 100644 --- a/src/lispops.h +++ b/src/lispops.h @@ -19,6 +19,18 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +/* + * utilities + */ + +/** + * Get the Lisp type of the single argument. + * @param pointer a pointer to the object whose type is requested. + * @return As a Lisp string, the tag of the object which is at that pointer. + */ +struct cons_pointer +c_type( struct cons_pointer pointer); + /* * special forms */ @@ -71,6 +83,18 @@ lisp_type( struct stack_frame *frame, struct cons_pointer env ); struct cons_pointer lisp_progn( struct stack_frame *frame, struct cons_pointer env ); +/** + * Special form: conditional. Each arg is expected to be a list; if the first + * item in such a list evaluates to non-NIL, the remaining items in that list + * are evaluated in turn and the value of the last returned. If no arg (clause) + * has a first element which evaluates to non NIL, then NIL is returned. + * @param frame My stack frame. + * @param env My environment (ignored). + * @return the value of the last form of the first successful clause. + */ +struct cons_pointer +lisp_cond( struct stack_frame *frame, struct cons_pointer env ); + /* * neither, at this stage, really */ diff --git a/unit-tests/cond.sh b/unit-tests/cond.sh new file mode 100644 index 0000000..227f9b3 --- /dev/null +++ b/unit-tests/cond.sh @@ -0,0 +1,24 @@ +#!/bin/bash + +expected='5' +actual=`echo "(cond ((equal 2 2) 5))" | target/psse 2> /dev/null | head -2 | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +expected='"should"' +actual=`echo "(cond ((equal 2 3) \"shouldn't\")(t \"should\"))" | target/psse 2> /dev/null | head -2 | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" + exit 0 +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi diff --git a/unit-tests/progn.sh b/unit-tests/progn.sh index 84921da..94c7f40 100644 --- a/unit-tests/progn.sh +++ b/unit-tests/progn.sh @@ -6,13 +6,13 @@ actual=`echo "(progn '((add 2 3)))" | target/psse 2> /dev/null | head -2 | tail if [ "${expected}" = "${actual}" ] then echo "OK" - exit 0 else echo "Fail: expected '${expected}', got '${actual}'" + exit 1 fi expected='"foo"' -actual=`echo "(progn '((add 2.5 3) \"foo\"))" | target/psse 2> /dev/null | head -1` +actual=`echo "(progn '((add 2.5 3) \"foo\"))" | target/psse 2> /dev/null | head -2 | tail -1` if [ "${expected}" = "${actual}" ] then