diff --git a/src/c/ops/eval_apply.c b/src/c/ops/eval_apply.c index 4b18e8c..ad8f3e6 100644 --- a/src/c/ops/eval_apply.c +++ b/src/c/ops/eval_apply.c @@ -246,7 +246,7 @@ struct pso_pointer eval_forms( struct pso_pointer frame_pointer ) { dec_ref( next_pointer ); } - return c_reverse( result ); + return c_reverse( frame_pointer, result ); } /** @@ -546,11 +546,10 @@ struct pso_pointer make_fn_frame(struct pso_pointer previous, args++; } - new_frame->payload.stack_frame.more = inc_ref( c_reverse( more)); + new_frame->payload.stack_frame.more = push_local( previous, c_reverse( previous, more)); } new_frame->payload.stack_frame.args = args; - dec_ref(next_pointer); return new_pointer; } @@ -905,9 +904,11 @@ struct pso_pointer lisp_source( struct pso_pointer frame_pointer) { cell->payload.lambda.body ) ); break; case NLAMBDATV: - result = make_cons( frame_pointer, c_string_to_lisp_symbol( frame_pointer, L"nλ" ), - make_cons( frame_pointer, cell->payload.lambda.args, - cell->payload.lambda.body ) ) ); + result = make_cons( frame_pointer, + c_string_to_lisp_symbol( frame_pointer, L"nλ" ), + make_cons( frame_pointer, + cell->payload.lambda.args, + cell->payload.lambda.body ) ); break; } push_local( frame_pointer, result ); @@ -942,57 +943,53 @@ struct pso_pointer lisp_list( struct pso_pointer frame_pointer ) { * these bindings are bound. * This is `let*` in Common Lisp parlance; `let` in Clojure parlance. */ -struct pso_pointer lisp_let( struct pso4 *frame, - struct pso_pointer frame_pointer, - struct pso_pointer env ) { - struct pso_pointer bindings = env; +struct pso_pointer lisp_let( struct pso_pointer frame_pointer ) { + struct pso4* frame = pointer_to_pso4( frame_pointer); + struct pso_pointer bindings = fetch_env(frame_pointer); struct pso_pointer result = nil; for ( struct pso_pointer cursor = fetch_arg( frame, 0); - tp( cursor ); cursor = c_cdr( cursor ) ) { + c_truep( cursor ); cursor = c_cdr( cursor ) ) { struct pso_pointer pair = c_car( cursor ); struct pso_pointer symbol = c_car( pair ); + struct pso_pointer next_pointer = push_local( frame_pointer, make_frame_with_env( 0, frame_pointer, bindings)); + if ( symbolp( symbol ) ) { + add_arg(next_pointer, c_cdr(pair)); struct pso_pointer val = - eval_form( frame, frame_pointer, c_cdr( pair ), - bindings ); + eval_form( next_pointer ); - debug_print_binding( symbol, val, false, DEBUG_BIND ); + // debug_print_binding( symbol, val, false, DEBUG_BIND ); - bindings = cons( cons( symbol, val ), bindings ); + bindings = make_cons( frame_pointer, make_cons( frame_pointer, symbol, val ), bindings ); } else { result = - throw_exception( c_string_to_lisp_symbol( L"let" ), - c_string_to_lisp_string - ( L"Let: cannot bind, not a symbol" ), + throw_exception( c_string_to_lisp_symbol( frame_pointer, L"let" ), + c_string_to_lisp_string( frame_pointer, L"Let: cannot bind, not a symbol" ), frame_pointer ); break; } } - debug_print( L"\nlet: bindings complete.\n", DEBUG_BIND, 0 ); + if (!exceptionp(result)) { + debug_print( L"\nlet: bindings complete.\n", DEBUG_BIND, 0 ); - struct pso_pointer progn_pointer = make_frame_with_env( 0, frame_pointer, env); - progn_frame = pointer_to_pso4(progn_pointer); - int a = 1; - for (; a < frame->payload.stack_frame.args && a < args_in_frame; a++) { - progn_frame->payload.stack_frame.arg[a-1] = fetch_arg( frame, a); - progn_frame->payload.stack_frame.args ++; - } - if ( a < frame->payload.stack_frame.args) { - progn_frame->payload.stack_frame.arg[a-1] = fetch_arg( frame, a); - } + struct pso_pointer progn_pointer = make_frame_with_env( 0, frame_pointer, bindings); + struct pso4* progn_frame = pointer_to_pso4(progn_pointer); - /* i.e., no exception yet */ - for ( int form = 1; - !exceptionp( result ) && form < frame->payload.stack_frame.args; - form++ ) { - result = - eval_form( frame, frame_pointer, fetch_arg( frame, form ), - bindings ); - } + int a = 1; + for (; a < frame->payload.stack_frame.args && a < args_in_frame; a++) { + progn_frame->payload.stack_frame.arg[a-1] = fetch_arg( frame, a); + progn_frame->payload.stack_frame.args ++; + } + if ( a < frame->payload.stack_frame.args) { + progn_frame->payload.stack_frame.arg[a-1] = fetch_arg( frame, a); + progn_frame->payload.stack_frame.more = c_cdr( frame->payload.stack_frame.more); + } + result = lisp_progn(progn_pointer); + } return result; } @@ -1011,7 +1008,7 @@ struct pso_pointer lisp_and( struct pso4 *frame, bool accumulator = true; struct pso_pointer result = frame->payload.stack_frame.more; - for ( int a = 0; accumulator == t && a < frame->payload.stack_frame.args; + for ( int a = 0; accumulator == true && a < frame->payload.stack_frame.args; a++ ) { accumulator = truthy( fetch_arg( frame, a ) ); } diff --git a/src/c/ops/mapcar.c b/src/c/ops/mapcar.c index a929d01..57571a0 100644 --- a/src/c/ops/mapcar.c +++ b/src/c/ops/mapcar.c @@ -30,7 +30,7 @@ struct pso_pointer lisp_mapcar( struct pso_pointer frame_pointer ) { for ( struct pso_pointer c = frame->payload.stack_frame.arg[1]; c_truep( c ); c = c_cdr( c ) ) { struct pso_pointer expr = - cons( frame->payload.stack_frame.arg[0], cons( c_car( c ), nil ) ); + cons( frame->payload.stack_frame.arg[0], make_cons( frame_pointer, c_car( c ), nil ) ); debug_printf( DEBUG_EVAL, 0, U"Mapcar %d, evaluating ", i ); debug_print_object( expr, DEBUG_EVAL, 0 ); diff --git a/src/c/ops/reverse.c b/src/c/ops/reverse.c index 720d348..296aaf3 100644 --- a/src/c/ops/reverse.c +++ b/src/c/ops/reverse.c @@ -27,7 +27,11 @@ #include "ops/string_ops.h" #include "ops/truth.h" - +/** + * @brief reverse a sequence + * + * (reverse sequence) + */ struct pso_pointer reverse( struct pso_pointer frame_pointer ) { struct pso_pointer result = nil; struct pso_pointer sequence = diff --git a/src/c/ops/reverse.h b/src/c/ops/reverse.h index 5519523..01b5776 100644 --- a/src/c/ops/reverse.h +++ b/src/c/ops/reverse.h @@ -16,6 +16,8 @@ #include "memory/pointer.h" -struct pso_pointer c_reverse( struct pso_pointer sequence ); +struct pso_pointer reverse( struct pso_pointer frame_pointer ); +struct pso_pointer c_reverse( struct pso_pointer frame_pointer, + struct pso_pointer sequence ); #endif diff --git a/src/c/ops/string_ops.c b/src/c/ops/string_ops.c index 47e30a3..54dbc15 100644 --- a/src/c/ops/string_ops.c +++ b/src/c/ops/string_ops.c @@ -25,7 +25,9 @@ #include "ops/truth.h" +#include "payloads/cons.h" #include "payloads/exception.h" +#include "payloads/keyword.h" #include "payloads/symbol.h" @@ -67,7 +69,7 @@ uint32_t calculate_hash( wint_t c, struct pso_pointer ptr ) { * has one character and a pointer to the next; in the last cell the * pointer to next is nil. * - * NOTE THAT: in 0.1.X, we may allocate symbols and keywords as arrays of + * NOTE THAT: in 0.1.X, we may allocate symbols and keywords as arrays of * char32_t in larger pso classes, so this function may be only for strings * (and thus simpler). */ diff --git a/src/c/ops/truth.h b/src/c/ops/truth.h index e775ff2..fb73682 100644 --- a/src/c/ops/truth.h +++ b/src/c/ops/truth.h @@ -28,4 +28,6 @@ struct pso_pointer or( struct pso_pointer frame_pointer ); bool c_nilp( struct pso_pointer p ); bool c_truep( struct pso_pointer p ); +#define truthy(p)(!c_nilp(p)) + #endif diff --git a/src/c/payloads/cons.h b/src/c/payloads/cons.h index 131eb88..7f56384 100644 --- a/src/c/payloads/cons.h +++ b/src/c/payloads/cons.h @@ -11,6 +11,7 @@ #define __psse_payloads_cons_h #include +#include "memory/node.h" #include "memory/pointer.h" #include "memory/pso2.h" #include "memory/pso4.h" @@ -32,7 +33,7 @@ struct pso_pointer make_cons( struct pso_pointer frame_pointer, struct pso_pointer car, struct pso_pointer cdr ); /** - * macro short-cuts for make_cons. + * macro short-cuts for make_cons. */ // #define make_cons(frame_pointer,car,cdr) (cons(make_frame(2, frame_pointer, car, cdr))) diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index b0b2730..066642d 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -24,12 +24,46 @@ #include "ops/reverse.h" #include "ops/list_ops.h" +#include "ops/stack_ops.h" + +/** + * @brief Add an argument to this (already initialised) stack frame, updating + * the args count. + * + * TODO: unit test this to death and back! + * + * @param frame_pointer a pointer to the frame to be modified. + * @param arg_pointer the pointer to the arg to be added. + * + * @return `nil` on success; potentially an exception on failure. + */ +struct pso_pointer add_arg( struct pso_pointer frame_pointer, struct pso_pointer arg_pointer) { + struct pso4* frame = pointer_to_pso4( frame_pointer); + struct pso_pointer result = nil; + + if (frame->payload.stack_frame.args < args_in_frame) { + frame->payload.stack_frame.arg[frame->payload.stack_frame.args++] = push_local(frame_pointer, arg_pointer); + } else { + struct pso_pointer new_more = c_reverse( frame_pointer, + make_cons( frame_pointer, + arg_pointer, + c_reverse( frame_pointer, frame->payload.stack_frame.more))); + if (exceptionp(new_more)) { + result = new_more; + } else { + frame->payload.stack_frame.more = + push_local( frame_pointer, new_more); + } + } + + return result; +} /** * @brief Construct a stack frame with this `previous` pointer, and arguments * taken from the remaining arguments to this function, which should all be * struct pso_pointer. - * + * * @param arg_count the count of arguments to the Lisp function. * @param previous the parent stack frame. * @param ... the arguments to the Lisp function, all of which must be of type @@ -42,6 +76,9 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, va_list args; va_start( args, previous ); + /* NOTE! It is really important not to `push_local` the new_pointer here, + * since that would stop stack frames and all the temporary objects they + * curate ever being garbage collected! */ struct pso_pointer new_pointer = allocate( previous, STACKTAG, 4 ); struct pso4 *new_frame = pointer_to_pso4( new_pointer ); @@ -85,7 +122,7 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, more_args ); } - new_frame->payload.stack_frame.more = c_reverse( more_args ); + new_frame->payload.stack_frame.more = c_reverse( previous, more_args ); } else { for ( ; cursor < args_in_frame; cursor++ ) { new_frame->payload.stack_frame.arg[cursor] = nil; @@ -103,7 +140,10 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, * @brief variant of make_frame with an explicit replacement environment, to * be called by functions like `binding` which add bindings to their upstack * environment. - * + * + * TODO: someone who really understood how C varargs functions work could save + * a lot of potentially error prone code by having this call `make_frame`, q.v. + * * @param arg_count the count of arguments to the Lisp function. * @param previous the parent stack frame. * @param env the modified environment @@ -119,6 +159,9 @@ struct pso_pointer make_frame_with_env( int arg_count, va_start( args, env ); struct pso4 *prev_frame = pointer_to_pso4( previous ); + /* NOTE! It is really important not to `push_local` the new_pointer here, + * since that would stop stack frames and all the temporary objects they + * curate ever being garbage collected! */ struct pso_pointer new_pointer = allocate( previous, STACKTAG, 4 ); struct pso4 *new_frame = pointer_to_pso4( new_pointer ); @@ -159,7 +202,7 @@ struct pso_pointer make_frame_with_env( int arg_count, more_args ); } - new_frame->payload.stack_frame.more = c_reverse( more_args ); + new_frame->payload.stack_frame.more = c_reverse( previous, more_args ); } else { for ( ; cursor < args_in_frame; cursor++ ) { new_frame->payload.stack_frame.arg[cursor] = nil; @@ -189,6 +232,9 @@ struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer argvalues, struct pso_pointer env ) { struct pso4 *prev_frame = pointer_to_pso4( previous ); + /* NOTE! It is really important not to `push_local` the new_pointer here, + * since that would stop stack frames and all the temporary objects they + * curate ever being garbage collected! */ struct pso_pointer new_pointer = allocate( previous, STACKTAG, 4 ); struct pso4 *new_frame = pointer_to_pso4( new_pointer ); struct pso_pointer arg_length = diff --git a/src/c/payloads/stack.h b/src/c/payloads/stack.h index 5fb9267..d89d705 100644 --- a/src/c/payloads/stack.h +++ b/src/c/payloads/stack.h @@ -20,7 +20,7 @@ #define args_in_frame 8 /** - * A stack frame. + * A stack frame. */ struct stack_frame_payload { /** the previous frame. */ @@ -60,4 +60,6 @@ struct pso_pointer make_frame_with_arglist( struct pso_pointer previous, struct pso_pointer destroy_stack_frame( struct pso_pointer fp, struct pso_pointer env ); +struct pso_pointer add_arg( struct pso_pointer frame_pointer, struct pso_pointer arg_pointer); + #endif