diff --git a/docs/State-of-play.md b/docs/State-of-play.md index eba1311..155aaab 100644 --- a/docs/State-of-play.md +++ b/docs/State-of-play.md @@ -62,6 +62,26 @@ So I think I'm going to put up with the uncollected garbage until we get to that However, any new C code (and there is going to have to be some) *must* be written in the sanitary but bureaucratic pattern. +#### 21:24 + +Well, at the end of the day I think the git log says it all: + +``` +commit 63906fe817d509adb6171a72d16c045c2793ebed (HEAD -> feature/reengineering-17-21) +Author: Simon Brooke +Date: Fri Apr 24 21:20:23 2026 +0100 + + Print is less badly broken. Read is less badly broken. GC is too aggressive. + +commit 22b0160a266999c939c9a21df150542f8b2f0b25 (origin/feature/reengineering-17-21) +Author: Simon Brooke +Date: Fri Apr 24 09:22:06 2026 +0100 + + Builds and runs, but print is badly broken. Need some rethink. +``` + +I could just disable the garbage collector until I've got `eval`/`apply` working. I *believe* that with `eval`/`apply` I'll be able to automate all the garbage collection bookkeeping work. I hope so. Mark and sweep, or even my preferred mark but don't sweep, on a massively parallel machine, just doesn't bear thinking on. + ## 20260421 diff --git a/src/c/io/io.c b/src/c/io/io.c index 8865a0d..9a95c2f 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -371,8 +371,8 @@ struct pso_pointer push_back_character( struct pso_pointer c, struct pso_pointer result = nil; if ( characterp( c ) && readp( r ) ) { if ( url_ungetwc( ( wint_t ) - ( pointer_to_object( c )->payload. - character.character ), + ( pointer_to_object( c )->payload.character. + character ), pointer_to_object( r )->payload.stream.stream ) >= 0 ) { result = t; @@ -399,8 +399,8 @@ struct pso_pointer lisp_close( struct pso_pointer frame_pointer, struct pso_pointer result = nil; if ( readp( fetch_arg( frame, 0 ) ) || writep( fetch_arg( frame, 0 ) ) ) { if ( url_fclose - ( pointer_to_object( fetch_arg( frame, 0 ) )->payload. - stream.stream ) + ( pointer_to_object( fetch_arg( frame, 0 ) )->payload.stream. + stream ) == 0 ) { result = t; } diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index c5fa2b8..aff210b 100644 --- a/src/c/memory/pso.c +++ b/src/c/memory/pso.c @@ -173,11 +173,10 @@ struct pso_pointer inc_ref( struct pso_pointer pointer ) { debug_printf( DEBUG_ALLOC, 0, L"\nIncremented object of type %3.3s, size class %d, " L"at page %u, offset %u to count %u", ( ( char * ) - &( object-> - header. - tag.bytes. - mnemonic - [0] ) ), + & + ( object->header.tag. + bytes.mnemonic + [0] ) ), ( int ) object->header.tag.bytes.size_class, pointer.page, pointer.offset, object->header.count ); if ( vectorpointp( pointer ) ) { diff --git a/src/c/ops/assoc.c b/src/c/ops/assoc.c index aa425ea..9e5672d 100644 --- a/src/c/ops/assoc.c +++ b/src/c/ops/assoc.c @@ -125,8 +125,8 @@ struct pso_pointer assoc( struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer store = or( make_frame( 2, frame_pointer, fetch_arg( frame, 1 ), - frame->payload.stack_frame. - env ) ); + frame->payload. + stack_frame.env ) ); return c_assoc( key, store ); } @@ -147,8 +147,8 @@ struct pso_pointer interned( struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer store = or( make_frame( 2, frame_pointer, fetch_arg( frame, 1 ), - frame->payload.stack_frame. - env ) ); + frame->payload. + stack_frame.env ) ); return c_interned( key, store ); } @@ -169,8 +169,8 @@ struct pso_pointer internedp( struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer store = or( make_frame( 2, frame_pointer, fetch_arg( frame, 1 ), - frame->payload.stack_frame. - env ) ); + frame->payload. + stack_frame.env ) ); return c_internedp( key, store ) ? t : nil; } diff --git a/src/c/ops/eval_apply.c b/src/c/ops/eval_apply.c index 0c8d2a7..e26fc1c 100644 --- a/src/c/ops/eval_apply.c +++ b/src/c/ops/eval_apply.c @@ -10,6 +10,13 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#include +#include +#include +#include +#include + + #include "debug.h" #include "memory/node.h" #include "memory/pointer.h" @@ -20,6 +27,8 @@ #include "memory/tags.h" #include "ops/assoc.h" +#include "ops/bind.h" +#include "ops/reverse.h" #include "ops/stack_ops.h" #include "ops/string_ops.h" #include "ops/truth.h" @@ -28,89 +37,1638 @@ #include "payloads/function.h" #include "payloads/stack.h" -/** - * @brief Apply a function to arguments in an environment. +///** +// * @brief Apply a function to arguments in an environment. +// * +// * * (apply fn args) +// */ +//struct pso_pointer apply( struct pso_pointer frame_pointer ) { +// +//// TODO. +// +//} +// +///** +// * @brief Evaluate a form, in an environment +// * +// * * (eval form) +// */ +//struct pso_pointer eval( struct pso_pointer frame_pointer ) { +// struct pso4 *frame = pointer_to_pso4( frame_pointer ); +// +// struct pso_pointer arg = fetch_arg( frame, 0 ); +// struct pso_pointer result = nil; +// +// if ( !c_c_nilp( arg ) ) { +// switch ( get_tag_value( arg ) ) { +// // case CONSTV: +// // result = eval_cons( frame, frame_pointer, env); +// // break; +// case INTEGERTV: +// case KEYTV: +// case NILTV: +// case STRINGTV: +// // self evaluating +// result = nil; +// break; +// case SYMBOLTV: +// result = c_assoc( arg, fetch_env( frame_pointer ) ); +// break; +// // case LAMBDATV: +// // result = eval_lambda( frame, frame_pointer, env); +// // break; +// // case NLAMBDATV: +// // result = eval_nlambda( frame, frame_pointer, env); +// // break; +// // case SPECIALTV: +// // result = eval_special( frame, frame_pointer, env); +// // break; +// default: +//#ifdef DEBUG +// struct pso2 *object = pointer_to_object( arg ); +// debug_printf( DEBUG_EVAL, 0, +// L"Can't yet evaluate objects of type %3.3s\n", +// object->header.tag.bytes.mnemonic[0] ); +// debug_print_object( arg, DEBUG_EVAL, 2 ); +// debug_println( DEBUG_EVAL, 0 ); +//#endif +// result = make_exception( make_frame( 1, frame_pointer, +// make_cons( frame_pointer, +// c_string_to_lisp_string +// ( frame_pointer, +// L"Can't yet evaluate things of this type: " ), +// arg ), +// make_cons( frame_pointer, +// make_cons +// ( frame_pointer, +// c_string_to_lisp_keyword +// ( frame_pointer, +// L"tag" ), +// get_tag_string +// ( frame_pointer, +// arg ) ), +// nil ), nil ) ); +// } +// } +// +// if ( exceptionp( result ) ) { +// struct pso3 *x = +// ( struct pso3 * ) pointer_to_object_with_tag_value( result, +// EXCEPTIONTV ); +// +// if ( c_c_nilp( x->payload.exception.stack ) ) { +// x->payload.exception.stack = frame_pointer; +// } +// } +// +// return result; +//} +/* + * lispops.c * - * * (apply fn args) + * List processing operations. + * + * The general idea here is that a list processing operation is a + * function which takes two arguments, both pso_pointers: + * + * 1. args, the argument list to this function; + * 2. env, the environment in which this function should be evaluated; + * + * and returns a pso_pointer, the result. + * + * They must all have the same signature so that I can call them as + * function pointers. + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. */ -struct pso_pointer apply( struct pso_pointer frame_pointer ) { -// TODO. +/** + * 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 pso_pointer eval_form( struct pso_pointer frame_pointer ) { + struct pso_pointer form = + pointer_to_pso4( frame_pointer )->payload.stack_frame.arg[0]; +#ifdef DEBUG + debug_print( L"eval_form: ", DEBUG_EVAL, 0 ); + debug_print_object( form, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL, 0 ); +#endif + struct pso_pointer result = form; + switch ( pointer_to_object( form )->header.tag.value & 0xfffff ) { + /* things which evaluate to themselves */ + case EXCEPTIONTV: + case FREETV: // shouldn't happen, but anyway... + case INTEGERTV: + case KEYTV: + case LOOPTV: // don't think this should happen... + case NILTV: + case RATIOTV: + case REALTV: + case READTV: + case STRINGTV: + case TIMETV: + case TRUETV: + case WRITETV: + break; + default: + { + struct pso_pointer next_pointer = + make_frame( 0, frame_pointer ); + + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct pso4 *next = pointer_to_pso4( next_pointer ); + next->payload.stack_frame.arg[0] = form; + next->payload.stack_frame.args = 1; + + result = + push_local( frame_pointer, lisp_eval( next_pointer ) ); + + if ( !exceptionp( result ) ) { + /* if we're returning an exception, we should NOT free the + * stack frame. Corollary is, when we free an exception, we + * should free all the frames it's holding on to. */ + dec_ref( next_pointer ); + } + } + } + break; + } + + debug_print( L"eval_form ", DEBUG_EVAL, 0 ); + debug_print_object( form, DEBUG_EVAL, 0 ); + debug_print( L" returning: ", DEBUG_EVAL, 0 ); + debug_print_object( result, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL, 0 ); + + return result; } /** - * @brief Evaluate a form, in an environment - * - * * (eval form) + * Evaluate all the forms in this `list` in the context of this stack `frame` + * and this `env`, and return a list of their values. If the arg passed as + * `list` is not in fact a list, return nil. + * @param frame the stack frame. + * @param list the list of forms to be evaluated. + * @param env the evaluation environment. + * @return a list of the the results of evaluating the forms. */ -struct pso_pointer eval( struct pso_pointer frame_pointer ) { - struct pso4 *frame = pointer_to_pso4( frame_pointer ); - - struct pso_pointer arg = fetch_arg( frame, 0 ); +struct pso_pointer eval_forms( struct pso_pointer frame_pointer ) { + struct pso_pointer list = + pointer_to_pso4( frame_pointer )->payload.stack_frame.arg[0]; struct pso_pointer result = nil; - if ( !c_nilp( arg ) ) { - switch ( get_tag_value( arg ) ) { - // case CONSTV: - // result = eval_cons( frame, frame_pointer, env); - // break; - case INTEGERTV: - case KEYTV: - case NILTV: - case STRINGTV: - // self evaluating - result = nil; - break; - case SYMBOLTV: - result = c_assoc( arg, fetch_env( frame_pointer ) ); - break; - // case LAMBDATV: - // result = eval_lambda( frame, frame_pointer, env); - // break; - // case NLAMBDATV: - // result = eval_nlambda( frame, frame_pointer, env); - // break; - // case SPECIALTV: - // result = eval_special( frame, frame_pointer, env); - // break; - default: -#ifdef DEBUG - struct pso2 *object = pointer_to_object( arg ); - debug_printf( DEBUG_EVAL, 0, - L"Can't yet evaluate objects of type %3.3s\n", - object->header.tag.bytes.mnemonic[0] ); - debug_print_object( arg, DEBUG_EVAL, 2 ); - debug_println( DEBUG_EVAL ); -#endif - result = make_exception( make_frame( 1, frame_pointer, + while ( consp( list ) ) { + struct pso_pointer next_pointer = + inc_ref( make_frame( 1, frame_pointer, c_car( list ) ) ); + result = push_local( frame_pointer, + make_cons( frame_pointer, + eval_form( next_pointer ), result ) ); + list = c_cdr( list ); + + dec_ref( next_pointer ); + } + + return c_reverse( result ); +} + +/** + * OK, the idea here (and I know this is less than perfect) is that the basic `try` + * special form in PSSE takes two arguments, the first, `body`, being a list of forms, + * and the second, `catch`, being a catch handler (which is also a list of forms). + * Forms from `body` are evaluated in turn until one returns an exception object, + * or until the list is exhausted. If the list was exhausted, then the value of + * evaluating the last form in `body` is returned. If an exception was encountered, + * then each of the forms in `catch` is evaluated and the value of the last of + * those is returned. + * + * This is experimental. It almost certainly WILL change. + */ +struct pso_pointer lisp_try( struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso_pointer body_frame = + inc_ref( make_frame( 1, frame_pointer, fetch_arg( frame, 0 ) ) ); + + result = push_local( frame_pointer, progn( body_frame ) ); + + dec_ref( body_frame ); + + if ( exceptionp( result ) ) { + // TODO: need to put the exception into the environment! + struct pso_pointer catch_frame = + inc_ref( make_frame_with_env( 1, frame_pointer, + make_cons( frame_pointer, make_cons( frame_pointer, - c_string_to_lisp_string + c_string_to_lisp_symbol ( frame_pointer, - L"Can't yet evaluate things of this type: " ), - arg ), - make_cons( frame_pointer, - make_cons - ( frame_pointer, - c_string_to_lisp_keyword - ( frame_pointer, - L"tag" ), - get_tag_string - ( frame_pointer, - arg ) ), - nil ), nil ) ); + L"*exception*" ), + result ), + fetch_env + ( frame_pointer ) ), + frame->payload.stack_frame. + arg[1] ) ); + result = push_local( progn( catch_frame ) ); + + dec_ref( catch_frame ); + } + + return result; +} + + +/** + * Return the object list (root namespace). + * + * * (oblist) + * + * @param frame the stack frame in which the expression is to be interpreted; + * @param frame_pointer a pointer to my pso4. + * @param env my environment (ignored). + * @return the root namespace. + */ +struct pso_pointer +lisp_oblist( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + return oblist; +} + +/** + * Used to construct the body for `lambda` and `nlambda` expressions. + */ +struct pso_pointer compose_body( struct pso_pointer frame_pointer ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso_pointer body = frame->payload.stack_frame.more; + + for ( int i = args_in_frame - 1; i > 0; i-- ) { + if ( !c_nilp( body ) ) { + body = + make_cons( frame_pointer, frame->payload.stack_frame.arg[i], + body ); + } else if ( !c_nilp( frame->payload.stack_frame.arg[i] ) ) { + body = + make_cons( frame_pointer, frame->payload.stack_frame.arg[i], + body ); } } - if ( exceptionp( result ) ) { - struct pso3 *x = - ( struct pso3 * ) pointer_to_object_with_tag_value( result, - EXCEPTIONTV ); + debug_print( L"compose_body returning ", DEBUG_LAMBDA, 0 ); + debug_dump_object( body, DEBUG_LAMBDA, 0 ); - if ( c_nilp( x->payload.exception.stack ) ) { - x->payload.exception.stack = frame_pointer; + return body; +} + +/** + * Construct an interpretable function. *NOTE* that if `args` is a single symbol + * rather than a list, a varargs function will be created. + * + * (lambda args body) + * + * @param frame the stack frame in which the expression is to be interpreted; + * @param frame_pointer a pointer to my pso4. + * @param env the environment in which it is to be intepreted. + * @return an interpretable function with these `args` and this `body`. + */ +//struct pso_pointer +//lisp_lambda( struct pso_pointer frame_pointer ) { +// return make_lambda( frame_pointer, frame->payload.stack_frame.arg[0], compose_body( frame_pointer ) ); +//} + +/** + * Construct an interpretable special form. *NOTE* that if `args` is a single symbol + * rather than a list, a varargs special form will be created. + * + * (nlambda args body) + * + * @param frame the stack frame in which the expression is to be interpreted; + * @param frame_pointer a pointer to my pso4. + * @param env the environment in which it is to be intepreted. + * @return an interpretable special form with these `args` and this `body`. + */ +//struct pso_pointer +//lisp_nlambda( struct pso_pointer frame_pointer, +// struct pso_pointer env ) { +// return make_nlambda( frame->payload.stack_frame.arg[0], compose_body( frame_pointer ) ); +//} + + +/** + * Evaluate a lambda or nlambda expression. + */ +struct pso_pointer +eval_lambda( struct pso4 *frame, + struct pso_pointer frame_pointer, struct pso_pointer env ) { + struct pso_pointer result = nil; + struct pso2 *cell = + pointer_to_object( fetch_arg( pointer_to_pso4( frame_pointer ), 0 ) ); + struct pso_pointer new_env = fetch_env( frame_pointer ); + struct pso_pointer names = cell->payload.lambda.args; + struct pso_pointer body = cell->payload.lambda.body; +#ifdef DEBUG + debug_print( L"eval_lambda called\n", DEBUG_LAMBDA, 0 ); + debug_println( DEBUG_LAMBDA ); +#endif + + if ( consp( names ) ) { + /* if `names` is a list, bind successive items from that list + * to values of arguments */ + for ( int i = 0; i < frame->payload.stack_frame.args && consp( names ); + i++ ) { + struct pso_pointer name = c_car( names ); + struct pso_pointer val = frame->payload.stack_frame.arg[i]; + + new_env = + make_cons( frame_pointer, + make_cons( frame_pointer, name, val ), new_env ); + //debug_print_binding( name, val, false, DEBUG_BIND ); + + names = c_cdr( names ); + } + + /* \todo if there's more than `args_in_frame` arguments, bind those too. */ + } else if ( symbolp( names ) ) { + /* if `names` is a symbol, rather than a list of symbols, + * then bind a list of the values of args to that symbol. */ + /* \todo eval all the things in frame->payload.stack_frame.more */ +// struct pso_pointer vals = +// eval_forms( frame, frame_pointer, frame->payload.stack_frame.more, env ); + + for ( int i = args_in_frame - 1; i >= 0; i-- ) { + struct pso_pointer next = + make_frame( 1, frame_pointer, fetch_arg( frame, i ) ); + struct pso_pointer val = + push_local( frame_pointer, eval_form( next ) ); + + if ( c_nilp( val ) && c_nilp( vals ) ) { /* nothing */ + } else { + vals = make_cons( frame_pointer, val, vals ); + } + } + + new_env = + make_cons( frame_pointer, make_cons( frame_pointer, names, vals ), + new_env ); + } + + while ( !c_nilp( body ) ) { + struct pso_pointer sexpr = c_car( body ); + body = c_cdr( body ); + + debug_print( L"In lambda: evaluating ", DEBUG_LAMBDA, 0 ); + debug_print_object( sexpr, DEBUG_LAMBDA, 0 ); + // debug_print( L"\t env is: ", DEBUG_LAMBDA , 0); + // debug_print_object( new_env, DEBUG_LAMBDA ); + debug_println( DEBUG_LAMBDA ); + + struct pso_pointer lambda_frame = + inc_ref( make_frame_with_env( 1, frame_pointer, new_env, sexpr ) ); + + result = push_local( frame_pointer, eval_form( lambda_frame ) ); + + dec_ref( lambda_frame ); + + if ( exceptionp( result ) ) { + break; + } + } + + debug_print( L"eval_lambda returning: \n", DEBUG_LAMBDA, 0 ); + debug_print_object( result, DEBUG_LAMBDA, 0 ); + debug_println( DEBUG_LAMBDA ); + + return result; +} + +/** + * if `r` is an exception, and it doesn't have a location, fix up its location from + * the name associated with this fn_pointer, if any. + */ +struct pso_pointer maybe_fixup_exception_location( struct pso_pointer r, + struct pso_pointer + fn_pointer ) { + struct pso_pointer result = r; + + if ( exceptionp( result ) + && ( functionp( fn_pointer ) || specialp( fn_pointer ) ) ) { + struct pso2 **fn_cell = pointer_to_object( fn_pointer ); + + struct pso_pointer payload = + pointer_to_object( result ).payload.exception.payload; + + switch ( get_header.tag.bytes.value & 0xfffff( payload ) ) { + case nilTV: + case CONSTV: + case HASHTV: + { + if ( c_nilp( c_assoc( privileged_keyword_location, + payload ) ) ) { + pointer_to_object( result ).payload.exception.payload = + set( privileged_keyword_location, + c_assoc( privileged_keyword_name, + fn_cell->payload.function.meta ), + payload ); + } + } + break; + default: + pointer_to_object( result ).payload.exception.payload = + cons( cons( privileged_keyword_location, + c_assoc( privileged_keyword_name, + fn_cell->payload.function.meta ) ), + cons( cons + ( privileged_keyword_payload, + payload ), nil ) ); } } return result; } + + +/** + * Internal guts of apply. + * @param frame the stack frame, expected to have only one argument, a list + * comprising something that evaluates to a function and its arguments. + * @param env The evaluation environment. + * @return the result of evaluating the function with its arguments. + */ +struct pso_pointer +c_apply( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + debug_print( L"Entering c_apply\n", DEBUG_EVAL, 0 ); + struct pso_pointer result = nil; + + struct pso_pointer fn_pointer = + eval_form( frame, frame_pointer, + c_car( frame->payload.stack_frame.arg[0] ), env ); + + if ( exceptionp( fn_pointer ) ) { + result = fn_pointer; + } else { + struct pso2 **fn_cell = pointer_to_object( fn_pointer ); + struct pso_pointer args = c_cdr( frame->payload.stack_frame.arg[0] ); + + switch ( get_header.tag.bytes.value & 0xfffff( fn_pointer ) ) { + case EXCEPTIONTV: + /* just pass exceptions straight back */ + result = fn_pointer; + break; + + case FUNCTIONTV: + { + struct pso_pointer exep = nil; + struct pso_pointer next_pointer = + make_pso4( frame_pointer, args, env ); + + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct pso4 *next = pointer_to_pso4( next_pointer ); + + result = maybe_fixup_exception_location( ( * + ( fn_cell-> + payload. + function. + executable ) ) + ( next, + next_pointer, + env ), + fn_pointer ); + dec_ref( next_pointer ); + } + } + break; + + case KEYTV: + result = c_assoc( fn_pointer, + eval_form( frame, + frame_pointer, + c_car( c_cdr + ( frame->payload. + stack_frame.arg[0] ) ), + env ) ); + break; + + case LAMBDATV: + { + struct pso_pointer exep = nil; + struct pso_pointer next_pointer = + make_pso4( frame_pointer, args, env ); + + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct pso4 *next = pointer_to_pso4( next_pointer ); + result = + eval_lambda( fn_cell, next, next_pointer, env ); + if ( !exceptionp( result ) ) { + dec_ref( next_pointer ); + } + } + } + break; + + case HASHTV: + /* \todo: if arg[0] is a CONS, treat it as a path */ + result = c_assoc( eval_form( frame, + frame_pointer, + c_car( c_cdr + ( frame->payload. + stack_frame.arg[0] ) ), + env ), fn_pointer ); + break; + + case NLAMBDATV: + { + struct pso_pointer next_pointer = + make_special_frame( frame_pointer, args, env ); + + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct pso4 *next = pointer_to_pso4( next_pointer ); + result = + eval_lambda( fn_cell, next, next_pointer, env ); + dec_ref( next_pointer ); + } + } + break; + + case SPECIALTV: + { + struct pso_pointer next_pointer = + make_special_frame( frame_pointer, args, env ); + + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + result = maybe_fixup_exception_location( ( * + ( fn_cell-> + payload. + special. + executable ) ) + ( pointer_to_pso4( next_pointer ), next_pointer, env ), fn_pointer ); + debug_print( L"Special form returning: ", DEBUG_EVAL, + 0 ); + debug_print_object( result, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL, 0 ); + dec_ref( next_pointer ); + } + } + break; + + default: + { + int bs = sizeof( wchar_t ) * 1024; + wchar_t *buffer = malloc( bs ); + memset( buffer, '\0', bs ); + swprintf( buffer, bs, + L"Unexpected cell with tag %d (%4.4s) in function position", + fn_cell->header.tag.bytes.value & 0xfffff, + &( fn_cell->tag.bytes[0] ) ); + struct pso_pointer message = + c_string_to_lisp_string( buffer ); + free( buffer ); + result = + throw_exception( c_string_to_lisp_symbol( L"apply" ), + message, frame_pointer ); + } + } + + } + + debug_print( L"c_apply: returning: ", DEBUG_EVAL, 0 ); + debug_print_object( result, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL, 0 ); + + return result; +} + +/** + * Function; evaluate the expression which is the first argument in the frame; + * further arguments are ignored. + * + * * (eval expression) + * + * @param frame my pso4. + * @param frame_pointer a pointer to my pso4. + * @param env my environment. + * @return + * * If `expression` is a number, string, `nil`, or `t`, returns `expression`. + * * If `expression` is a symbol, returns the value that expression is bound + * to in the evaluation environment (`env`). + * * If `expression` is a list, expects the car to be something that evaluates to a + * function or special form: + * * If a function, evaluates all the other top level elements in `expression` and + * passes them in a stack frame as arguments to the function; + * * If a special form, passes the cdr of expression to the special form as argument. + * @exception if `expression` is a symbol which is not bound in `env`. + */ +struct pso_pointer +lisp_eval( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + debug_print( L"Eval: ", DEBUG_EVAL, 0 ); + debug_dump_object( frame_pointer, DEBUG_EVAL, 0 ); + + struct pso_pointer result = frame->payload.stack_frame.arg[0]; + struct pso2 **cell = + pointer_to_object( frame->payload.stack_frame.arg[0] ); + + switch ( cell->header.tag.bytes.value & 0xfffff ) { + case CONSTV: + result = c_apply( frame, frame_pointer, env ); + break; + + case SYMBOLTV: + { + struct pso_pointer canonical = + interned( frame->payload.stack_frame.arg[0], env ); + if ( c_nilp( canonical ) ) { + struct pso_pointer message = + cons( c_string_to_lisp_string + ( L"Attempt to take value of unbound symbol." ), + frame->payload.stack_frame.arg[0] ); + result = + throw_exception( c_string_to_lisp_symbol( L"eval" ), + message, frame_pointer ); + } else { + result = c_assoc( canonical, env ); +// inc_ref( result ); + } + } + break; + /* + * \todo + * the Clojure practice of having a map serve in the function place of + * an s-expression is a good one and I should adopt it; + * H'mmm... this is working, but it isn't here. Where is it? + */ + default: + result = frame->payload.stack_frame.arg[0]; + break; + } + + debug_print( L"Eval returning ", DEBUG_EVAL, 0 ); + debug_dump_object( result, DEBUG_EVAL, 0 ); + + return result; +} + + +/** + * Function; apply the function which is the result of evaluating the + * first argument to the list of values which is the result of evaluating + * the second argument + * + * * (apply fn args) + * + * @param frame my pso4. + * @param frame_pointer a pointer to my pso4. + * @param env my environment. + * @return the result of applying `fn` to `args`. + */ +struct pso_pointer +lisp_apply( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + debug_print( L"Apply: ", DEBUG_EVAL, 0 ); + debug_dump_object( frame_pointer, DEBUG_EVAL, 0 ); + + set_reg( frame, 0, + cons( frame->payload.stack_frame.arg[0], + frame->payload.stack_frame.arg[1] ) ); + set_reg( frame, 1, nil ); + + struct pso_pointer result = c_apply( frame, frame_pointer, env ); + + debug_print( L"Apply returning ", DEBUG_EVAL, 0 ); + debug_dump_object( result, DEBUG_EVAL, 0 ); + + return result; +} + + +/** + * Special form; + * returns its argument (strictly first argument - only one is expected but + * this isn't at this stage checked) unevaluated. + * + * * (quote a) + * + * @param frame my pso4. + * @param frame_pointer a pointer to my pso4. + * @param env my environment (ignored). + * @return `a`, unevaluated, + */ +struct pso_pointer +lisp_quote( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + return frame->payload.stack_frame.arg[0]; +} + + +/** + * Function; + * binds the value of `name` in the `namespace` to value of `value`, altering + * the namespace in so doing. Retuns `value`. + * `namespace` defaults to the oblist. + * \todo doesn't actually work yet for namespaces which are not the oblist. + * + * * (set name value) + * * (set name value namespace) + * + * @param frame my pso4. + * @param frame_pointer a pointer to my pso4. + * @param env my environment (ignored). + * @return `value` + */ +struct pso_pointer +lisp_set( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + struct pso_pointer namespace = + c_nilp( frame->payload.stack_frame.arg[2] ) ? oblist : frame->payload. + stack_frame.arg[2]; + + if ( symbolp( frame->payload.stack_frame.arg[0] ) ) { + deep_bind( frame->payload.stack_frame.arg[0], + frame->payload.stack_frame.arg[1] ); + result = frame->payload.stack_frame.arg[1]; + } else { + result = + throw_exception( c_string_to_lisp_symbol( L"set" ), + cons + ( c_string_to_lisp_string + ( L"The first argument to `set` is not a symbol: " ), + cons( frame->payload.stack_frame.arg[0], + nil ) ), frame_pointer ); + } + + return result; +} + + +/** + * Special form; + * binds `symbol` in the `namespace` to value of `value`, altering + * the namespace in so doing, and returns value. `namespace` defaults to + * the value of `oblist`. + * \todo doesn't actually work yet for namespaces which are not the oblist. + * + * * (set! symbol value) + * * (set! symbol value namespace) + * + * @param frame my pso4. + * @param frame_pointer a pointer to my pso4. + * @param env my environment (ignored). + * @return `value` + */ +struct pso_pointer +lisp_set_shriek( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + struct pso_pointer namespace = frame->payload.stack_frame.arg[2]; + + if ( symbolp( frame->payload.stack_frame.arg[0] ) ) { + struct pso_pointer val = + eval_form( frame, frame_pointer, frame->payload.stack_frame.arg[1], + env ); + deep_bind( frame->payload.stack_frame.arg[0], val ); + result = val; + } else { + result = + throw_exception( c_string_to_lisp_symbol( L"set!" ), + cons + ( c_string_to_lisp_string + ( L"The first argument to `set!` is not a symbol: " ), + cons( frame->payload.stack_frame.arg[0], + nil ) ), frame_pointer ); + } + + return result; +} + +/** + * @return t if `arg` represents an end of string, else false. + * \todo candidate for moving to a memory/string.c file + */ +bool end_of_stringp( struct pso_pointer arg ) { + return c_nilp( arg ) || + ( stringp( arg ) && + pointer_to_object( arg ).payload.string.character == + ( wint_t ) '\0' ); +} + +/** + * Function; look up the value of a `key` in a `store`. + * + * * (assoc key store) + * + * @param frame my pso4. + * @param frame_pointer a pointer to my pso4. + * @param env my environment (ignored). + * @return the value associated with `key` in `store`, or `nil` if not found. + */ +struct pso_pointer +lisp_assoc( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + return c_assoc( frame->payload.stack_frame.arg[0], + c_nilp( frame->payload.stack_frame. + arg[1] ) ? oblist : frame->payload.stack_frame. + arg[1] ); +} + +/** + * @brief `(interned? key store)`: Return `t` if the symbol or keyword `key` is bound in this `store`, else `nil`. + * + * @param frame + * @param frame_pointer + * @param env + * @return struct pso_pointer + */ +struct pso_pointer +lisp_internedp( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = internedp( frame->payload.stack_frame.arg[0], + c_nilp( frame->payload.stack_frame. + arg[1] ) ? oblist : frame-> + payload.stack_frame.arg[1] ); + + if ( exceptionp( result ) ) { + struct pso_pointer old = result; + struct pso2 **cell = &( pointer_to_object( result ) ); + result = + throw_exception( c_string_to_lisp_symbol( L"interned?" ), + cell->payload.exception.payload, frame_pointer ); + dec_ref( old ); + } + + return result; +} + +struct pso_pointer c_keys( struct pso_pointer store ) { + struct pso_pointer result = nil; + + if ( consp( store ) ) { + for ( struct pso_pointer pair = c_car( store ); !c_nilp( pair ); + pair = c_car( store ) ) { + if ( consp( pair ) ) { + result = cons( c_car( pair ), result ); + } else if ( hashmapp( pair ) ) { + result = c_append( hashmap_keys( pair ), result ); + } + + store = c_cdr( store ); + } + } else if ( hashmapp( store ) ) { + result = hashmap_keys( store ); + } + + return result; +} + + + +struct pso_pointer lisp_keys( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + return c_keys( frame->payload.stack_frame.arg[0] ); +} + +/** + * Function: return the number of top level forms in the object which is + * the first (and only) argument, if it is a sequence (which for current + * purposes means a list or a string) + * + * * (count l) + * + * @param frame my pso4. + * @param frame_pointer a pointer to my pso4. + * @param env my environment (ignored). + * @return the number of top level forms in a list, or characters in a + * string, else 0. + */ +struct pso_pointer +lisp_count( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + return acquire_integer( c_count( frame->payload.stack_frame.arg[0] ), + nil ); +} + + + + +/** + * Function; reverse the order of members in s sequence. + * + * * (reverse sequence) + * + * @param frame my pso4. + * @param frame_pointer a pointer to my pso4. + * @param env my environment (ignored). + * @return a sequence like this `sequence` but with the members in the reverse order. + */ +struct pso_pointer lisp_reverse( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + return c_reverse( frame->payload.stack_frame.arg[0] ); +} + + + +/** + * Function: get the Lisp type of the single argument. + * + * * (type expression) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my pso4. + * @param env my environment (ignored). + * @return As a Lisp string, the tag of `expression`. + */ +struct pso_pointer +lisp_type( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + return c_type( frame->payload.stack_frame.arg[0] ); +} + +/** + * Evaluate each of these expressions in this `env`ironment over this `frame`, + * returning only the value of the last. + */ +struct pso_pointer +c_progn( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer expressions, struct pso_pointer env ) { + struct pso_pointer result = nil; + + while ( consp( expressions ) ) { + struct pso_pointer r = result; + + result = eval_form( frame, frame_pointer, c_car( expressions ), env ); + dec_ref( r ); + + expressions = exceptionp( result ) ? nil : c_cdr( expressions ); + } + + return result; +} + + +/** + * Special form; evaluate the expressions which are listed in my arguments + * sequentially and return the value of the last. This function is called 'do' + * in some dialects of Lisp. + * + * * (progn expressions...) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my pso4. + * @param env the environment in which expressions are evaluated. + * @return the value of the last `expression` of the sequence which is my single + * argument. + */ +struct pso_pointer +lisp_progn( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + + for ( int i = 0; + i < args_in_frame && !c_nilp( frame->payload.stack_frame.arg[i] ); + i++ ) { + struct pso_pointer r = result; + + result = + eval_form( frame, frame_pointer, frame->payload.stack_frame.arg[i], + env ); + + dec_ref( r ); + } + + if ( consp( frame->payload.stack_frame.more ) ) { + result = + c_progn( frame, frame_pointer, frame->payload.stack_frame.more, + env ); + } + + return result; +} + +/** + * @brief evaluate a single cond clause; if the test part succeeds return a + * pair whose car is t and whose cdr is the value of the action part + */ +struct pso_pointer eval_cond_clause( struct pso_pointer clause, + struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + +#ifdef DEBUG + debug_print( L"\n\tCond clause: ", DEBUG_EVAL, 0 ); + debug_print_object( clause, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL, 0 ); +#endif + + if ( consp( clause ) ) { + struct pso_pointer val = + eval_form( frame, frame_pointer, c_car( clause ), + env ); + + if ( !c_nilp( val ) ) { + result = + cons( t, + c_progn( frame, frame_pointer, c_cdr( clause ), env ) ); + +#ifdef DEBUG + debug_print( L"\n\t\tCond clause ", DEBUG_EVAL, 0 ); + debug_print_object( clause, DEBUG_EVAL, 0 ); + debug_print( L" succeeded; returning: ", DEBUG_EVAL, 0 ); + debug_print_object( result, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL, 0 ); + } else { + debug_print( L"\n\t\tCond clause ", DEBUG_EVAL, 0 ); + debug_print_object( clause, DEBUG_EVAL, 0 ); + debug_print( L" failed.\n", DEBUG_EVAL, 0 ); +#endif + } + } else { + result = throw_exception( c_string_to_lisp_symbol( L"cond" ), + c_string_to_lisp_string + ( L"Arguments to `cond` must be lists" ), + frame_pointer ); + } + + return result; +} + +/** + * Special form: conditional. Each `clause` 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. + * + * * (cond clauses...) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my pso4. + * @param env the environment in which arguments will be evaluated. + * @return the value of the last expression of the first successful `clause`. + */ +struct pso_pointer +lisp_cond( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + bool done = false; + + for ( int i = 0; ( i < frame->payload.stack_frame.args ) && !done; i++ ) { + struct pso_pointer clause_pointer = fetch_arg( frame, i ); + + result = eval_cond_clause( clause_pointer, frame, frame_pointer, env ); + + if ( !c_nilp( result ) && tp( c_car( result ) ) ) { + result = c_cdr( result ); + done = t; + break; + } + } +#ifdef DEBUG + debug_print( L"\tCond returning: ", DEBUG_EVAL, 0 ); + debug_print_object( result, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL, 0 ); +#endif + + return result; +} + +/** + * Throw an exception with a cause. + * `throw_exception` is a misnomer, because it doesn't obey the calling signature of a + * lisp function; but it is nevertheless to be preferred to make_exception. A + * real `throw_exception`, which does, will be needed. + * object pointing to it. Then this should become a normal lisp function + * which expects a normally bound frame and environment, such that + * frame->payload.stack_frame.arg[0] is the payload, frame->payload.stack_frame.arg[1] is the cause, and frame->payload.stack_frame.arg[2] is the cons-space + * pointer to the frame in which the exception occurred. + */ +struct pso_pointer throw_exception_with_cause( struct pso_pointer location, + struct pso_pointer message, + struct pso_pointer cause, + struct pso_pointer + frame_pointer ) { + struct pso_pointer result = nil; + +#ifdef DEBUG + debug_print( L"\nERROR: `", 511, 0 ); + debug_print_object( message, 511 ); + debug_print( L"` at `", 511, 0 ); + debug_print_object( location, 511 ); + debug_print( L"`\n", 511, 0 ); + if ( !c_nilp( cause ) ) { + debug_print( L"\tCaused by: ", 511, 0 ); + debug_print_object( cause, 511 ); + debug_print( L"`\n", 511, 0 ); + } +#endif + struct pso2 **cell = pointer_to_object( message ); + + if ( cell->header.tag.bytes.value & 0xfffff == EXCEPTIONTV ) { + result = message; + } else { + result = + make_exception( cons + ( cons( privileged_keyword_location, + location ), + cons( cons + ( privileged_keyword_payload, + message ), + ( c_nilp( cause ) ? nil : + cons( cons + ( privileged_keyword_cause, + cause ), nil ) ) ) ), + frame_pointer ); + } + + return result; + +} + +/** + * Throw an exception. + * `throw_exception` is a misnomer, because it doesn't obey the calling signature of a + * lisp function; but it is nevertheless to be preferred to make_exception. A + * real `throw_exception`, which does, will be needed. + * object pointing to it. Then this should become a normal lisp function + * which expects a normally bound frame and environment, such that + * frame->payload.stack_frame.arg[0] is the payload, frame->payload.stack_frame.arg[1] is the cause, and frame->payload.stack_frame.arg[2] is the cons-space + * pointer to the frame in which the exception occurred. + */ +struct pso_pointer +throw_exception( struct pso_pointer location, + struct pso_pointer payload, + struct pso_pointer frame_pointer ) { + return throw_exception_with_cause( location, payload, nil, frame_pointer ); +} + +/** + * Function; create an exception. Exceptions are special in as much as if an + * exception is created in the binding of the arguments of any function, the + * function will return the exception rather than whatever else it would + * normally return. A function which detects a problem it cannot resolve + * *should* return an exception. + * + * * (exception message location) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my pso4. + * @param env the environment in which arguments will be evaluated. + * @return areturns an exception whose message is this `message`, and whose + * stack frame is the parent stack frame when the function is invoked. + * `message` does not have to be a string but should be something intelligible + * which can be read. + * If `message` is itself an exception, returns that instead. + */ +struct pso_pointer +lisp_exception( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer message = frame->payload.stack_frame.arg[0]; + + return exceptionp( message ) ? message : + throw_exception_with_cause( message, frame->payload.stack_frame.arg[1], + frame->payload.stack_frame.arg[2], + frame->previous ); +} + +/** + * Function: the read/eval/print loop. + * + * * (repl) + * * (repl prompt) + * * (repl prompt input_stream output_stream) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my pso4. + * @param env the environment in which epressions will be evaluated. + * @return the value of the last expression read. + */ +struct pso_pointer lisp_repl( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer expr = nil; + +#ifdef DEBUG + debug_print( L"Entering new inner REPL\n\tenv is `", DEBUG_REPL, 0 ); + debug_print_object( env, DEBUG_REPL ); + debug_print( L"`\n", DEBUG_REPL, 0 ); +#endif + + struct pso_pointer input = get_default_stream( t, env ); + struct pso_pointer output = get_default_stream( false, env ); + struct pso_pointer old_oblist = oblist; + struct pso_pointer new_env = env; + + if ( tp( frame->payload.stack_frame.arg[0] ) ) { + new_env = + set( prompt_name, frame->payload.stack_frame.arg[0], new_env ); + } + if ( readp( frame->payload.stack_frame.arg[1] ) ) { + new_env = + set( c_string_to_lisp_symbol( L"*in*" ), + frame->payload.stack_frame.arg[1], new_env ); + input = frame->payload.stack_frame.arg[1]; + } + if ( writep( frame->payload.stack_frame.arg[2] ) ) { + new_env = + set( c_string_to_lisp_symbol( L"*out*" ), + frame->payload.stack_frame.arg[2], new_env ); + output = frame->payload.stack_frame.arg[2]; + } + + inc_ref( input ); + inc_ref( output ); + inc_ref( prompt_name ); + + /* output should NEVER BE nil; but during development it has happened. + * To allow debugging under such circumstances, we need an emergency + * default. */ + URL_FILE *os = + !writep( output ) ? file_to_url_file( stdout ) : + pointer_to_object( output ).payload.stream.stream; + if ( !writep( output ) ) { + debug_print( L"WARNING: invalid output; defaulting!\n", + DEBUG_IO | DEBUG_REPL ); + } + + /* \todo this is subtly wrong. If we were evaluating + * (print (eval (read))) + * then the stack frame for read would have the stack frame for + * eval as parent, and it in turn would have the stack frame for + * print as parent. + */ + while ( readp( input ) && writep( output ) + && !url_feof( pointer_to_object( input ).payload.stream.stream ) ) { + /* OK, here's a really subtle problem: because lists are immutable, anything + * bound in the oblist subsequent to this function being invoked isn't in the + * environment. So, for example, changes to *prompt* or *log* made in the oblist + * 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. */ + /* OK, there's something even more subtle here if the root namespace is a map. + * H'mmmm... + * I think that now the oblist is a hashmap masquerading as a namespace, + * we should no longer have to do this. TODO: test, and if so, delete this + * statement. */ + if ( !eq( oblist, old_oblist ) ) { + struct pso_pointer cursor = oblist; + + while ( !c_nilp( cursor ) && !eq( cursor, old_oblist ) ) { + struct pso_pointer old_new_env = new_env; + 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 = cons( c_car( cursor ), new_env ); + inc_ref( new_env ); + dec_ref( old_new_env ); + cursor = c_cdr( cursor ); + } + old_oblist = oblist; + } + + println( os ); + + struct pso_pointer prompt = c_assoc( prompt_name, new_env ); + if ( !c_nilp( prompt ) ) { + print( os, prompt ); + } + + expr = lisp_read( pointer_to_pso4( frame_pointer ), frame_pointer, + new_env ); + + if ( exceptionp( expr ) + && url_feof( pointer_to_object( input ).payload.stream.stream ) ) { + /* suppress printing end of stream exception */ + dec_ref( expr ); + break; + } + + println( os ); + + print( os, eval_form( frame, frame_pointer, expr, new_env ) ); + + dec_ref( expr ); + } + + if ( c_nilp( output ) ) { + free( os ); + } + dec_ref( input ); + dec_ref( output ); + dec_ref( prompt_name ); + dec_ref( new_env ); + + debug_printf( DEBUG_REPL, L"Leaving inner repl\n" ); + + return expr; +} + +/** + * Function. return the source code of the object which is its first argument, + * if it is an executable and has source code. + * + * * (source object) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my pso4. + * @param env the environment (ignored). + * @return the source of the `object` indicated, if it is a function, a lambda, + * an nlambda, or a spcial form; else `nil`. + */ +struct pso_pointer lisp_source( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + struct pso2 **cell = + pointer_to_object( frame->payload.stack_frame.arg[0] ); + struct pso_pointer source_key = c_string_to_lisp_keyword( L"source" ); + switch ( cell->header.tag.bytes.value & 0xfffff ) { + case FUNCTIONTV: + result = c_assoc( source_key, cell->payload.function.meta ); + break; + case SPECIALTV: + result = c_assoc( source_key, cell->payload.special.meta ); + break; + case LAMBDATV: + result = cons( c_string_to_lisp_symbol( L"lambda" ), + cons( cell->payload.lambda.args, + cell->payload.lambda.body ) ); + break; + case NLAMBDATV: + result = cons( c_string_to_lisp_symbol( L"nlambda" ), + 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; +} + +/** + * A version of append which can conveniently be called from C. + */ +struct pso_pointer c_append( struct pso_pointer l1, struct pso_pointer l2 ) { + switch ( pointer_to_object( l1 ).header.tag.bytes.value & 0xfffff ) { + case CONSTV: + if ( pointer_to_object( l1 ).header.tag.bytes.value & 0xfffff == + pointer_to_object( l2 ).header.tag.bytes.value & 0xfffff ) { + if ( c_nilp( c_cdr( l1 ) ) ) { + return cons( c_car( l1 ), l2 ); + } else { + return cons( c_car( l1 ), c_append( c_cdr( l1 ), l2 ) ); + } + } else { + throw_exception( c_string_to_lisp_symbol( L"append" ), + c_string_to_lisp_string + ( L"Can't append: not same type" ), nil ); + } + break; + case KEYTV: + case STRINGTV: + case SYMBOLTV: + if ( pointer_to_object( l1 ).header.tag.bytes.value & 0xfffff == + pointer_to_object( l2 ).header.tag.bytes.value & 0xfffff ) { + if ( c_nilp( c_cdr( l1 ) ) ) { + return + make_string_like_thing( ( pointer_to_object + ( l1 ).payload.string. + character ), l2, + pointer_to_object( l1 ).header. + tag.bytes.value & 0xfffff ); + } else { + return + make_string_like_thing( ( pointer_to_object + ( l1 ).payload.string. + character ), + c_append( c_cdr( l1 ), l2 ), + pointer_to_object( l1 ).header. + tag.bytes.value & 0xfffff ); + } + } else { + throw_exception( c_string_to_lisp_symbol( L"append" ), + c_string_to_lisp_string + ( L"Can't append: not same type" ), nil ); + } + break; + default: + throw_exception( c_string_to_lisp_symbol( L"append" ), + c_string_to_lisp_string + ( L"Can't append: not a sequence" ), nil ); + break; + } +} + +/** + * should really be overwritten with a version in Lisp, since this is much easier to write in Lisp + */ +struct pso_pointer lisp_append( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = + fetch_arg( frame, ( frame->payload.stack_frame.args - 1 ) ); + + for ( int a = frame->payload.stack_frame.args - 2; a >= 0; a-- ) { + result = c_append( fetch_arg( frame, a ), result ); + } + + return result; +} + +struct pso_pointer lisp_mapcar( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + debug_print( L"Mapcar: ", DEBUG_EVAL, 0 ); + debug_dump_object( frame_pointer, DEBUG_EVAL, 0 ); + int i = 0; + + for ( struct pso_pointer c = frame->payload.stack_frame.arg[1]; tp( c ); + c = c_cdr( c ) ) { + struct pso_pointer expr = + cons( frame->payload.stack_frame.arg[0], cons( c_car( c ), nil ) ); + + debug_printf( DEBUG_EVAL, L"Mapcar %d, evaluating ", i ); + debug_print_object( expr, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL, 0 ); + + struct pso_pointer r = eval_form( frame, frame_pointer, expr, env ); + + if ( exceptionp( r ) ) { + result = r; + inc_ref( expr ); // to protect exception from the later dec_ref + break; + } else { + result = cons( r, result ); + } + debug_printf( DEBUG_EVAL, L"Mapcar %d, result is ", i++ ); + debug_print_object( result, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL, 0 ); + + dec_ref( expr ); + } + + result = consp( result ) ? c_reverse( result ) : result; + + debug_print( L"Mapcar returning: ", DEBUG_EVAL, 0 ); + debug_print_object( result, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL, 0 ); + + return result; +} + +/** + * @brief construct and return a list of arbitrarily many arguments. + * + * @param frame The stack frame. + * @param frame_pointer A pointer to the stack frame. + * @param env The evaluation environment. + * @return struct pso_pointer a pointer to the result + */ +struct pso_pointer lisp_list( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = frame->payload.stack_frame.more; + + for ( int a = + c_nilp( result ) ? frame->payload.stack_frame.args - + 1 : args_in_frame - 1; a >= 0; a-- ) { + result = cons( fetch_arg( frame, a ), result ); + } + + return result; +} + + + +/** + * Special form: evaluate a series of forms in an environment in which + * 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 result = nil; + + for ( struct pso_pointer cursor = frame->payload.stack_frame.arg[0]; + tp( cursor ); cursor = c_cdr( cursor ) ) { + struct pso_pointer pair = c_car( cursor ); + struct pso_pointer symbol = c_car( pair ); + + if ( symbolp( symbol ) ) { + struct pso_pointer val = + eval_form( frame, frame_pointer, c_cdr( pair ), + bindings ); + + debug_print_binding( symbol, val, false, DEBUG_BIND ); + + bindings = cons( cons( 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" ), + frame_pointer ); + break; + } + } + + debug_print( L"\nlet: bindings complete.\n", DEBUG_BIND, 0 ); + + /* 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 ); + } + + /* release the local bindings as they go out of scope! **BUT** + * bindings were consed onto the front of env, so caution... */ + // for (struct pso_pointer cursor = bindings; !eq( cursor, env); cursor = c_cdr(cursor)) { + // dec_ref( cursor); + // } + + return result; + +} + +/** + * @brief Boolean `and` of arbitrarily many arguments. + * + * @param frame The stack frame. + * @param frame_pointer A pointer to the stack frame. + * @param env The evaluation environment. + * @return struct pso_pointer a pointer to the result + */ +struct pso_pointer lisp_and( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + bool accumulator = t; + struct pso_pointer result = frame->payload.stack_frame.more; + + for ( int a = 0; accumulator == t && a < frame->payload.stack_frame.args; + a++ ) { + accumulator = truthy( fetch_arg( frame, a ) ); + } +# + return accumulator ? t : nil; +} + +/** + * @brief Boolean `or` of arbitrarily many arguments. + * + * @param frame The stack frame. + * @param frame_pointer A pointer to the stack frame. + * @param env The evaluation environment. + * @return struct pso_pointer a pointer to the result + */ +struct pso_pointer lisp_or( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + bool accumulator = false; + struct pso_pointer result = frame->payload.stack_frame.more; + + for ( int a = 0; + accumulator == false && a < frame->payload.stack_frame.args; a++ ) { + accumulator = truthy( fetch_arg( frame, a ) ); + } + + return accumulator ? t : nil; +} + +/** + * @brief Logical inverese: if the first argument is `nil`, return `t`, else `nil`. + * + * @param frame The stack frame. + * @param frame_pointer A pointer to the stack frame. + * @param env The evaluation environment. + * @return struct pso_pointer `t` if the first argument is `nil`, else `nil`. + */ +struct pso_pointer lisp_not( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + return c_nilp( frame->payload.stack_frame.arg[0] ) ? t : nil; +} diff --git a/src/c/ops/reverse.c b/src/c/ops/reverse.c index 9bfe934..720d348 100644 --- a/src/c/ops/reverse.c +++ b/src/c/ops/reverse.c @@ -16,8 +16,10 @@ #include "memory/pointer.h" #include "memory/pso.h" #include "memory/pso2.h" +#include "memory/pso4.h" #include "memory/tags.h" +#include "ops/stack_ops.h" #include "payloads/cons.h" #include "payloads/exception.h" #include "payloads/psse_string.h" @@ -25,6 +27,63 @@ #include "ops/string_ops.h" #include "ops/truth.h" + +struct pso_pointer reverse( struct pso_pointer frame_pointer ) { + struct pso_pointer result = nil; + struct pso_pointer sequence = + fetch_arg( pointer_to_pso4( frame_pointer ), 0 ); + for ( struct pso_pointer cursor = sequence; !c_nilp( sequence ); + cursor = c_cdr( cursor ) ) { + struct pso2 *object = pointer_to_object( cursor ); + switch ( get_tag_value( cursor ) ) { + case CONSTV: + result = push_local( frame_pointer, + make_cons( frame_pointer, c_car( cursor ), + result ) ); + break; + case KEYTV: + result = push_local( frame_pointer, + make_string_like_thing( frame_pointer, + object->payload. + string.character, + result, + KEYTAG ) ); + break; + case STRINGTV: + result = push_local( frame_pointer, + make_string_like_thing( frame_pointer, + object->payload. + string.character, + result, + STRINGTAG ) ); + break; + case SYMBOLTV: + result = push_local( frame_pointer, + make_string_like_thing( frame_pointer, + object->payload. + string.character, + result, + SYMBOLTAG ) ); + break; + default: + result = push_local( frame_pointer, + make_exception( make_frame + ( 1, frame_pointer, + make_cons + ( frame_pointer, + c_string_to_lisp_string + ( frame_pointer, + L"Invalid object in sequence" ), + cursor ) ) ) ); + goto exit; + break; + } + } + exit: + + return result; +} + /** * @brief reverse a sequence. * @@ -37,49 +96,11 @@ */ struct pso_pointer c_reverse( struct pso_pointer frame_pointer, struct pso_pointer sequence ) { - // todo: issue #21: must have stack frame passed in. + struct pso_pointer result = nil; - for ( struct pso_pointer cursor = sequence; !c_nilp( sequence ); - cursor = c_cdr( cursor ) ) { - struct pso2 *object = pointer_to_object( cursor ); - switch ( get_tag_value( cursor ) ) { - case CONSTV: - result = make_cons( frame_pointer, c_car( cursor ), result ); - break; - case KEYTV: - // TODO: should you be able to reverse keywords and symbols? - result = - make_string_like_thing( frame_pointer, - object->payload.string.character, - result, KEYTAG ); - break; - case STRINGTV: - result = - make_string_like_thing( frame_pointer, - object->payload.string.character, - result, STRINGTAG ); - break; - case SYMBOLTV: - // TODO: should you be able to reverse keywords and symbols? - result = - make_string_like_thing( frame_pointer, - object->payload.string.character, - result, SYMBOLTAG ); - break; - default: - result = - make_exception( make_frame( 1, frame_pointer, - make_cons( frame_pointer, - c_string_to_lisp_string - ( frame_pointer, - L"Invalid object in sequence" ), - cursor ) ) ); - goto exit; - break; - } + if ( stackp( frame_pointer ) ) { + result = reverse( frame_pointer ); } - exit: - return result; } diff --git a/src/c/ops/stack_ops.c b/src/c/ops/stack_ops.c index cd7fac1..f1d14ea 100644 --- a/src/c/ops/stack_ops.c +++ b/src/c/ops/stack_ops.c @@ -71,9 +71,8 @@ struct pso_pointer push_local( struct pso_pointer frame_pointer, if ( stackp( frame_pointer ) ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); - struct pso_pointer l = - make_cons( frame_pointer, local, - frame->payload.stack_frame.locals ); + struct pso_pointer l = make_cons( frame_pointer, local, + frame->payload.stack_frame.locals ); frame->payload.stack_frame.locals = l; } diff --git a/src/c/ops/string_ops.c b/src/c/ops/string_ops.c index 74d0f47..8d5c345 100644 --- a/src/c/ops/string_ops.c +++ b/src/c/ops/string_ops.c @@ -181,8 +181,8 @@ char *lisp_string_to_c_string( struct pso_pointer s ) { int i = 0; for ( struct pso_pointer c = s; !c_nilp( c ); c = c_cdr( c ) ) { buffer[i++] = - ( wchar_t ) ( pointer_to_object( c )->payload.string. - character ); + ( wchar_t ) ( pointer_to_object( c )->payload. + string.character ); } mbstate_t ps; diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index c4b11c5..b0b2730 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -194,8 +194,8 @@ struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer struct pso_pointer arg_length = length( make_frame( 1, previous, argvalues ) ); int arg_count = - integerp( arg_length ) ? pointer_to_object( arg_length )->payload. - integer.value : 0; + integerp( arg_length ) ? pointer_to_object( arg_length )-> + payload.integer.value : 0; #ifdef DEBUG debug_printf( DEBUG_ALLOC, 0, L"\nAllocating stack frame with %d arguments at page %d, " @@ -253,8 +253,8 @@ struct pso_pointer make_frame_with_arglist( struct pso_pointer previous, struct pso_pointer argvalues ) { return make_frame_with_arglist_and_env( previous, argvalues, pointer_to_pso4 - ( previous )->payload. - stack_frame.env ); + ( previous )->payload.stack_frame. + env ); } diff --git a/src/sed/convert.sed b/src/sed/convert.sed index d7d681a..1ab02c8 100644 --- a/src/sed/convert.sed +++ b/src/sed/convert.sed @@ -1,17 +1,16 @@ # sed script to help converting snippets of code from 0.0.X to 0.1.X s?allocate_cell( *\([A-Z]*\) *)?allocate( \1, 2)?g -s?c_car(?car(?g -s?c_cdr(?cdr(?g s?cons_pointer?pso_pointer?g s?consspaceobject\.h?pso2\.h? -s?cons_space_object?pso2?g +s?cons_space_object?pso2*?g s?debug_print(\([^)]*\))?debug_print(\1, 0)?g s?frame->arg?frame->payload.stack_frame.arg?g s?make_cons?cons?g s?NIL?nil?g s?nilTAG?NILTAG?g -s?&pointer2cell?pointer_to_object?g +s?\&pointer2cell?pointer_to_object?g +s?pointer2cell?pointer_to_object?g s?stack_frame?pso4?g s?stack\.h?pso4\.h? s?tag.value?header.tag.bytes.value \& 0xfffff?g \ No newline at end of file