/** * ops/apply.c * * Post Scarcity Software Environment: apply. * * Add a applying for a key/value pair to a store -- at this stage, just an * association list. * * (c) 2026 Simon Brooke * 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" #include "memory/pso.h" #include "memory/pso2.h" #include "memory/pso3.h" #include "memory/pso4.h" #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" #include "payloads/cons.h" #include "payloads/function.h" #include "payloads/stack.h" ///** // * @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 * * 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. */ /** * 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; } /** * 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_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; 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_symbol ( frame_pointer, 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 ); } } debug_print( L"compose_body returning ", DEBUG_LAMBDA, 0 ); debug_dump_object( body, DEBUG_LAMBDA, 0 ); 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; }