From e7dffcad2cae9bc690b643a8072a2a33a94c9e80 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 30 Dec 2018 19:07:07 +0000 Subject: [PATCH] Not really making progress. --- lisp/not-working-yet.lisp | 6 ++++ lisp/types.lisp | 7 ----- src/init.c | 1 + src/ops/lispops.c | 60 ++++++++++++++++++++++++++++++++------- src/ops/lispops.h | 4 +++ src/ops/read.c | 7 +++-- 6 files changed, 66 insertions(+), 19 deletions(-) create mode 100644 lisp/not-working-yet.lisp diff --git a/lisp/not-working-yet.lisp b/lisp/not-working-yet.lisp new file mode 100644 index 0000000..0f3a8c2 --- /dev/null +++ b/lisp/not-working-yet.lisp @@ -0,0 +1,6 @@ +(set! or (lambda values + "True if any of `values` are non-nil." + (cond + ((nil? values) nil) + ((car values) t) + (t (eval (cons 'or (cdr values))))))) diff --git a/lisp/types.lisp b/lisp/types.lisp index cba1ef6..7f7bf8c 100644 --- a/lisp/types.lisp +++ b/lisp/types.lisp @@ -15,10 +15,3 @@ (set! true? (lambda (o) "True if o is the canonical true value." (= (type o) "TRUE") ) ) (set! write? (lambda (o) "True if o is a write stream." (= (type o) "WRIT") ) ) -(set! or (lambda values - "True if any of `values` are non-nil." - (cond ((car values) t) (t (apply 'or (cdr values)))))) - -(set! number? - (lambda (o) - "I don't yet have an `or` operator diff --git a/src/init.c b/src/init.c index 15fd8e4..f446dc4 100644 --- a/src/init.c +++ b/src/init.c @@ -146,6 +146,7 @@ int main( int argc, char *argv[] ) { bind_function( L"progn", &lisp_progn ); bind_function( L"reverse", &lisp_reverse ); bind_function( L"set", &lisp_set ); + bind_function( L"source", &lisp_source ); bind_function( L"subtract", &lisp_subtract ); bind_function( L"throw", &lisp_exception ); bind_function( L"type", &lisp_type ); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 1913406..476cf46 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -1035,18 +1035,21 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, * are not visible. So copy changes made in the oblist into the enviroment. * TODO: the whole process of resolving symbol values needs to be revisited * when we get onto namespaces. */ - struct cons_pointer cursor = oblist; - while ( !nilp( cursor ) && !eq( cursor, old_oblist ) ) { - debug_print - ( L"lisp_repl: copying new oblist binding into REPL environment:\n", - DEBUG_REPL ); - debug_print_object( c_car( cursor ), DEBUG_REPL ); - debug_println( DEBUG_REPL ); + if ( !eq( oblist, old_oblist ) ) { + struct cons_pointer cursor = oblist; - new_env = make_cons( c_car( cursor ), new_env ); - cursor = c_cdr( cursor ); + while ( !nilp( cursor ) && !eq( cursor, old_oblist ) ) { + debug_print + ( L"lisp_repl: copying new oblist binding into REPL environment:\n", + DEBUG_REPL ); + debug_print_object( c_car( cursor ), DEBUG_REPL ); + debug_println( DEBUG_REPL ); + + new_env = make_cons( c_car( cursor ), new_env ); + cursor = c_cdr( cursor ); + } + old_oblist = oblist; } - old_oblist = oblist; println( os ); @@ -1079,3 +1082,40 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, return expr; } + +/** + * (source object) + * + * Function. + * Return the source code of the object, if it is an executable + * and has source code. + */ +struct cons_pointer lisp_source( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + struct cons_space_object cell = pointer2cell( frame->arg[0] ); + + switch ( cell.tag.value ) { + case FUNCTIONTV: + result = cell.payload.function.source; + break; + case SPECIALTV: + result = cell.payload.special.source; + break; + case LAMBDATV: + result = make_cons( c_string_to_lisp_symbol( L"lambda" ), + make_cons( cell.payload.lambda.args, + cell.payload.lambda.body ) ); + break; + case NLAMBDATV: + result = make_cons( c_string_to_lisp_symbol( L"nlambda" ), + make_cons( cell.payload.lambda.args, + cell.payload.lambda.body ) ); + break; + } + // TODO: suffers from premature GC, and I can't see why! + inc_ref( result ); + + return result; +} diff --git a/src/ops/lispops.h b/src/ops/lispops.h index f9cd8ba..7868c4b 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -197,3 +197,7 @@ struct cons_pointer throw_exception( struct cons_pointer message, struct cons_pointer lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); + +struct cons_pointer lisp_source( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); diff --git a/src/ops/read.c b/src/ops/read.c index 2a8522c..410a27f 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -275,6 +275,9 @@ struct cons_pointer read_string( FILE * input, wint_t initial ) { result = make_string( initial, NIL ); break; case '"': + /* making a string of the null character means we can have an empty + * string. Just returning NIL here would make an empty string + * impossible. */ result = make_string( '\0', NIL ); break; default: @@ -302,9 +305,9 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) { break; case ')': /* - * unquoted strings may not include right-parenthesis + * symbols may not include right-parenthesis */ - result = make_symbol( '\0', NIL ); + result = NIL; /* * push back the character read */