Simon Brooke
f7eabb9b62
as the focus ot this prototype is supposed to be building things in Lisp, I've started deliberately copying stuff that mostly works directly from the 0.0.6 branch into this branch. After all, if it's going to be replaced in Lisp, it doesn't have to be the most elegant C.
1674 lines
60 KiB
C
1674 lines
60 KiB
C
/**
|
|
* 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 <simon@journeyman.cc>
|
|
* Licensed under GPL version 2.0, or, at your option, any later version.
|
|
*/
|
|
|
|
#include <ctype.h>
|
|
#include <stdbool.h>
|
|
#include <stdio.h>
|
|
#include <stdlib.h>
|
|
#include <string.h>
|
|
|
|
|
|
#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 <simon@journeyman.cc>
|
|
* 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;
|
|
}
|