simon/post-scarcity
1
0
Fork 0
Code Issues 18 Pull requests Projects Releases Packages Wiki Activity Actions

Still still doesn't compile. Progress is being made, but it's fair awfy slow.

Browse source
This commit is contained in:
Simon Brooke 2026-05-03 14:17:31 +01:00
parent aac4669a3d
commit ab0ea09bd4
18 changed files with 255 additions and 426 deletions
Download patch file Download diff file Expand all files Collapse all files

8
docs/State-of-play.md
View file

@ -1,5 +1,13 @@
# State of Play
## 20260503
Right, so, it's a week since my last entry. The version of eval/apply copied from `0.0.6` still doesn't compile, let alone work. There are reasons. I've been ill — my brain really is fucked — and I've had outdoor work it's felt urgent to do.
There is progress. I am cleaning up bits of old cruft as I go. But I don't think copying the old code was a good decision. Probably, if I had started a clean room implementation a week ago, I would now have a working evaluator. Certainly, I'd have a better one.
Probably, the first thing I should do when I get the old one working is write a new, clean, one.
## 20260427
### eval/apply, yet again

12
src/c/io/print.c
View file

@ -268,6 +268,17 @@ struct pso_pointer write( struct pso_pointer frame_pointer ) {
return result;
}
struct pso_pointer c_write(struct pso_pointer frame_pointer,
struct pso_pointer object, struct pso_pointer stream,
bool escape, bool nl_before, bool nl_after) {
struct pso_pointer next_pointer =
push_local(frame_pointer, make_frame(5, frame_pointer, object, stream, escape ? t : nil,
nl_before ? t : nil, nl_after ? t : nil));
struct pso_pointer result = push_local(frame_pointer, write(next_pointer));
return result;
}
/**
* @brief Simple print for bootstrap layer.
*
@ -307,3 +318,4 @@ struct pso_pointer princ( struct pso_pointer frame_pointer ) {
return result;
}

7
src/c/io/print.h
View file

@ -26,4 +26,11 @@ struct pso_pointer princ( struct pso_pointer frame_pointer );
struct pso_pointer in_write( struct pso_pointer p, URL_FILE * output,
bool escape, int indent );
struct pso_pointer c_write(struct pso_pointer frame_pointer,
struct pso_pointer object, struct pso_pointer stream,
bool escape, bool nl_before, bool nl_after);
#define c_print(f,o,s)(c_write(f,o,s,true,true,false))
#define c_princ(f,o,s)(c_write(f,o,s,false,true,false))
#endif

23
src/c/memory/pso2.h
View file

@ -12,21 +12,29 @@
#include <stdint.h>
#include "../payloads/psse_string.h"
#include "payloads/psse_string.h"
#include "memory/header.h"
#include "payloads/character.h"
#include "payloads/cons.h"
#include "payloads/float.h"
#include "payloads/free.h"
#include "payloads/function.h"
#include "payloads/integer.h"
#include "payloads/keyword.h"
#include "payloads/lambda.h"
#include "payloads/nlambda.h"
#include "payloads/read_stream.h"
#include "payloads/symbol.h"
#include "payloads/time.h"
#include "payloads/vector_pointer.h"
#include "payloads/write_stream.h"
/**
* @brief A cons cell.
*
* included here to avoid circularity.
*/
struct cons_payload {
/** Contents of the Address Register, naturally. */
struct pso_pointer car;
/** Contents of the Decrement Register, naturally. */
struct pso_pointer cdr;
};
/**
* @brief A paged space object of size class 2, four words total, two words
@ -43,7 +51,8 @@ struct pso2 {
struct free_payload free;
struct function_payload function;
struct integer_payload integer;
struct lambda_payload lambda;
struct lambda_payload lambda;
struct float_payload real;
struct function_payload special;
struct stream_payload stream;
struct string_payload string;

7
src/c/memory/tags.h
View file

@ -122,6 +122,9 @@ bool check_type( struct pso_pointer p, char *s );
#define ratiop(p) (check_tag(p,RATIOTV))
#define readp(p) (check_tag(p,READTV))
#define realp(p) (check_tag(p,REALTV))
/** 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) (check_tag(p,CONSTV)||check_tag(p,STRINGTV)||check_tag(p,SYMBOLTV))
#define specialp(p) (check_tag(p,SPECIALTV))
#define stackp(p) (check_tag(p, STACKTV))
@ -137,9 +140,5 @@ bool check_type( struct pso_pointer p, char *s );
#define vectorp(p) (check_tag(p,VECTORTV))
#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

17
src/c/ops/cond.c
View file

@ -1,7 +1,7 @@
/**
* @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
* @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"
@ -10,8 +10,10 @@
#include "memory/pso2.h"
#include "memory/tags.h"
#include "ops/eval_apply.h"
#include "ops/progn.h"
#include "ops/stack_ops.h"
#include "ops/string_ops.h"
#include "ops/truth.h"
#include "payloads/cons.h"
@ -38,13 +40,12 @@ struct pso_pointer eval_cond_clause( struct pso_pointer clause,
#endif
if ( consp( clause ) ) {
struct pso_pointer val =
eval_form( frame, frame_pointer, c_car( clause ),
env );
struct pso_pointer test_frame = push_local( frame_pointer, make_frame(1, frame_pointer, c_car(clause)));
struct pso_pointer val = lisp_eval(test_frame);
if ( !c_nilp( val ) ) {
result =
cons( t,
make_cons( frame_pointer, t,
c_progn( frame, frame_pointer, c_cdr( clause ), env ) );
#ifdef DEBUG
@ -94,8 +95,8 @@ lisp_cond( struct pso4 *frame, struct pso_pointer frame_pointer,
// 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 ) ) ) {

124
src/c/ops/dump.c
View file

@ -3,6 +3,9 @@
*
* Dump representations of both cons space and vector space objects.
*
* TODO: This is going to be entirely rewritten and merged with `inspect.c`,
* q.v., which will be the main entrypoint to this code. What exists is
* technical debt but will work for now.
*
* (c) 2018 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
@ -14,24 +17,29 @@
#include <wchar.h>
#include <wctype.h>
#include "memory/pointer.h"
#include "memory/pso2.h"
#include "memory/pso4.h"
#include "memory/tags.h"
#include "io/print.h"
#include "ops/stack_ops.h"
#include "payloads/lambda.h"
void dump_string_cell( URL_FILE *output, wchar_t *prefix,
void dump_string_cell( struct pso_pointer frame_pointer, struct pso_pointer output, wchar_t *prefix,
struct pso_pointer pointer ) {
URL_FILE* os = pointer_to_object(output)->payload.stream.stream;
struct pso2 *cell = pointer_to_object( pointer );
if ( cell->payload.string.character == 0 ) {
url_fwprintf( output,
if ( cell->payload.string.character == 0 ) {
url_fwprintf( os,
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,
url_fwprintf( os,
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,
@ -39,102 +47,108 @@ void dump_string_cell( URL_FILE *output, wchar_t *prefix,
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" );
url_fwprintf( os, L"\t\t value: " );
c_print( frame_pointer, pointer, output );
url_fwprintf( os, 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",
void dump_object( struct pso_pointer frame_pointer, struct pso_pointer output, struct pso_pointer pointer ) {
URL_FILE* os = pointer_to_object(output)->payload.stream.stream;
struct pso2 *cell = pointer_to_object( pointer );
url_fwprintf( os, 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,
url_fwprintf( os,
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 );
c_print( frame_pointer, pointer, output );
url_fputws( L"\n", os );
break;
// case EXCEPTIONTV:
// url_fwprintf( os, L"\t\tException cell: " );
// dump_stack_trace( output, pointer );
// break;
case FREETV:
url_fwprintf( output,
url_fwprintf( os,
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 HASHTV:
// dump_map( output, pointer );
// break;
case INTEGERTV:
url_fwprintf( output, L"\t\tInteger cell: value %ld, count %u\n",
url_fwprintf( os, 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 );
dump_string_cell( frame_pointer, 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 );
url_fwprintf( os, L"\t\t\u03bb cell;\n\t\t args: " );
c_print( frame_pointer, cell->payload.lambda.args, output );
url_fwprintf( os, L";\n\t\t\tbody: " );
c_print( frame_pointer, cell->payload.lambda.body, output );
url_fputws( L"\n", os );
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 );
url_fwprintf( os, L"\t\tn\u03bb cell; \n\t\targs: " );
c_print( frame_pointer, cell->payload.lambda.args, output );
url_fwprintf( os, L";\n\t\t\tbody: " );
c_print( frame_pointer, cell->payload.lambda.body, output );
url_fputws( L"\n", os );
break;
// case RATIOTV:
// url_fwprintf( os,
// 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 );
url_fputws( L"\t\tInput stream; metadata: ", os );
c_print( frame_pointer, cell->payload.stream.meta, output );
url_fputws( L"\n", os );
break;
case REALTV:
url_fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n",
url_fwprintf( os, 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 STACKTV:
// dump_frame( frame_pointer, output, pointer );
// break;
case STRINGTV:
dump_string_cell( output, L"String", pointer );
dump_string_cell( frame_pointer, output, L"String", pointer );
break;
case SYMBOLTV:
dump_string_cell( output, L"Symbol", pointer );
dump_string_cell( frame_pointer, 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;
url_fputws( L"\t\tOutput stream; metadata: ", os );
c_print( frame_pointer, cell->payload.stream.meta, output );
url_fputws( L"\n", os );
break;
default:
url_fwprintf(os, L"TODO: Cannot yet dump object of type %3.3s\n",
cell->header.tag.bytes.mnemonic[0]);
break;
}
}

404
src/c/ops/eval_apply.c
View file

@ -32,6 +32,7 @@
#include "ops/assoc.h"
#include "ops/bind.h"
#include "ops/eval_apply.h"
#include "ops/progn.h"
#include "ops/reverse.h"
#include "ops/stack_ops.h"
#include "ops/string_ops.h"
@ -43,11 +44,12 @@
#include "payloads/lambda.h"
#include "payloads/nlambda.h"
#include "payloads/stack.h"
#include "payloads/symbol.h"
///**
// * @brief Apply a function to arguments in an environment.
// *
// * * (apply fn args)
// * * (apply fn args)
// */
//struct pso_pointer apply( struct pso_pointer frame_pointer ) {
//
@ -58,7 +60,7 @@
///**
// * @brief Evaluate a form, in an environment
// *
// * * (eval form)
// * * (eval form)
// */
//struct pso_pointer eval( struct pso_pointer frame_pointer ) {
// struct pso4 *frame = pointer_to_pso4( frame_pointer );
@ -164,7 +166,7 @@ struct pso_pointer eval_form( struct pso_pointer frame_pointer ) {
#ifdef DEBUG
debug_print( L"eval_form: ", DEBUG_EVAL, 0 );
debug_print_object( form, DEBUG_EVAL, 0 );
debug_println( DEBUG_EVAL, 0 );
debug_println( DEBUG_EVAL );
#endif
struct pso_pointer result = form;
@ -214,7 +216,7 @@ struct pso_pointer eval_form( struct pso_pointer frame_pointer ) {
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 );
debug_println( DEBUG_EVAL );
return result;
}
@ -264,16 +266,14 @@ struct pso_pointer lisp_try( struct pso_pointer frame_pointer,
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 ) ) );
push_local( frame_pointer, make_frame( 1, frame_pointer, fetch_arg( frame, 0 ) ) );
result = push_local( frame_pointer, progn( body_frame ) );
dec_ref( body_frame );
result = push_local( frame_pointer, lisp_progn( 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,
push_local( frame_pointer, make_frame_with_env( 1, frame_pointer,
make_cons( frame_pointer,
make_cons( frame_pointer,
c_string_to_lisp_symbol
@ -284,9 +284,7 @@ struct pso_pointer lisp_try( struct pso_pointer frame_pointer,
( frame_pointer ) ),
frame->payload.stack_frame.
arg[1] ) );
result = push_local( progn( catch_frame ) );
dec_ref( catch_frame );
result = push_local( frame_pointer, lisp_progn( catch_frame ) );
}
return result;
@ -348,7 +346,7 @@ struct pso_pointer compose_body( struct pso_pointer 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 ) );
return make_lambda( frame_pointer, fetch_arg(frame, 0), compose_body( frame_pointer ) );
}
/**
@ -366,7 +364,7 @@ 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 ) );
return make_nlambda( frame_pointer, fetch_arg(frame, 0), compose_body( frame_pointer ) );
}
@ -379,7 +377,7 @@ eval_lambda( struct pso_pointer frame_pointer ) {
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 = lambda->payload.lambda.args;
struct pso_pointer body = lambda->payload.lambda.body;
@ -410,9 +408,9 @@ eval_lambda( struct pso_pointer frame_pointer ) {
* 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 more_frame = inc_ref(
make_frame(1, frame_pointer,
make_frame(1, frame_pointer,
frame->payload.stack_frame.more));
struct pso_pointer vals =
eval_forms( more_frame );
@ -464,7 +462,7 @@ eval_lambda( struct pso_pointer frame_pointer ) {
/**
* 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.
* the name associated with this fn_pointer, if any.
*/
struct pso_pointer maybe_fixup_exception_location( struct pso_pointer r,
struct pso_pointer
@ -520,7 +518,7 @@ struct pso_pointer maybe_fixup_exception_location( struct pso_pointer r,
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 =
@ -528,7 +526,7 @@ struct pso_pointer make_fn_frame(struct pso_pointer previous,
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)) {
@ -557,7 +555,6 @@ struct pso_pointer make_fn_frame(struct pso_pointer previous,
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`.
@ -572,12 +569,12 @@ struct pso_pointer make_fn_frame(struct pso_pointer previous,
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)) {
@ -585,7 +582,7 @@ struct pso_pointer make_special_frame(struct pso_pointer previous,
new_frame->payload.stack_frame.arg[args++] = inc_ref( c_car(cursor) );
}
if (consp(cursor)) {
new_frame->payload.stack_frame.more = inc_ref( cursor);
}
@ -594,7 +591,6 @@ struct pso_pointer make_special_frame(struct pso_pointer previous,
return new_pointer;
}
/**
* Internal guts of apply.
* @param frame the stack frame, expected to have only one argument, a list
@ -611,7 +607,7 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) {
struct pso_pointer fn_pointer =
push_local(frame_pointer, eval_form( fn_frame));
dec_ref( fn_frame);
if ( exceptionp( fn_pointer ) ) {
result = fn_pointer;
} else {
@ -675,7 +671,7 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) {
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
@ -736,7 +732,7 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) {
c_string_to_lisp_string( frame_pointer, buffer );
free( buffer );
result =
make_exception( frame_pointer, c_string_to_lisp_symbol( frame_pointer, U"apply" ),
throw_exception( c_string_to_lisp_symbol( frame_pointer, U"apply" ),
message, frame_pointer );
}
}
@ -809,7 +805,7 @@ lisp_eval( struct pso_pointer frame_pointer ) {
/*
* \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;
* 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:
@ -823,10 +819,6 @@ lisp_eval( struct pso_pointer frame_pointer ) {
return result;
}
/**
* Special form;
* returns its argument (strictly first argument - only one is expected but
@ -845,8 +837,26 @@ lisp_quote( struct pso4 *frame, struct pso_pointer frame_pointer,
return frame->payload.stack_frame.arg[0];
}
/**
* Get the Lisp type of the single argument.
* @param pointer a pointer to the object whose type is requested.
* @return As a Lisp string, the tag of the object which is at that pointer.
*/
struct pso_pointer c_type( struct pso_pointer frame_pointer, struct pso_pointer pointer ) {
/* Strings read by `read` have the null character termination. This means
* that for the same printable string, the hashcode is different from
* strings made with NIL termination. The question is which should be
* fixed, and actually that's probably strings read by `read`. However,
* for now, it was easier to add a null character here. */
struct pso_pointer result = make_symbol( frame_pointer, ( wchar_t ) 0, nil );
struct pso2 *cell = pointer_to_object( pointer );
for ( int i = TAGLENGTH - 1; i >= 0; i-- ) {
result = make_symbol( frame_pointer, ( wchar_t ) cell->header.tag.bytes.mnemonic[i], result );
}
return result;
}
/**
@ -854,153 +864,14 @@ lisp_quote( struct pso4 *frame, struct pso_pointer frame_pointer,
*
* * (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`.
* @return As a Lisp symbol, 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] );
lisp_type( struct pso_pointer frame_pointer ) {
return c_type( frame_pointer, fetch_arg( pointer_to_pso4( frame_pointer), 0) );
}
/**
* 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.
@ -1013,14 +884,13 @@ struct pso_pointer lisp_repl( struct pso4 *frame,
* @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 lisp_source( struct pso_pointer frame_pointer) {
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 ) {
struct pso4* frame = pointer_to_pso4(frame_pointer);
struct pso2 *cell =
pointer_to_object( fetch_arg( frame, 0) );
struct pso_pointer source_key = c_string_to_lisp_keyword( frame_pointer, L"source" );
switch ( get_tag_value(fetch_arg( frame, 0)) ) {
case FUNCTIONTV:
result = c_assoc( source_key, cell->payload.function.meta );
break;
@ -1028,151 +898,38 @@ struct pso_pointer lisp_source( struct pso4 *frame,
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 ) );
result = make_cons( frame_pointer,
c_string_to_lisp_symbol( frame_pointer, L"λ" ),
make_cons( frame_pointer,
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 ) );
result = make_cons( frame_pointer, c_string_to_lisp_symbol( frame_pointer, L"nλ" ),
make_cons( frame_pointer, cell->payload.lambda.args,
cell->payload.lambda.body ) ) );
break;
}
// \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 );
push_local( frame_pointer, result );
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.
*
* (list args...)
*
* @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 lisp_list( struct pso_pointer frame_pointer ) {
struct pso4* frame = pointer_to_pso4( frame_pointer);
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 );
result = make_cons( frame_pointer, fetch_arg( frame, a ), result );
}
return result;
@ -1191,7 +948,7 @@ struct pso_pointer lisp_let( struct pso4 *frame,
struct pso_pointer bindings = env;
struct pso_pointer result = nil;
for ( struct pso_pointer cursor = frame->payload.stack_frame.arg[0];
for ( struct pso_pointer cursor = fetch_arg( frame, 0);
tp( cursor ); cursor = c_cdr( cursor ) ) {
struct pso_pointer pair = c_car( cursor );
struct pso_pointer symbol = c_car( pair );
@ -1216,6 +973,17 @@ struct pso_pointer lisp_let( struct pso4 *frame,
debug_print( L"\nlet: bindings complete.\n", DEBUG_BIND, 0 );
struct pso_pointer progn_pointer = make_frame_with_env( 0, frame_pointer, env);
progn_frame = pointer_to_pso4(progn_pointer);
int a = 1;
for (; a < frame->payload.stack_frame.args && a < args_in_frame; a++) {
progn_frame->payload.stack_frame.arg[a-1] = fetch_arg( frame, a);
progn_frame->payload.stack_frame.args ++;
}
if ( a < frame->payload.stack_frame.args) {
progn_frame->payload.stack_frame.arg[a-1] = fetch_arg( frame, a);
}
/* i.e., no exception yet */
for ( int form = 1;
!exceptionp( result ) && form < frame->payload.stack_frame.args;
@ -1225,19 +993,13 @@ struct pso_pointer lisp_let( struct pso4 *frame,
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.
@ -1246,7 +1008,7 @@ struct pso_pointer lisp_let( struct pso4 *frame,
struct pso_pointer lisp_and( struct pso4 *frame,
struct pso_pointer frame_pointer,
struct pso_pointer env ) {
bool accumulator = t;
bool accumulator = true;
struct pso_pointer result = frame->payload.stack_frame.more;
for ( int a = 0; accumulator == t && a < frame->payload.stack_frame.args;
@ -1259,7 +1021,7 @@ struct pso_pointer lisp_and( struct pso4 *frame,
/**
* @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.
@ -1281,7 +1043,7 @@ struct pso_pointer lisp_or( struct pso4 *frame,
/**
* @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.

11
src/c/ops/inspect.c
View file

@ -17,6 +17,7 @@
#include "memory/pso2.h"
#include "memory/pso4.h"
#include "memory/tags.h"
#include "ops/inspect.h"
#include "ops/stack_ops.h"
/**
@ -48,15 +49,7 @@ struct pso_pointer lisp_inspect(struct pso_pointer frame_pointer) {
: 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] );
dump_object( frame_pointer, fetch_arg(frame,1), fetch_arg(frame, 0) );
debug_print( L"Leaving lisp_inspect", DEBUG_IO, 0 );

9
src/c/ops/inspect.h
View file

@ -12,5 +12,14 @@
#ifndef psse_ops_inspect
#define psse_ops_inspect
#include "memory/pointer.h"
/**
* Legacy technical debt to be entirely rewritten
*/
void dump_object(struct pso_pointer frame_pointer,
struct pso_pointer output, struct pso_pointer pointer );
struct pso_pointer lisp_inspect( struct pso_pointer frame_pointer );
#endif

7
src/c/ops/keys.c
View file

@ -20,14 +20,15 @@
* @brief an implementation of `keys` convenient for calling from C
*
* @param */
struct pso_pointer c_keys( struct pso_pointer store ) {
struct pso_pointer c_keys(struct pso_pointer frame_pointer,
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 );
result = make_cons( frame_pointer, c_car( pair ), result );
// } else if ( hashtabp( pair ) ) {
// result = c_append( hashmap_keys( pair ), result );
}
@ -44,6 +45,6 @@ struct pso_pointer c_keys( struct pso_pointer store ) {
struct pso_pointer lisp_keys( struct pso_pointer frame_pointer) {
return c_keys( pointer_to_pso4(frame_pointer)->payload.stack_frame.arg[0] );
return c_keys( frame_pointer, pointer_to_pso4(frame_pointer)->payload.stack_frame.arg[0] );
}

10
src/c/ops/mapcar.c
View file

@ -14,15 +14,15 @@
#include "memory/node.h"
#include "memory/pointer.h"
#include "memory/pso.h"
#include "memory/pso4.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;
struct pso_pointer lisp_mapcar( struct pso_pointer frame_pointer ) {
struct pso_pointer result = nil;
struct pso4* frame = pointer_to_pso4(frame_pointer);
debug_print( U"Mapcar: ", DEBUG_EVAL, 0 );
debug_dump_object( frame_pointer, DEBUG_EVAL, 0 );
int i = 0;
@ -34,7 +34,7 @@ struct pso_pointer lisp_mapcar( struct pso4 *frame,
debug_printf( DEBUG_EVAL, 0, U"Mapcar %d, evaluating ", i );
debug_print_object( expr, DEBUG_EVAL, 0 );
debug_println( DEBUG_EVAL, 0 );
debug_println( DEBUG_EVAL);
struct pso_pointer r = eval_form( frame, frame_pointer, expr, env );

17
src/c/ops/mapcar.h
View file

@ -0,0 +1,17 @@
/**
* ops/mapcar.h
*
* Post Scarcity Software Environment: mapcar.
*
* map a function across a sequence of forms.
*
* (c) 2026 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef psse_ops_mapcar
#define psse_ops_mapcar
#endif

4
src/c/ops/progn.c
View file

@ -76,8 +76,8 @@ lisp_progn( struct pso_pointer frame_pointer) {
}
if (consp(frame->payload.stack_frame.more)) {
result =
c_progn(frame, frame_pointer, frame->payload.stack_frame.more, env);
result = c_progn(frame, frame_pointer, frame->payload.stack_frame.more,
fetch_env(frame_pointer));
}
return result;

2
src/c/ops/repl.c
View file

@ -93,7 +93,7 @@ void repl( struct pso_pointer frame_pointer ) {
dec_ref( next );
next = inc_ref( make_frame( 1, base_of_stack, read_value ) );
struct pso_pointer eval_value = inc_ref( eval( next ) );
struct pso_pointer eval_value = inc_ref( lisp_eval( next ) );
dec_ref( next );
dec_ref( read_value );

13
src/c/payloads/cons.h
View file

@ -12,20 +12,13 @@
#include <stdbool.h>
#include "memory/pointer.h"
#include "memory/pso2.h"
#include "memory/pso4.h"
#define CONS_SIZE_CLASS 2
/**
* @brief A cons cell.
*
*/
struct cons_payload {
/** Contents of the Address Register, naturally. */
struct pso_pointer car;
/** Contents of the Decrement Register, naturally. */
struct pso_pointer cdr;
};
/* NOTE THAT the definition of a cons payload has to be in memory/pso2.h to
* avoid circularity. */
struct pso_pointer car( struct pso_pointer frame_pointer );

2
src/c/payloads/exception.c
View file

@ -132,7 +132,7 @@ struct pso_pointer throw_exception_with_cause( struct pso_pointer location,
} else {
struct pso_pointer x_frame = inc_ref(make_frame(
2, frame_pointer, message,
(nilp(location)
(c_nilp(location)
? nil
: make_cons(frame_pointer,
make_cons(frame_pointer,

4
src/c/payloads/exception.h
View file

@ -30,4 +30,8 @@ struct pso_pointer make_exception( struct pso_pointer frame_pointer );
struct pso_pointer destroy_exception( struct pso_pointer fp );
struct pso_pointer
throw_exception( struct pso_pointer location,
struct pso_pointer payload,
struct pso_pointer frame_pointer );
#endif