From aac4669a3d01fd63eef07afa0891f32f71ff1e4f Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 28 Apr 2026 11:54:15 +0100 Subject: [PATCH] Still doesn't compile, but I think excellent progress. --- docs/State-of-play.md | 8 + src/c/debug.h | 5 + src/c/environment/privileged_keywords.c | 43 ++ src/c/environment/privileged_keywords.h | 23 + src/c/memory/tags.h | 7 +- src/c/ops/bind.c | 1 + src/c/ops/cond.c | 114 ++++ src/c/ops/dump.c | 140 ++++ src/c/ops/eval_apply.c | 824 +++++++----------------- src/c/ops/eval_apply.h | 4 +- src/c/ops/inspect.c | 64 ++ src/c/ops/inspect.h | 16 + src/c/ops/keys.c | 49 ++ src/c/ops/keys.h | 19 + src/c/ops/list_ops.c | 14 +- src/c/ops/mapcar.c | 62 ++ src/c/ops/mapcar.h | 0 src/c/ops/progn.c | 84 +++ src/c/ops/progn.h | 23 + src/c/ops/string_ops.c | 52 +- src/c/ops/string_ops.h | 13 +- src/c/payloads/cons.h | 4 +- src/c/payloads/exception.c | 71 ++ src/c/payloads/function.h | 11 - src/c/payloads/keyword.c | 27 + src/c/payloads/keyword.h | 4 + src/c/payloads/lambda.c | 24 + src/c/payloads/lambda.h | 7 +- src/c/payloads/nlambda.h | 4 + src/c/payloads/packed_string.h | 33 + src/c/payloads/psse_string.c | 14 + src/c/payloads/psse_string.h | 3 + src/c/payloads/symbol.c | 29 + src/c/payloads/symbol.h | 5 + 34 files changed, 1128 insertions(+), 673 deletions(-) create mode 100644 src/c/environment/privileged_keywords.c create mode 100644 src/c/environment/privileged_keywords.h create mode 100644 src/c/ops/cond.c create mode 100644 src/c/ops/dump.c create mode 100644 src/c/ops/inspect.c create mode 100644 src/c/ops/inspect.h create mode 100644 src/c/ops/keys.c create mode 100644 src/c/ops/keys.h create mode 100644 src/c/ops/mapcar.c create mode 100644 src/c/ops/mapcar.h create mode 100644 src/c/ops/progn.c create mode 100644 src/c/ops/progn.h create mode 100644 src/c/payloads/keyword.c create mode 100644 src/c/payloads/lambda.c create mode 100644 src/c/payloads/packed_string.h create mode 100644 src/c/payloads/symbol.c diff --git a/docs/State-of-play.md b/docs/State-of-play.md index 155aaab..86bff0f 100644 --- a/docs/State-of-play.md +++ b/docs/State-of-play.md @@ -1,5 +1,13 @@ # State of Play +## 20260427 + +### eval/apply, yet again + +OK, OK. So the version of `eval`/`apply` written in C is the `:bootstrap` version — which is to say, sufficient to get Lisp bootstrapped, and to run the compiler. One or both can then be replaced by new implementations written in Lisp, to provide the `:system` versions. And any user should in principle be able to override the system versions with their own versions (although troubling worries about security come into that). + +So yesterday, I decided to copy the versions of `eval` and `apply` from `0.0.6` (which, after all, do work — there are lots of problems with the `0.0.6` prototype, but the interpreter is not one of them) into `0.1.0`. But then last night I read the chapter in Cees de Groot's [The Genius of Lisp](https://cdegroot.com/programming/lisp/2026/02/17/why-i-wrote-the-genius-of-lisp.html) and I'm back to wanting to reimplement them *yet again*. I'm not sure that this is wise. + ## 20260424 ### To have `c_` functions or not to have `c_` functions, revisited diff --git a/src/c/debug.h b/src/c/debug.h index 4c3a8b3..317f62d 100644 --- a/src/c/debug.h +++ b/src/c/debug.h @@ -97,6 +97,11 @@ */ #define DEBUG_EQUAL 512 +/** + * @brief sum of all previous DEBUG_ values. + */ +#define DEBUG_ANY 1023 + /** * @brief Verbosity (and content) of debugging output * diff --git a/src/c/environment/privileged_keywords.c b/src/c/environment/privileged_keywords.c new file mode 100644 index 0000000..411e6a0 --- /dev/null +++ b/src/c/environment/privileged_keywords.c @@ -0,0 +1,43 @@ +/** + * privileged_keywords.c + * + * Post Scarcity Soctware Environment + * + * Keywords essential to the operation of the system. I'm not certain that + * there's any necessity to have privileged keywords, but as these are + * keywords that will be used exceedingly frequently, we might as well + * make them cheap to access. + * + * Copyright (c): 27 Apr 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include "environment/privileged_keywords.h" + +#include "memory/node.h" +#include "memory/pointer.h" + +#include "memory/pso.h" +#include "payloads/cons.h" + +#include "ops/string_ops.h" + + +/** + * location metadata for exceptions (and possibly location in other contexts). + */ +struct pso_pointer privileged_keyword_location; + +/** + * name metadata for compiled functions. + */ +struct pso_pointer privileged_keyword_name; + + +#define load_and_lock(var,val)var = lock_object(c_string_to_lisp_keyword(nil, val)) + + +struct pso_pointer initialise_privileged_keywords( struct pso_pointer env){ + load_and_lock(privileged_keyword_location, PK_LOCATION); + load_and_lock( privileged_keyword_name, PK_NAME); +} \ No newline at end of file diff --git a/src/c/environment/privileged_keywords.h b/src/c/environment/privileged_keywords.h new file mode 100644 index 0000000..74a9723 --- /dev/null +++ b/src/c/environment/privileged_keywords.h @@ -0,0 +1,23 @@ +/** + * privileged_keywords.h + * + * Post Scarcity Soctware Environment + * + * TODO: Edit purpose. + * + * Copyright (c): 27 Apr 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef SRC_C_ENVIRONMENT_PRIVILEGED_KEYWORDS_H_ +#define SRC_C_ENVIRONMENT_PRIVILEGED_KEYWORDS_H_ + +#define PK_LOCATION U"location" +#define PK_NAME = U"name" + +#include "memory/pointer.h" +extern struct pso_pointer privileged_keyword_location; +extern struct pso_pointer privileged_keyword_name; + +struct pso_pointer initialise_privileged_keywords( struct pso_pointer env); +#endif /* SRC_C_ENVIRONMENT_PRIVILEGED_KEYWORDS_H_ */ diff --git a/src/c/memory/tags.h b/src/c/memory/tags.h index 422c1dd..faad41f 100644 --- a/src/c/memory/tags.h +++ b/src/c/memory/tags.h @@ -135,6 +135,11 @@ bool check_type( struct pso_pointer p, char *s ); // #define truep(p) ( !check_tag(p,NILTV)) #define vectorpointp(p) (check_tag(p,VECTORPOINTTV)) #define vectorp(p) (check_tag(p,VECTORTV)) -#define writep(p) (check_tag(p,WRITETV)) +#define writep(p) (check_tag(p, WRITETV)) + +/** a sequence is an object having a list structure with the pointer to the + * remainder in the fourth word of each cell. I.e., cons, string, symbol, + * keyword, possibly some others */ +#define sequencep(p)(consp(p) || keywordp(p) || stringp(p) || symbolp(p)) #endif diff --git a/src/c/ops/bind.c b/src/c/ops/bind.c index 2b6f447..743de6b 100644 --- a/src/c/ops/bind.c +++ b/src/c/ops/bind.c @@ -35,3 +35,4 @@ struct pso_pointer lisp_bind( struct pso_pointer frame_pointer ) { return cons( make_frame( 2, frame_pointer, binding, store ) ); } + diff --git a/src/c/ops/cond.c b/src/c/ops/cond.c new file mode 100644 index 0000000..f764661 --- /dev/null +++ b/src/c/ops/cond.c @@ -0,0 +1,114 @@ + +/** + * @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 + */ +#include "debug.h" + +#include "memory/node.h" +#include "memory/pointer.h" +#include "memory/pso2.h" +#include "memory/tags.h" + +#include "ops/progn.h" +#include "ops/stack_ops.h" +#include "ops/truth.h" + +#include "payloads/cons.h" +#include "payloads/exception.h" + +/** + * if the car of a consp evaluates to non-nil, the clause succeeded and the + * cond expression must conclude, even if the result of the clause is nil. + * + * Therefore this funtion will + * @return nil if the test failed; + * @return a pair `(t . )` if the test succeeded. + */ +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); +#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); + } 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( frame_pointer, L"cond" ), + c_string_to_lisp_string + (frame_pointer, 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 ); + + // TODO: WHOOPS! This isn't right. If the test of a cond clause + // evaluates to non-nil, but the last form of the clause evaluates + // to nil, the form still succeeded and we should still exit `cond`. + // + + result = eval_cond_clause( clause_pointer, frame, frame_pointer, env ); + + if ( !c_nilp( result ) && c_truep( c_car( result ) ) ) { + result = c_cdr( result ); + done = true; + break; + } + } +#ifdef DEBUG + debug_print( L"\tCond returning: ", DEBUG_EVAL, 0 ); + debug_print_object( result, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL); +#endif + + return result; +} diff --git a/src/c/ops/dump.c b/src/c/ops/dump.c new file mode 100644 index 0000000..0e3ed86 --- /dev/null +++ b/src/c/ops/dump.c @@ -0,0 +1,140 @@ +/* + * dump.c + * + * Dump representations of both cons space and vector space objects. + * + * + * (c) 2018 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +/* + * wide characters + */ +#include +#include + +#include "memory/pso2.h" +#include "memory/tags.h" +#include "io/print.h" + +#include "payloads/lambda.h" + + +void dump_string_cell( URL_FILE *output, wchar_t *prefix, + struct pso_pointer pointer ) { + struct pso2 *cell = pointer_to_object( pointer ); + if ( cell->payload.string.character == 0 ) { + url_fwprintf( output, + L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n", + prefix, + cell->payload.string.cdr.page, + cell->payload.string.cdr.offset, cell->header.count ); + } else { + url_fwprintf( output, + L"\t\t%ls cell: character '%lc' (%d) with hash %d; next at page %d offset %d, count %u\n", + prefix, + ( wint_t ) cell->payload.string.character, + cell->payload.string.character, + cell->payload.string.hash, + cell->payload.string.cdr.page, + cell->payload.string.cdr.offset, cell->header.count ); + url_fwprintf( output, L"\t\t value: " ); + print( output, pointer ); + url_fwprintf( output, L"\n" ); + } +} + +/** + * dump the object at this pso_pointer to this output stream. + */ +void dump_object( URL_FILE *output, struct pso_pointer pointer ) { + struct pso2 *cell = pointer_to_object( pointer ); + url_fwprintf( output, L"\t%3.3s (%d) at page %d, offset %d count %u\n", + cell->header.tag.bytes.mnemonic[0], get_tag_value( pointer ), + pointer.page, pointer.offset, cell->header.count ); + + switch ( get_tag_value( pointer ) ) { + case CONSTV: + url_fwprintf( output, + L"\t\tCons cell: car at page %d offset %d, cdr at page %d " + L"offset %d, count %u :", + cell->payload.cons.car.page, + cell->payload.cons.car.offset, + cell->payload.cons.cdr.page, + cell->payload.cons.cdr.offset ); + print( output, pointer ); + url_fputws( L"\n", output ); + break; + case EXCEPTIONTV: + url_fwprintf( output, L"\t\tException cell: " ); + dump_stack_trace( output, pointer ); + break; + case FREETV: + url_fwprintf( output, + L"\t\tFree cell: next at page %d offset %d\n", + cell->payload.cons.cdr.page, + cell->payload.cons.cdr.offset ); + break; + case HASHTV: + dump_map( output, pointer ); + break; + case INTEGERTV: + url_fwprintf( output, L"\t\tInteger cell: value %ld, count %u\n", + cell->payload.integer.value, cell->header.count ); + break; + case KEYTV: + dump_string_cell( output, L"Keyword", pointer ); + break; + case LAMBDATV: + url_fwprintf( output, L"\t\t\u03bb cell;\n\t\t args: " ); + print( output, cell->payload.lambda.args ); + url_fwprintf( output, L";\n\t\t\tbody: " ); + print( output, cell->payload.lambda.body ); + url_fputws( L"\n", output ); + break; + case NILTV: + break; + case NLAMBDATV: + url_fwprintf( output, L"\t\tn\u03bb cell; \n\t\targs: " ); + print( output, cell->payload.lambda.args ); + url_fwprintf( output, L";\n\t\t\tbody: " ); + print( output, cell->payload.lambda.body ); + url_fputws( L"\n", output ); + break; + case RATIOTV: + url_fwprintf( output, + L"\t\tRational cell: value %ld/%ld, count %u\n", + pointer_to_object( cell->payload.ratio. + dividend ).payload.integer.value, + pointer_to_object( cell->payload.ratio. + divisor ).payload.integer.value, + cell->header.count ); + break; + case READTV: + url_fputws( L"\t\tInput stream; metadata: ", output ); + print( output, cell->payload.stream.meta ); + url_fputws( L"\n", output ); + break; + case REALTV: + url_fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n", + cell->payload.real.value, cell->header.count ); + break; + case STACKTV: + dump_frame( output, pointer ); + break; + case STRINGTV: + dump_string_cell( output, L"String", pointer ); + break; + case SYMBOLTV: + dump_string_cell( output, L"Symbol", pointer ); + break; + case TRUETV: + break; + case WRITETV: + url_fputws( L"\t\tOutput stream; metadata: ", output ); + print( output, cell->payload.stream.meta ); + url_fputws( L"\n", output ); + break; + } +} diff --git a/src/c/ops/eval_apply.c b/src/c/ops/eval_apply.c index e26fc1c..e6bff33 100644 --- a/src/c/ops/eval_apply.c +++ b/src/c/ops/eval_apply.c @@ -1,10 +1,10 @@ /** - * ops/apply.c + * ops/eval_apply.c * - * Post Scarcity Software Environment: apply. + * Post Scarcity Software Environment: eval and apply. * - * Add a applying for a key/value pair to a store -- at this stage, just an - * association list. + * apply: Apply a function to arguments in an environment. + * eval: Evaluate a form in an environment. * * (c) 2026 Simon Brooke * Licensed under GPL version 2.0, or, at your option, any later version. @@ -18,6 +18,9 @@ #include "debug.h" + +#include "environment/privileged_keywords.h" + #include "memory/node.h" #include "memory/pointer.h" #include "memory/pso.h" @@ -28,13 +31,17 @@ #include "ops/assoc.h" #include "ops/bind.h" +#include "ops/eval_apply.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/exception.h" #include "payloads/function.h" +#include "payloads/lambda.h" +#include "payloads/nlambda.h" #include "payloads/stack.h" ///** @@ -338,10 +345,11 @@ struct pso_pointer compose_body( struct pso_pointer frame_pointer ) { * @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 ) ); -//} +struct pso_pointer +lisp_lambda( struct pso_pointer frame_pointer ) { + struct pso4* frame = pointer_to_pso4(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 @@ -354,25 +362,27 @@ struct pso_pointer compose_body( struct pso_pointer frame_pointer ) { * @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 ) ); -//} +struct pso_pointer +lisp_nlambda( struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso4* frame = pointer_to_pso4(frame_pointer); + 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 ) ); +eval_lambda( struct pso_pointer frame_pointer ) { + struct pso_pointer result = nil; + struct pso4 *frame = pointer_to_pso4(frame_pointer); + struct pso2 *lambda = pointer_to_object(fetch_arg(frame, 0)); + struct pso_pointer args = fetch_arg( frame, 1); + 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; + struct pso_pointer names = lambda->payload.lambda.args; + struct pso_pointer body = lambda->payload.lambda.body; #ifdef DEBUG debug_print( L"eval_lambda called\n", DEBUG_LAMBDA, 0 ); debug_println( DEBUG_LAMBDA ); @@ -399,8 +409,12 @@ eval_lambda( struct pso4 *frame, /* 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 ); + struct pso_pointer more_frame = inc_ref( + make_frame(1, frame_pointer, + frame->payload.stack_frame.more)); + + struct pso_pointer vals = + eval_forms( more_frame ); for ( int i = args_in_frame - 1; i >= 0; i-- ) { struct pso_pointer next = @@ -410,7 +424,7 @@ eval_lambda( struct pso4 *frame, if ( c_nilp( val ) && c_nilp( vals ) ) { /* nothing */ } else { - vals = make_cons( frame_pointer, val, vals ); + new_env = make_cons( frame_pointer, val, vals ); } } @@ -457,42 +471,129 @@ struct pso_pointer maybe_fixup_exception_location( struct pso_pointer r, 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 ) ); - } - } +// if ( exceptionp( result ) +// && ( functionp( fn_pointer ) || specialp( fn_pointer ) ) ) { +// struct pso2 **fn_cell = pointer_to_object( fn_pointer ); +// +// struct pso_pointer payload = +// pointer_to_pso3( result )->payload.exception.meta; +// +// switch ( get_tag_value(payload)) { +// case NILTV: +// case CONSTV: +// case HASHTV: +// { +// if ( c_nilp( c_assoc( privileged_keyword_location, +// payload ) ) ) { +// pointer_to_pso3( result )->payload.exception.meta = +// make_cons(frame_pointer, privileged_keyword_location, +// c_assoc( privileged_keyword_name, +// fn_cell->payload.function.meta ), +// payload ); +// } +// } +// break; +// default: +// pointer_to_pso3( result )->payload.exception.meta = +// cons( cons( privileged_keyword_location, +// c_assoc( privileged_keyword_name, +// fn_cell->payload.function.meta ) ), +// cons( cons +// ( privileged_keyword_payload, +// payload ), nil ) ); +// } +// } return result; } +/** + * @brief Create a new stack frame in which to evaluate the function indicated + * by this `fn_pointer`, with evaluated args from this `arg_list`. + * + * @param previous the parent stack frame; + * @param fn_pointer a pointer to the function object or lambda to evaluate; + * @param arg_list a Lisp list of args to be passed; + * + * @return a pointer to the new frame. + */ +struct pso_pointer make_fn_frame(struct pso_pointer previous, + struct pso_pointer fn_pointer, + struct pso_pointer arg_list) { + + struct pso_pointer new_pointer = make_frame( 0, previous ); + struct pso4 *new_frame = pointer_to_pso4( new_pointer ); + struct pso_pointer next_pointer = + push_local(previous, make_frame(1, previous, nil)); + struct pso4 *next_frame = pointer_to_pso4(next_pointer); + + new_frame->payload.stack_frame.function = fn_pointer; + + int args = 0; + struct pso_pointer cursor; + for ( cursor = arg_list; consp(cursor) && args < args_in_frame; cursor = c_cdr(cursor)) { + // Reusing a frame like this is a bit of an abuse but will save allocation churn. + next_frame->payload.stack_frame.arg[0] = c_car(cursor); + new_frame->payload.stack_frame.arg[args++] = inc_ref( lisp_eval( next_pointer) ); + } + if (consp(cursor)) { + struct pso_pointer more = nil; + + for (; consp(cursor); cursor = c_cdr(cursor)) { + // Reusing a frame like this is a bit of an abuse but will save + // allocation churn. + next_frame->payload.stack_frame.arg[0] = c_car(cursor); + more = make_cons(previous, lisp_eval(next_pointer), more); + + args++; + } + + new_frame->payload.stack_frame.more = inc_ref( c_reverse( more)); + } + + new_frame->payload.stack_frame.args = args; + dec_ref(next_pointer); + + return new_pointer; +} + + +/** + * @brief Create a new stack frame in which to evaluate the special form + * indicated by this `fn_pointer`, with unevaluated args from this `arg_list`. + * + * @param previous the parent stack frame; + * @param fn_pointer a pointer to the special form object or nlambda to + * evaluate; + * @param arg_list a Lisp list of args to be passed; + * + * @return a pointer to the new frame. + */ +struct pso_pointer make_special_frame(struct pso_pointer previous, + struct pso_pointer fn_pointer, + struct pso_pointer arg_list) { + + struct pso_pointer new_pointer = make_frame( 0, previous ); + struct pso4 *new_frame = pointer_to_pso4( new_pointer ); + + new_frame->payload.stack_frame.function = fn_pointer; + + int args = 0; + struct pso_pointer cursor; + for ( cursor = arg_list; consp(cursor) && args < args_in_frame; cursor = c_cdr(cursor)) { + // Reusing a frame like this is a bit of an abuse but will save allocation churn. + new_frame->payload.stack_frame.arg[args++] = inc_ref( c_car(cursor) ); + } + if (consp(cursor)) { + + new_frame->payload.stack_frame.more = inc_ref( cursor); + } + + new_frame->payload.stack_frame.args = args; + + return new_pointer; +} + /** * Internal guts of apply. @@ -501,23 +602,23 @@ struct pso_pointer maybe_fixup_exception_location( struct pso_pointer r, * @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 lisp_apply( struct pso_pointer frame_pointer) { + debug_print( L"Entering apply\n", DEBUG_EVAL, 0 ); struct pso_pointer result = nil; + struct pso4* frame = pointer_to_pso4(frame_pointer); + struct pso_pointer fn_frame = inc_ref( make_frame(1, frame_pointer, c_car( frame->payload.stack_frame.arg[0] ))); struct pso_pointer fn_pointer = - eval_form( frame, frame_pointer, - c_car( frame->payload.stack_frame.arg[0] ), env ); - + push_local(frame_pointer, eval_form( fn_frame)); + dec_ref( fn_frame); + if ( exceptionp( fn_pointer ) ) { result = fn_pointer; } else { - struct pso2 **fn_cell = pointer_to_object( fn_pointer ); + 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 ) ) { + switch ( get_tag_value( fn_pointer ) ) { case EXCEPTIONTV: /* just pass exceptions straight back */ result = fn_pointer; @@ -525,51 +626,46 @@ c_apply( struct pso4 *frame, struct pso_pointer frame_pointer, case FUNCTIONTV: { - struct pso_pointer exep = nil; struct pso_pointer next_pointer = - make_pso4( frame_pointer, args, env ); + inc_ref( make_fn_frame( frame_pointer, fn_pointer, args )); if ( exceptionp( next_pointer ) ) { result = next_pointer; } else { - struct pso4 *next = pointer_to_pso4( next_pointer ); - - result = maybe_fixup_exception_location( ( * + result = push_local( frame_pointer, + maybe_fixup_exception_location( ( * ( fn_cell-> payload. function. executable ) ) - ( next, - next_pointer, - env ), - fn_pointer ); + (next_pointer ), + 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 KEYTV: { + struct pso_pointer map_frame = + inc_ref(make_frame(1, frame_pointer, c_car(args))); + result = push_local( + frame_pointer, + c_assoc(fn_pointer, + maybe_fixup_exception_location( + eval_form(map_frame), fn_pointer))); + } break; - case LAMBDATV: + case LAMBDATV: { - struct pso_pointer exep = nil; struct pso_pointer next_pointer = - make_pso4( frame_pointer, args, env ); + make_fn_frame( frame_pointer, fn_pointer, args ); 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 ); + eval_lambda( next_pointer ); if ( !exceptionp( result ) ) { dec_ref( next_pointer ); } @@ -578,26 +674,27 @@ c_apply( struct pso4 *frame, struct pso_pointer frame_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 ); + /* \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 ); + make_special_frame( frame_pointer, fn_pointer, args ); 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 ); + eval_lambda( next_pointer ); dec_ref( next_pointer ); } } @@ -606,7 +703,7 @@ c_apply( struct pso4 *frame, struct pso_pointer frame_pointer, case SPECIALTV: { struct pso_pointer next_pointer = - make_special_frame( frame_pointer, args, env ); + make_special_frame( frame_pointer, fn_pointer, args ); if ( exceptionp( next_pointer ) ) { result = next_pointer; @@ -616,11 +713,11 @@ c_apply( struct pso4 *frame, struct pso_pointer frame_pointer, payload. special. executable ) ) - ( pointer_to_pso4( next_pointer ), next_pointer, env ), fn_pointer ); - debug_print( L"Special form returning: ", DEBUG_EVAL, + ( next_pointer ), fn_pointer ); + debug_print( U"Special form returning: ", DEBUG_EVAL, 0 ); debug_print_object( result, DEBUG_EVAL, 0 ); - debug_println( DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL); dec_ref( next_pointer ); } } @@ -632,23 +729,23 @@ c_apply( struct pso4 *frame, struct pso_pointer frame_pointer, 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] ) ); + L"Unexpected cell with tag %u (%3.3s) in function position", + get_tag_value(fn_pointer), + &( fn_cell->header.tag.bytes.mnemonic[0] ) ); struct pso_pointer message = - c_string_to_lisp_string( buffer ); + c_string_to_lisp_string( frame_pointer, buffer ); free( buffer ); result = - throw_exception( c_string_to_lisp_symbol( L"apply" ), + make_exception( frame_pointer, c_string_to_lisp_symbol( frame_pointer, U"apply" ), message, frame_pointer ); } } } - debug_print( L"c_apply: returning: ", DEBUG_EVAL, 0 ); + debug_print( L"apply: returning: ", DEBUG_EVAL, 0 ); debug_print_object( result, DEBUG_EVAL, 0 ); - debug_println( DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL ); return result; } @@ -674,31 +771,34 @@ c_apply( struct pso4 *frame, struct pso_pointer frame_pointer, * @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 ) { +lisp_eval( struct pso_pointer frame_pointer ) { debug_print( L"Eval: ", DEBUG_EVAL, 0 ); debug_dump_object( frame_pointer, DEBUG_EVAL, 0 ); + struct pso4* frame = pointer_to_pso4(frame_pointer); struct pso_pointer result = frame->payload.stack_frame.arg[0]; - struct pso2 **cell = - pointer_to_object( frame->payload.stack_frame.arg[0] ); + struct pso2 *cell = pointer_to_object(frame->payload.stack_frame.arg[0]); + struct pso_pointer env = fetch_env(frame_pointer); - switch ( cell->header.tag.bytes.value & 0xfffff ) { - case CONSTV: - result = c_apply( frame, frame_pointer, env ); - break; + switch (get_tag_value(result)) { + case CONSTV: { + struct pso_pointer next_pointer = + push_local(frame_pointer, make_frame(2, frame_pointer, + c_car(result), c_cdr(result))); + result = push_local(frame_pointer, lisp_apply(next_pointer)); + } break; - case SYMBOLTV: + case SYMBOLTV: { struct pso_pointer canonical = - interned( frame->payload.stack_frame.arg[0], env ); + c_interned( frame->payload.stack_frame.arg[0], fetch_env(frame_pointer) ); if ( c_nilp( canonical ) ) { struct pso_pointer message = - cons( c_string_to_lisp_string - ( L"Attempt to take value of unbound symbol." ), + make_cons( frame_pointer, c_string_to_lisp_string + ( frame_pointer, L"Attempt to take value of unbound symbol." ), frame->payload.stack_frame.arg[0] ); result = - throw_exception( c_string_to_lisp_symbol( L"eval" ), + throw_exception( c_string_to_lisp_symbol( frame_pointer, L"eval" ), message, frame_pointer ); } else { result = c_assoc( canonical, env ); @@ -713,47 +813,18 @@ lisp_eval( struct pso4 *frame, struct pso_pointer frame_pointer, * H'mmm... this is working, but it isn't here. Where is it? */ default: - result = frame->payload.stack_frame.arg[0]; + // we've already done this... break; - } + } - debug_print( L"Eval returning ", DEBUG_EVAL, 0 ); + 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; -} /** @@ -775,212 +846,6 @@ lisp_quote( struct pso4 *frame, struct pso_pointer frame_pointer, } -/** - * 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] ); -} @@ -1000,251 +865,6 @@ lisp_type( struct pso4 *frame, struct pso_pointer frame_pointer, 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. diff --git a/src/c/ops/eval_apply.h b/src/c/ops/eval_apply.h index 2f326fa..4126657 100644 --- a/src/c/ops/eval_apply.h +++ b/src/c/ops/eval_apply.h @@ -17,10 +17,10 @@ #include "memory/pso4.h" #include "payloads/function.h" -struct pso_pointer apply( struct pso_pointer frame_pointer ); +struct pso_pointer lisp_apply( struct pso_pointer frame_pointer ); -struct pso_pointer eval( struct pso_pointer frame_pointer ); +struct pso_pointer lisp_eval( struct pso_pointer frame_pointer ); #endif diff --git a/src/c/ops/inspect.c b/src/c/ops/inspect.c new file mode 100644 index 0000000..6f9b856 --- /dev/null +++ b/src/c/ops/inspect.c @@ -0,0 +1,64 @@ +/** + * inspect.c + * + * Post Scarcity Soctware Environment + * + * Display the contents of an object; later, in explorable form. + * + * Copyright (c): 25 Apr 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include "debug.h" +#include "io/fopen.h" +#include "io/io.h" +#include "memory/node.h" +#include "memory/pointer.h" +#include "memory/pso2.h" +#include "memory/pso4.h" +#include "memory/tags.h" +#include "ops/stack_ops.h" + +/** + * Function: dump/inspect one complete lisp expression and return nil. If + * write-stream is specified and is a write stream, then print to that stream, + * else the stream which is the value of + * `*out*` in the environment. + * + * * (inspect expr) + * * (inspect expr write-stream) + * + * TODO: IT OCCURS TO ME that if `inspect` returns a Markdown formatted string + * then it will be readable right away, but wrappable in a browser later to + * allow interactive exploration. + * + * @param frame my pso4. + * @param frame_pointer a pointer to my pso4. + * @param env my environment (from which the stream may be extracted). + * @return nil. + */ +struct pso_pointer lisp_inspect(struct pso_pointer frame_pointer) { + debug_print( L"Entering lisp_inspect\n", DEBUG_IO, 0 ); + struct pso_pointer result = nil; + + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + + struct pso_pointer out_stream = writep( frame->payload.stack_frame.arg[1] ) + ? frame->payload.stack_frame.arg[1] + : get_default_stream( false, fetch_env( frame_pointer ) ); + URL_FILE *output; + + if ( writep( out_stream ) ) { + debug_print( L"lisp_inspect: setting output stream\n", DEBUG_IO, 0 ); + debug_dump_object( out_stream, DEBUG_IO ); + output = pointer_to_object( out_stream )->payload.stream.stream; + } else { + output = file_to_url_file( stderr ); + } + + dump_object( output, frame->payload.stack_frame.arg[0] ); + + debug_print( L"Leaving lisp_inspect", DEBUG_IO, 0 ); + + return result; +} diff --git a/src/c/ops/inspect.h b/src/c/ops/inspect.h new file mode 100644 index 0000000..7e15d15 --- /dev/null +++ b/src/c/ops/inspect.h @@ -0,0 +1,16 @@ +/** + * inspect.h + * + * Post Scarcity Soctware Environment + * + * Display the contents of an object; later, in explorable form. + * + * Copyright (c): 25 Apr 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef psse_ops_inspect +#define psse_ops_inspect + +struct pso_pointer lisp_inspect( struct pso_pointer frame_pointer ); +#endif \ No newline at end of file diff --git a/src/c/ops/keys.c b/src/c/ops/keys.c new file mode 100644 index 0000000..2ec8ac9 --- /dev/null +++ b/src/c/ops/keys.c @@ -0,0 +1,49 @@ +/** + * ops/keys.c + * + * Post Scarcity Software Environment: eval and apply. + * + * keys: return an unsorted list of the keys bound in a store. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + + +#include "memory/node.h" +#include "memory/pointer.h" +#include "memory/tags.h" +#include "ops/truth.h" +#include "payloads/cons.h" + +/** + * @brief an implementation of `keys` convenient for calling from C + * + * @param */ +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 ( hashtabp( pair ) ) { + // result = c_append( hashmap_keys( pair ), result ); + } + + store = c_cdr( store ); + } + // } else if ( hashtabp( store ) ) { + // result = hashmap_keys( store ); + } + + return result; +} + + + +struct pso_pointer lisp_keys( struct pso_pointer frame_pointer) { + return c_keys( pointer_to_pso4(frame_pointer)->payload.stack_frame.arg[0] ); +} + diff --git a/src/c/ops/keys.h b/src/c/ops/keys.h new file mode 100644 index 0000000..3b48261 --- /dev/null +++ b/src/c/ops/keys.h @@ -0,0 +1,19 @@ +/** + * ops/keys.h + * + * Post Scarcity Software Environment: keys. + * + * keys: return an unsorted list of the keys bound in a store. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef psse_ops_keys +#define psse_ops_keys + +struct pso_pointer c_keys( struct pso_pointer store ); + +struct pso_pointer lisp_keys(struct pso_pointer frame_pointer); + +#endif \ No newline at end of file diff --git a/src/c/ops/list_ops.c b/src/c/ops/list_ops.c index 3baeabf..6ef05b9 100644 --- a/src/c/ops/list_ops.c +++ b/src/c/ops/list_ops.c @@ -13,20 +13,24 @@ #include "memory/pso4.h" #include "ops/stack_ops.h" + +#include "payloads/cons.h" +#include "payloads/integer.h" #include "payloads/stack.h" #include "ops/truth.h" -struct pso_pointer length( struct pso_pointer frame_pointer ) { +struct pso_pointer count( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer list = fetch_arg( frame, 0 ); - int count = 0; + int c = 0; for ( struct pso_pointer cursor = list; !c_nilp( cursor ); - cursor = cdr( make_frame( 1, frame_pointer, list ) ) ) { - count++; + cursor = c_cdr( cursor ) ) { + c++; } - return make_integer( frame_pointer, count ); + return acquire_integer( frame_pointer, c ); } + diff --git a/src/c/ops/mapcar.c b/src/c/ops/mapcar.c new file mode 100644 index 0000000..444cfc8 --- /dev/null +++ b/src/c/ops/mapcar.c @@ -0,0 +1,62 @@ +/** + * ops/mapcar.c + * + * Post Scarcity Software Environment: mapcar. + * + * map a function across a sequence of forms. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + + +#include "debug.h" +#include "memory/node.h" +#include "memory/pointer.h" +#include "memory/pso.h" +#include "memory/tags.h" +#include "ops/reverse.h" +#include "ops/truth.h" +#include "payloads/cons.h" + +struct pso_pointer lisp_mapcar( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + debug_print( U"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]; c_truep( 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, 0, U"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, 0, U"Mapcar %d, result is ", i++ ); + debug_print_object( result, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL); + + dec_ref( expr ); + } + + result = consp( result ) ? c_reverse( result ) : result; + + debug_print( U"Mapcar returning: ", DEBUG_EVAL, 0 ); + debug_print_object( result, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL ); + + return result; +} diff --git a/src/c/ops/mapcar.h b/src/c/ops/mapcar.h new file mode 100644 index 0000000..e69de29 diff --git a/src/c/ops/progn.c b/src/c/ops/progn.c new file mode 100644 index 0000000..f5ac897 --- /dev/null +++ b/src/c/ops/progn.c @@ -0,0 +1,84 @@ +/** + * ops/progn.c + * + * Post Scarcity Software Environment: progn. + * + * Evaluate a sequence of expressions and return the value of the last. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include + +#include "memory/node.h" +#include "memory/pointer.h" +#include "memory/pso4.h" +#include "memory/tags.h" + +#include "ops/eval_apply.h" +#include "ops/stack_ops.h" + +#include "payloads/cons.h" +#include "payloads/stack.h" + + +/** + * 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; + struct pso_pointer next_pointer = + push_local(frame_pointer, make_frame(1, frame_pointer, nil)); + struct pso4 *next_frame = pointer_to_pso4(next_pointer); + + while ( consp( expressions ) ) { + next_frame->payload.stack_frame.arg[0] = c_car(expressions); + + result = lisp_eval( next_pointer); + + 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 pso_pointer frame_pointer) { + struct pso_pointer result = nil; + struct pso4 *frame = pointer_to_pso4(frame_pointer); + struct pso_pointer next_pointer = + push_local(frame_pointer, make_frame(1, frame_pointer, nil)); + struct pso4 *next_frame = pointer_to_pso4(next_pointer); + + for (int i = 0; i < args_in_frame; i++) { + next_frame->payload.stack_frame.arg[0] = + frame->payload.stack_frame.arg[i]; + + result = push_local(frame_pointer, lisp_eval(next_pointer)); + } + + if (consp(frame->payload.stack_frame.more)) { + result = + c_progn(frame, frame_pointer, frame->payload.stack_frame.more, env); + } + + return result; +} diff --git a/src/c/ops/progn.h b/src/c/ops/progn.h new file mode 100644 index 0000000..4651485 --- /dev/null +++ b/src/c/ops/progn.h @@ -0,0 +1,23 @@ +/** + * ops/progn.c + * + * Post Scarcity Software Environment: progn. + * + * Evaluate a sequence of expressions and return the value of the last. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_ops_progn_h +#define __psse_ops_progn_h + +#include "memory/pointer.h" +#include "memory/pso4.h" + +struct pso_pointer c_progn(struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer expressions, + struct pso_pointer env); + +struct pso_pointer lisp_progn(struct pso_pointer frame_pointer); +#endif \ No newline at end of file diff --git a/src/c/ops/string_ops.c b/src/c/ops/string_ops.c index 8d5c345..47e30a3 100644 --- a/src/c/ops/string_ops.c +++ b/src/c/ops/string_ops.c @@ -26,6 +26,7 @@ #include "ops/truth.h" #include "payloads/exception.h" +#include "payloads/symbol.h" /** @@ -100,45 +101,6 @@ struct pso_pointer make_string_like_thing( struct pso_pointer frame_pointer, return pointer; } -/** - * Construct a string from the character `c` and this `tail`. A string is - * implemented as a flat list of cells each of which has one character and a - * pointer to the next; in the last cell the pointer to next is NIL. - * - * @param c the character to add (prepend); - * @param tail the string which is being built. - */ -struct pso_pointer make_string( struct pso_pointer frame_pointer, wint_t c, - struct pso_pointer tail ) { - return make_string_like_thing( frame_pointer, c, tail, STRINGTAG ); -} - -/** - * Construct a keyword from the character `c` and this `tail`. A string is - * implemented as a flat list of cells each of which has one character and a - * pointer to the next; in the last cell the pointer to next is NIL. - * - * @param c the character to add (prepend); - * @param tail the keyword which is being built. - */ -struct pso_pointer make_keyword( struct pso_pointer frame_pointer, wint_t c, - struct pso_pointer tail ) { - return make_string_like_thing( frame_pointer, c, tail, KEYTAG ); -} - -/** - * Construct a symbol from the character `c` and this `tail`. A string is - * implemented as a flat list of cells each of which has one character and a - * pointer to the next; in the last cell the pointer to next is NIL. - * - * @param c the character to add (prepend); - * @param tail the symbol which is being built. - */ -struct pso_pointer make_symbol( struct pso_pointer frame_pointer, wint_t c, - struct pso_pointer tail ) { - return make_string_like_thing( frame_pointer, c, tail, SYMBOLTAG ); -} - /** * Return a lisp string representation of this wide character string. @@ -245,3 +207,15 @@ struct pso_pointer c_string_to_lisp_keyword( struct pso_pointer 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' ); +} diff --git a/src/c/ops/string_ops.h b/src/c/ops/string_ops.h index 463aab7..4e94ae9 100644 --- a/src/c/ops/string_ops.h +++ b/src/c/ops/string_ops.h @@ -9,7 +9,7 @@ #ifndef __psse_ops_string_ops_h #define __psse_ops_string_ops_h - +#include /* * wide characters */ @@ -21,15 +21,6 @@ struct pso_pointer make_string_like_thing( struct pso_pointer frame_pointer, wint_t c, struct pso_pointer tail, char *tag ); -struct pso_pointer make_string( struct pso_pointer frame_pointer, wint_t c, - struct pso_pointer tail ); - -struct pso_pointer make_keyword( struct pso_pointer frame_pointer, wint_t c, - struct pso_pointer tail ); - -struct pso_pointer make_symbol( struct pso_pointer frame_pointer, wint_t c, - struct pso_pointer tail ); - struct pso_pointer c_string_to_lisp_string( struct pso_pointer frame_pointer, wchar_t *string ); char *lisp_string_to_c_string( struct pso_pointer s ); @@ -41,4 +32,6 @@ struct pso_pointer c_string_to_lisp_keyword( struct pso_pointer frame_pointer, struct pso_pointer c_string_to_lisp_symbol( struct pso_pointer frame_pointer, char32_t * symbol ); +bool end_of_stringp(struct pso_pointer arg); + #endif diff --git a/src/c/payloads/cons.h b/src/c/payloads/cons.h index fdbfc8f..bb10292 100644 --- a/src/c/payloads/cons.h +++ b/src/c/payloads/cons.h @@ -49,7 +49,7 @@ struct pso_pointer make_cons( struct pso_pointer frame_pointer, */ #define make_cons2(car,cdr) (cons(make_frame(2, frame_pointer, car, cdr))) -#define c_car(p)(consp(p) ? pointer_to_object(p)->payload.cons.car : nil) -#define c_cdr(p)(consp(p) ? pointer_to_object(p)->payload.cons.cdr : nil) +#define c_car(p)(sequencep(p) ? pointer_to_object(p)->payload.cons.car : nil) +#define c_cdr(p)(sequencep(p) ? pointer_to_object(p)->payload.cons.cdr : nil) #endif diff --git a/src/c/payloads/exception.c b/src/c/payloads/exception.c index 729e1f9..2bcb802 100644 --- a/src/c/payloads/exception.c +++ b/src/c/payloads/exception.c @@ -15,6 +15,8 @@ #include +#include "debug.h" +#include "environment/privileged_keywords.h" #include "memory/node.h" #include "memory/pointer.h" #include "memory/pso.h" @@ -26,6 +28,7 @@ #include "ops/stack_ops.h" #include "ops/truth.h" +#include "payloads/cons.h" #include #include #include @@ -92,3 +95,71 @@ struct pso_pointer destroy_exception( struct pso_pointer fp ) { return nil; } + +/** + * 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( U"\nERROR: `", DEBUG_ANY, 0 ); + debug_print_object( message, DEBUG_ANY, 0 ); + debug_print( U"` at `", DEBUG_ANY, 0 ); + debug_print_object( location, DEBUG_ANY, 0 ); + debug_print( U"`\n", DEBUG_ANY, 0 ); + if ( !c_nilp( cause ) ) { + debug_print( U"\tCaused by: ", DEBUG_ANY, 0 ); + debug_print_object( cause, DEBUG_ANY, 0); + debug_print( U"`\n", DEBUG_ANY, 0 ); + } +#endif + struct pso2 *cell = pointer_to_object( message ); + + if (get_tag_value( message)) { + result = message; + } else { + struct pso_pointer x_frame = inc_ref(make_frame( + 2, frame_pointer, message, + (nilp(location) + ? nil + : make_cons(frame_pointer, + make_cons(frame_pointer, + privileged_keyword_location, location), + nil)), + cause)); + + result = push_local(frame_pointer, make_exception(x_frame)); + } + + 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 ); +} + diff --git a/src/c/payloads/function.h b/src/c/payloads/function.h index 2ab1a54..419ffa7 100644 --- a/src/c/payloads/function.h +++ b/src/c/payloads/function.h @@ -30,7 +30,6 @@ struct function_payload { */ struct pso_pointer meta; -#ifdef MANAGED_POINTER_ONLY /** * pointer to a C function which takes a managed pointer to the same stack * frame and a managed pointer to the environment as arguments. Arguments @@ -38,16 +37,6 @@ struct function_payload { * invocation. */ struct pso_pointer ( *executable ) ( struct pso_pointer frame_pointer ); -#else - /** - * pointer to a C function which takes an unmanaged pointer to a stack frame, - * a managed pointer to the same stack frame, and a managed pointer to the - * environment as arguments. Arguments to the Lisp function are assumed to be - * loaded into the frame before invocation. - */ - struct pso_pointer ( *executable ) ( struct pso4 * frame, - struct pso_pointer frame_pointer ); -#endif }; #endif diff --git a/src/c/payloads/keyword.c b/src/c/payloads/keyword.c new file mode 100644 index 0000000..325f4e3 --- /dev/null +++ b/src/c/payloads/keyword.c @@ -0,0 +1,27 @@ +/** + * keyword.c + * + * Post Scarcity Soctware Environment + * + * TODO: Edit purpose. + * + * Copyright (c): 27 Apr 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include "memory/pointer.h" +#include "memory/tags.h" +#include "ops/string_ops.h" + + /** + * Construct a keyword from the character `c` and this `tail`. A string is + * implemented as a flat list of cells each of which has one character and a + * pointer to the next; in the last cell the pointer to next is NIL. + * + * @param c the character to add (prepend); + * @param tail the keyword which is being built. + */ + struct pso_pointer make_keyword( struct pso_pointer frame_pointer, wint_t c, + struct pso_pointer tail ) { + return make_string_like_thing( frame_pointer, c, tail, KEYTAG ); + } diff --git a/src/c/payloads/keyword.h b/src/c/payloads/keyword.h index 4728066..35bbbe7 100644 --- a/src/c/payloads/keyword.h +++ b/src/c/payloads/keyword.h @@ -11,9 +11,13 @@ #define __psse_payloads_keyword_h #include "memory/pointer.h" +#include /* TODO: for now, Keyword shares a payload with String, but this may change. * Strings are of indefinite length, but keywords are really not, and might * fit into any size class. */ + + struct pso_pointer make_keyword( struct pso_pointer frame_pointer, wint_t c, + struct pso_pointer tail ); #endif diff --git a/src/c/payloads/lambda.c b/src/c/payloads/lambda.c new file mode 100644 index 0000000..b38ad9d --- /dev/null +++ b/src/c/payloads/lambda.c @@ -0,0 +1,24 @@ +/** + * lambda.c + * + * Post Scarcity Soctware Environment + * + * TODO: Edit purpose. + * + * Copyright (c): 27 Apr 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include "memory/pointer.h" +#include "memory/pso.h" +#include "memory/pso2.h" + +struct pso_pointer make_lambda_like_thing(struct pso_pointer frame_pointer, + struct pso_pointer args, + struct pso_pointer body, char *tag) { + + struct pso_pointer result = allocate(frame_pointer, tag, 2); + struct pso2 *object = pointer_to_object(result); + object->payload.lambda.args = args; + object->payload.lambda.body = body; +} diff --git a/src/c/payloads/lambda.h b/src/c/payloads/lambda.h index cfa9bde..0873719 100644 --- a/src/c/payloads/lambda.h +++ b/src/c/payloads/lambda.h @@ -11,6 +11,7 @@ #define __psse_payloads_lambda_h #include "memory/pointer.h" +#include "memory/tags.h" /** * @brief Tag for lambda cell. Lambdas are the interpretable (source) versions of functions. @@ -29,5 +30,9 @@ struct lambda_payload { struct pso_pointer body; }; - +struct pso_pointer make_lambda_like_thing(struct pso_pointer frame_pointer, + struct pso_pointer args, + struct pso_pointer body, char *tag); + +#define make_lambda(f,a,b) (make_lambda_like_thing( f, a, b, LAMBDATAG)) #endif diff --git a/src/c/payloads/nlambda.h b/src/c/payloads/nlambda.h index d82d2e3..874bc87 100644 --- a/src/c/payloads/nlambda.h +++ b/src/c/payloads/nlambda.h @@ -11,7 +11,11 @@ #define __psse_payloads_nlambda_h #include "memory/pointer.h" +#include "memory/tags.h" +#include "payloads/lambda.h" /* nlambda shares a payload with lambda */ +#define make_nlambda(f,a,b)(make_lambda_like_thing(f, a, b, NLAMBDATAG)) + #endif diff --git a/src/c/payloads/packed_string.h b/src/c/payloads/packed_string.h new file mode 100644 index 0000000..e09d078 --- /dev/null +++ b/src/c/payloads/packed_string.h @@ -0,0 +1,33 @@ +/** + * packed_string.h + * + * Post Scarcity Soctware Environment + * + * The idea of a packed string is that it is an array of wide characters, + * packed into a paged space object. Any size of paged space object may be + * used. + * + * The initial inspiration is I wanted to use swprintf to produce formatted + * strings. Eventually, we will have a `format` function in Lisp similar to + * Common Lisp's or Clojure's, so this issue will go away. But it may still + * be useful to have an array of character as an explicit type. + * + * Copyright (c): 22 Apr 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef SRC_C_PAYLOADS_PACKED_STRING_H_ +#define SRC_C_PAYLOADS_PACKED_STRING_H_ +#include +/* + * wide characters + */ +#include + +struct packed_string_payload { + uint32_t length; /* number of characters */ + wchar_t chars[]; /* actual characters. */ +}; + + +#endif /* SRC_C_PAYLOADS_PACKED_STRING_H_ */ diff --git a/src/c/payloads/psse_string.c b/src/c/payloads/psse_string.c index 2206138..cc5eaef 100644 --- a/src/c/payloads/psse_string.c +++ b/src/c/payloads/psse_string.c @@ -20,11 +20,25 @@ #include "memory/pso4.h" #include "memory/tags.h" +#include "ops/string_ops.h" #include "payloads/cons.h" #include "ops/stack_ops.h" +/** + * Construct a string from the character `c` and this `tail`. A string is + * implemented as a flat list of cells each of which has one character and a + * pointer to the next; in the last cell the pointer to next is NIL. + * + * @param c the character to add (prepend); + * @param tail the string which is being built. + */ +struct pso_pointer make_string( struct pso_pointer frame_pointer, wint_t c, + struct pso_pointer tail ) { + return make_string_like_thing( frame_pointer, c, tail, STRINGTAG ); +} + /** * @brief When an string is freed, its cdr pointer must be decremented. * diff --git a/src/c/payloads/psse_string.h b/src/c/payloads/psse_string.h index 8c71039..7e1c75e 100644 --- a/src/c/payloads/psse_string.h +++ b/src/c/payloads/psse_string.h @@ -33,6 +33,9 @@ struct string_payload { struct pso_pointer cdr; }; +struct pso_pointer make_string( struct pso_pointer frame_pointer, wint_t c, + struct pso_pointer tail ); + struct pso_pointer destroy_string( struct pso_pointer fp ); #endif diff --git a/src/c/payloads/symbol.c b/src/c/payloads/symbol.c new file mode 100644 index 0000000..4030831 --- /dev/null +++ b/src/c/payloads/symbol.c @@ -0,0 +1,29 @@ +/** + * symbol.c + * + * Post Scarcity Soctware Environment + * + * TODO: Edit purpose. + * + * Copyright (c): 27 Apr 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include + +#include "memory/pointer.h" +#include "memory/tags.h" +#include "ops/string_ops.h" + + /** + * Construct a symbol from the character `c` and this `tail`. A string is + * implemented as a flat list of cells each of which has one character and a + * pointer to the next; in the last cell the pointer to next is NIL. + * + * @param c the character to add (prepend); + * @param tail the symbol which is being built. + */ +struct pso_pointer make_symbol( struct pso_pointer frame_pointer, wint_t c, + struct pso_pointer tail ) { + return make_string_like_thing( frame_pointer, c, tail, SYMBOLTAG ); + } diff --git a/src/c/payloads/symbol.h b/src/c/payloads/symbol.h index cddd293..3460983 100644 --- a/src/c/payloads/symbol.h +++ b/src/c/payloads/symbol.h @@ -10,10 +10,15 @@ #ifndef __psse_payloads_symbol_h #define __psse_payloads_symbol_h +#include + #include "memory/pointer.h" /* TODO: for now, Symbol shares a payload with String, but this may change. * Strings are of indefinite length, but symbols are really not, and might * fit into any size class. */ + + struct pso_pointer make_symbol( struct pso_pointer frame_pointer, wint_t c, + struct pso_pointer tail ); #endif