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 # 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 ## 20260427
### eval/apply, yet again ### 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; 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. * @brief Simple print for bootstrap layer.
* *
@ -307,3 +318,4 @@ struct pso_pointer princ( struct pso_pointer frame_pointer ) {
return result; 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, struct pso_pointer in_write( struct pso_pointer p, URL_FILE * output,
bool escape, int indent ); 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 #endif

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

@ -12,21 +12,29 @@
#include <stdint.h> #include <stdint.h>
#include "../payloads/psse_string.h" #include "payloads/psse_string.h"
#include "memory/header.h" #include "memory/header.h"
#include "payloads/character.h" #include "payloads/character.h"
#include "payloads/cons.h" #include "payloads/float.h"
#include "payloads/free.h" #include "payloads/free.h"
#include "payloads/function.h" #include "payloads/function.h"
#include "payloads/integer.h" #include "payloads/integer.h"
#include "payloads/keyword.h"
#include "payloads/lambda.h" #include "payloads/lambda.h"
#include "payloads/nlambda.h"
#include "payloads/read_stream.h" #include "payloads/read_stream.h"
#include "payloads/symbol.h"
#include "payloads/time.h" #include "payloads/time.h"
#include "payloads/vector_pointer.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 * @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 free_payload free;
struct function_payload function; struct function_payload function;
struct integer_payload integer; struct integer_payload integer;
struct lambda_payload lambda; struct lambda_payload lambda;
struct float_payload real;
struct function_payload special; struct function_payload special;
struct stream_payload stream; struct stream_payload stream;
struct string_payload string; 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 ratiop(p) (check_tag(p,RATIOTV))
#define readp(p) (check_tag(p,READTV)) #define readp(p) (check_tag(p,READTV))
#define realp(p) (check_tag(p,REALTV)) #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 sequencep(p) (check_tag(p,CONSTV)||check_tag(p,STRINGTV)||check_tag(p,SYMBOLTV))
#define specialp(p) (check_tag(p,SPECIALTV)) #define specialp(p) (check_tag(p,SPECIALTV))
#define stackp(p) (check_tag(p, STACKTV)) #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 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 #endif

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

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

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

@ -3,6 +3,9 @@
* *
* Dump representations of both cons space and vector space objects. * 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> * (c) 2018 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version. * Licensed under GPL version 2.0, or, at your option, any later version.
@ -14,24 +17,29 @@
#include <wchar.h> #include <wchar.h>
#include <wctype.h> #include <wctype.h>
#include "memory/pointer.h"
#include "memory/pso2.h" #include "memory/pso2.h"
#include "memory/pso4.h"
#include "memory/tags.h" #include "memory/tags.h"
#include "io/print.h" #include "io/print.h"
#include "ops/stack_ops.h"
#include "payloads/lambda.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 ) { struct pso_pointer pointer ) {
URL_FILE* os = pointer_to_object(output)->payload.stream.stream;
struct pso2 *cell = pointer_to_object( pointer ); 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", L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n",
prefix, prefix,
cell->payload.string.cdr.page, cell->payload.string.cdr.page,
cell->payload.string.cdr.offset, cell->header.count ); cell->payload.string.cdr.offset, cell->header.count );
} else { } 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", L"\t\t%ls cell: character '%lc' (%d) with hash %d; next at page %d offset %d, count %u\n",
prefix, prefix,
( wint_t ) cell->payload.string.character, ( 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.hash,
cell->payload.string.cdr.page, cell->payload.string.cdr.page,
cell->payload.string.cdr.offset, cell->header.count ); cell->payload.string.cdr.offset, cell->header.count );
url_fwprintf( output, L"\t\t value: " ); url_fwprintf( os, L"\t\t value: " );
print( output, pointer ); c_print( frame_pointer, pointer, output );
url_fwprintf( output, L"\n" ); url_fwprintf( os, L"\n" );
} }
} }
/** /**
* dump the object at this pso_pointer to this output stream. * dump the object at this pso_pointer to this output stream.
*/ */
void dump_object( URL_FILE *output, struct pso_pointer pointer ) { void dump_object( struct pso_pointer frame_pointer, struct pso_pointer output, struct pso_pointer pointer ) {
struct pso2 *cell = pointer_to_object( pointer ); URL_FILE* os = pointer_to_object(output)->payload.stream.stream;
url_fwprintf( output, L"\t%3.3s (%d) at page %d, offset %d count %u\n",
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 ), cell->header.tag.bytes.mnemonic[0], get_tag_value( pointer ),
pointer.page, pointer.offset, cell->header.count ); pointer.page, pointer.offset, cell->header.count );
switch ( get_tag_value( pointer ) ) { switch ( get_tag_value( pointer ) ) {
case CONSTV: case CONSTV:
url_fwprintf( output, url_fwprintf( os,
L"\t\tCons cell: car at page %d offset %d, cdr at page %d " L"\t\tCons cell: car at page %d offset %d, cdr at page %d "
L"offset %d, count %u :", L"offset %d, count %u :",
cell->payload.cons.car.page, cell->payload.cons.car.page,
cell->payload.cons.car.offset, cell->payload.cons.car.offset,
cell->payload.cons.cdr.page, cell->payload.cons.cdr.page,
cell->payload.cons.cdr.offset ); cell->payload.cons.cdr.offset );
print( output, pointer ); c_print( frame_pointer, pointer, output );
url_fputws( L"\n", output ); url_fputws( L"\n", os );
break;
case EXCEPTIONTV:
url_fwprintf( output, L"\t\tException cell: " );
dump_stack_trace( output, pointer );
break; break;
// case EXCEPTIONTV:
// url_fwprintf( os, L"\t\tException cell: " );
// dump_stack_trace( output, pointer );
// break;
case FREETV: case FREETV:
url_fwprintf( output, url_fwprintf( os,
L"\t\tFree cell: next at page %d offset %d\n", L"\t\tFree cell: next at page %d offset %d\n",
cell->payload.cons.cdr.page, cell->payload.cons.cdr.page,
cell->payload.cons.cdr.offset ); cell->payload.cons.cdr.offset );
break; break;
case HASHTV: // case HASHTV:
dump_map( output, pointer ); // dump_map( output, pointer );
break; // break;
case INTEGERTV: 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 ); cell->payload.integer.value, cell->header.count );
break; break;
case KEYTV: case KEYTV:
dump_string_cell( output, L"Keyword", pointer ); dump_string_cell( frame_pointer, output, L"Keyword", pointer );
break; break;
case LAMBDATV: case LAMBDATV:
url_fwprintf( output, L"\t\t\u03bb cell;\n\t\t args: " ); url_fwprintf( os, L"\t\t\u03bb cell;\n\t\t args: " );
print( output, cell->payload.lambda.args ); c_print( frame_pointer, cell->payload.lambda.args, output );
url_fwprintf( output, L";\n\t\t\tbody: " ); url_fwprintf( os, L";\n\t\t\tbody: " );
print( output, cell->payload.lambda.body ); c_print( frame_pointer, cell->payload.lambda.body, output );
url_fputws( L"\n", output ); url_fputws( L"\n", os );
break; break;
case NILTV: case NILTV:
break; break;
case NLAMBDATV: case NLAMBDATV:
url_fwprintf( output, L"\t\tn\u03bb cell; \n\t\targs: " ); url_fwprintf( os, L"\t\tn\u03bb cell; \n\t\targs: " );
print( output, cell->payload.lambda.args ); c_print( frame_pointer, cell->payload.lambda.args, output );
url_fwprintf( output, L";\n\t\t\tbody: " ); url_fwprintf( os, L";\n\t\t\tbody: " );
print( output, cell->payload.lambda.body ); c_print( frame_pointer, cell->payload.lambda.body, output );
url_fputws( L"\n", output ); url_fputws( L"\n", os );
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; 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: case READTV:
url_fputws( L"\t\tInput stream; metadata: ", output ); url_fputws( L"\t\tInput stream; metadata: ", os );
print( output, cell->payload.stream.meta ); c_print( frame_pointer, cell->payload.stream.meta, output );
url_fputws( L"\n", output ); url_fputws( L"\n", os );
break; break;
case REALTV: 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 ); cell->payload.real.value, cell->header.count );
break; break;
case STACKTV: // case STACKTV:
dump_frame( output, pointer ); // dump_frame( frame_pointer, output, pointer );
break; // break;
case STRINGTV: case STRINGTV:
dump_string_cell( output, L"String", pointer ); dump_string_cell( frame_pointer, output, L"String", pointer );
break; break;
case SYMBOLTV: case SYMBOLTV:
dump_string_cell( output, L"Symbol", pointer ); dump_string_cell( frame_pointer, output, L"Symbol", pointer );
break; break;
case TRUETV: case TRUETV:
break; break;
case WRITETV: case WRITETV:
url_fputws( L"\t\tOutput stream; metadata: ", output ); url_fputws( L"\t\tOutput stream; metadata: ", os );
print( output, cell->payload.stream.meta ); c_print( frame_pointer, cell->payload.stream.meta, output );
url_fputws( L"\n", output ); url_fputws( L"\n", os );
break; break;
default:
url_fwprintf(os, L"TODO: Cannot yet dump object of type %3.3s\n",
cell->header.tag.bytes.mnemonic[0]);
break;
} }
} }

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

@ -32,6 +32,7 @@
#include "ops/assoc.h" #include "ops/assoc.h"
#include "ops/bind.h" #include "ops/bind.h"
#include "ops/eval_apply.h" #include "ops/eval_apply.h"
#include "ops/progn.h"
#include "ops/reverse.h" #include "ops/reverse.h"
#include "ops/stack_ops.h" #include "ops/stack_ops.h"
#include "ops/string_ops.h" #include "ops/string_ops.h"
@ -43,6 +44,7 @@
#include "payloads/lambda.h" #include "payloads/lambda.h"
#include "payloads/nlambda.h" #include "payloads/nlambda.h"
#include "payloads/stack.h" #include "payloads/stack.h"
#include "payloads/symbol.h"
///** ///**
// * @brief Apply a function to arguments in an environment. // * @brief Apply a function to arguments in an environment.
@ -164,7 +166,7 @@ struct pso_pointer eval_form( struct pso_pointer frame_pointer ) {
#ifdef DEBUG #ifdef DEBUG
debug_print( L"eval_form: ", DEBUG_EVAL, 0 ); debug_print( L"eval_form: ", DEBUG_EVAL, 0 );
debug_print_object( form, DEBUG_EVAL, 0 ); debug_print_object( form, DEBUG_EVAL, 0 );
debug_println( DEBUG_EVAL, 0 ); debug_println( DEBUG_EVAL );
#endif #endif
struct pso_pointer result = form; 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_object( form, DEBUG_EVAL, 0 );
debug_print( L" returning: ", DEBUG_EVAL, 0 ); debug_print( L" returning: ", DEBUG_EVAL, 0 );
debug_print_object( result, DEBUG_EVAL, 0 ); debug_print_object( result, DEBUG_EVAL, 0 );
debug_println( DEBUG_EVAL, 0 ); debug_println( DEBUG_EVAL );
return result; return result;
} }
@ -264,16 +266,14 @@ struct pso_pointer lisp_try( struct pso_pointer frame_pointer,
struct pso_pointer result = nil; struct pso_pointer result = nil;
struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer body_frame = 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 ) ); result = push_local( frame_pointer, lisp_progn( body_frame ) );
dec_ref( body_frame );
if ( exceptionp( result ) ) { if ( exceptionp( result ) ) {
// TODO: need to put the exception into the environment! // TODO: need to put the exception into the environment!
struct pso_pointer catch_frame = 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,
make_cons( frame_pointer, make_cons( frame_pointer,
c_string_to_lisp_symbol c_string_to_lisp_symbol
@ -284,9 +284,7 @@ struct pso_pointer lisp_try( struct pso_pointer frame_pointer,
( frame_pointer ) ), ( frame_pointer ) ),
frame->payload.stack_frame. frame->payload.stack_frame.
arg[1] ) ); arg[1] ) );
result = push_local( progn( catch_frame ) ); result = push_local( frame_pointer, lisp_progn( catch_frame ) );
dec_ref( catch_frame );
} }
return result; return result;
@ -348,7 +346,7 @@ struct pso_pointer compose_body( struct pso_pointer frame_pointer ) {
struct pso_pointer struct pso_pointer
lisp_lambda( struct pso_pointer frame_pointer ) { lisp_lambda( struct pso_pointer frame_pointer ) {
struct pso4* frame = pointer_to_pso4(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, lisp_nlambda( struct pso_pointer frame_pointer,
struct pso_pointer env ) { struct pso_pointer env ) {
struct pso4* frame = pointer_to_pso4(frame_pointer); 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 ) );
} }
@ -557,7 +555,6 @@ struct pso_pointer make_fn_frame(struct pso_pointer previous,
return new_pointer; return new_pointer;
} }
/** /**
* @brief Create a new stack frame in which to evaluate the special form * @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`. * indicated by this `fn_pointer`, with unevaluated args from this `arg_list`.
@ -594,7 +591,6 @@ struct pso_pointer make_special_frame(struct pso_pointer previous,
return new_pointer; return new_pointer;
} }
/** /**
* Internal guts of apply. * Internal guts of apply.
* @param frame the stack frame, expected to have only one argument, a list * @param frame the stack frame, expected to have only one argument, a list
@ -736,7 +732,7 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) {
c_string_to_lisp_string( frame_pointer, buffer ); c_string_to_lisp_string( frame_pointer, buffer );
free( buffer ); free( buffer );
result = 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 ); message, frame_pointer );
} }
} }
@ -823,10 +819,6 @@ lisp_eval( struct pso_pointer frame_pointer ) {
return result; return result;
} }
/** /**
* Special form; * Special form;
* returns its argument (strictly first argument - only one is expected but * 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]; 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) * * (type expression)
* *
* @param frame my stack frame. * @return As a Lisp symbol, the tag of `expression`.
* @param frame_pointer a pointer to my pso4.
* @param env my environment (ignored).
* @return As a Lisp string, the tag of `expression`.
*/ */
struct pso_pointer struct pso_pointer
lisp_type( struct pso4 *frame, struct pso_pointer frame_pointer, lisp_type( struct pso_pointer frame_pointer ) {
struct pso_pointer env ) { return c_type( frame_pointer, fetch_arg( pointer_to_pso4( frame_pointer), 0) );
return c_type( frame->payload.stack_frame.arg[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, * Function. return the source code of the object which is its first argument,
* if it is an executable and has source code. * 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, * @return the source of the `object` indicated, if it is a function, a lambda,
* an nlambda, or a spcial form; else `nil`. * an nlambda, or a spcial form; else `nil`.
*/ */
struct pso_pointer lisp_source( struct pso4 *frame, struct pso_pointer lisp_source( struct pso_pointer frame_pointer) {
struct pso_pointer frame_pointer,
struct pso_pointer env ) {
struct pso_pointer result = nil; struct pso_pointer result = nil;
struct pso2 **cell = struct pso4* frame = pointer_to_pso4(frame_pointer);
pointer_to_object( frame->payload.stack_frame.arg[0] ); struct pso2 *cell =
struct pso_pointer source_key = c_string_to_lisp_keyword( L"source" ); pointer_to_object( fetch_arg( frame, 0) );
switch ( cell->header.tag.bytes.value & 0xfffff ) { struct pso_pointer source_key = c_string_to_lisp_keyword( frame_pointer, L"source" );
switch ( get_tag_value(fetch_arg( frame, 0)) ) {
case FUNCTIONTV: case FUNCTIONTV:
result = c_assoc( source_key, cell->payload.function.meta ); result = c_assoc( source_key, cell->payload.function.meta );
break; break;
@ -1028,130 +898,19 @@ struct pso_pointer lisp_source( struct pso4 *frame,
result = c_assoc( source_key, cell->payload.special.meta ); result = c_assoc( source_key, cell->payload.special.meta );
break; break;
case LAMBDATV: case LAMBDATV:
result = cons( c_string_to_lisp_symbol( L"lambda" ), result = make_cons( frame_pointer,
cons( cell->payload.lambda.args, c_string_to_lisp_symbol( frame_pointer, L"λ" ),
cell->payload.lambda.body ) ); make_cons( frame_pointer,
cell->payload.lambda.args,
cell->payload.lambda.body ) );
break; break;
case NLAMBDATV: case NLAMBDATV:
result = cons( c_string_to_lisp_symbol( L"nlambda" ), result = make_cons( frame_pointer, c_string_to_lisp_symbol( frame_pointer, L"nλ" ),
cons( cell->payload.lambda.args, make_cons( frame_pointer, cell->payload.lambda.args,
cell->payload.lambda.body ) ); cell->payload.lambda.body ) ) );
break; break;
} }
// \todo suffers from premature GC, and I can't see why! push_local( frame_pointer, result );
inc_ref( result );
return result;
}
/**
* A version of append which can conveniently be called from C.
*/
struct pso_pointer c_append( struct pso_pointer l1, struct pso_pointer l2 ) {
switch ( pointer_to_object( l1 ).header.tag.bytes.value & 0xfffff ) {
case CONSTV:
if ( pointer_to_object( l1 ).header.tag.bytes.value & 0xfffff ==
pointer_to_object( l2 ).header.tag.bytes.value & 0xfffff ) {
if ( c_nilp( c_cdr( l1 ) ) ) {
return cons( c_car( l1 ), l2 );
} else {
return cons( c_car( l1 ), c_append( c_cdr( l1 ), l2 ) );
}
} else {
throw_exception( c_string_to_lisp_symbol( L"append" ),
c_string_to_lisp_string
( L"Can't append: not same type" ), nil );
}
break;
case KEYTV:
case STRINGTV:
case SYMBOLTV:
if ( pointer_to_object( l1 ).header.tag.bytes.value & 0xfffff ==
pointer_to_object( l2 ).header.tag.bytes.value & 0xfffff ) {
if ( c_nilp( c_cdr( l1 ) ) ) {
return
make_string_like_thing( ( pointer_to_object
( l1 ).payload.string.
character ), l2,
pointer_to_object( l1 ).header.
tag.bytes.value & 0xfffff );
} else {
return
make_string_like_thing( ( pointer_to_object
( l1 ).payload.string.
character ),
c_append( c_cdr( l1 ), l2 ),
pointer_to_object( l1 ).header.
tag.bytes.value & 0xfffff );
}
} else {
throw_exception( c_string_to_lisp_symbol( L"append" ),
c_string_to_lisp_string
( L"Can't append: not same type" ), nil );
}
break;
default:
throw_exception( c_string_to_lisp_symbol( L"append" ),
c_string_to_lisp_string
( L"Can't append: not a sequence" ), nil );
break;
}
}
/**
* should really be overwritten with a version in Lisp, since this is much easier to write in Lisp
*/
struct pso_pointer lisp_append( struct pso4 *frame,
struct pso_pointer frame_pointer,
struct pso_pointer env ) {
struct pso_pointer result =
fetch_arg( frame, ( frame->payload.stack_frame.args - 1 ) );
for ( int a = frame->payload.stack_frame.args - 2; a >= 0; a-- ) {
result = c_append( fetch_arg( frame, a ), result );
}
return result;
}
struct pso_pointer lisp_mapcar( struct pso4 *frame,
struct pso_pointer frame_pointer,
struct pso_pointer env ) {
struct pso_pointer result = nil;
debug_print( L"Mapcar: ", DEBUG_EVAL, 0 );
debug_dump_object( frame_pointer, DEBUG_EVAL, 0 );
int i = 0;
for ( struct pso_pointer c = frame->payload.stack_frame.arg[1]; tp( c );
c = c_cdr( c ) ) {
struct pso_pointer expr =
cons( frame->payload.stack_frame.arg[0], cons( c_car( c ), nil ) );
debug_printf( DEBUG_EVAL, L"Mapcar %d, evaluating ", i );
debug_print_object( expr, DEBUG_EVAL, 0 );
debug_println( DEBUG_EVAL, 0 );
struct pso_pointer r = eval_form( frame, frame_pointer, expr, env );
if ( exceptionp( r ) ) {
result = r;
inc_ref( expr ); // to protect exception from the later dec_ref
break;
} else {
result = cons( r, result );
}
debug_printf( DEBUG_EVAL, L"Mapcar %d, result is ", i++ );
debug_print_object( result, DEBUG_EVAL, 0 );
debug_println( DEBUG_EVAL, 0 );
dec_ref( expr );
}
result = consp( result ) ? c_reverse( result ) : result;
debug_print( L"Mapcar returning: ", DEBUG_EVAL, 0 );
debug_print_object( result, DEBUG_EVAL, 0 );
debug_println( DEBUG_EVAL, 0 );
return result; return result;
} }
@ -1159,20 +918,18 @@ struct pso_pointer lisp_mapcar( struct pso4 *frame,
/** /**
* @brief construct and return a list of arbitrarily many arguments. * @brief construct and return a list of arbitrarily many arguments.
* *
* @param frame The stack frame. * (list args...)
* @param frame_pointer A pointer to the stack frame. *
* @param env The evaluation environment.
* @return struct pso_pointer a pointer to the result * @return struct pso_pointer a pointer to the result
*/ */
struct pso_pointer lisp_list( struct pso4 *frame, struct pso_pointer lisp_list( struct pso_pointer frame_pointer ) {
struct pso_pointer frame_pointer, struct pso4* frame = pointer_to_pso4( frame_pointer);
struct pso_pointer env ) {
struct pso_pointer result = frame->payload.stack_frame.more; struct pso_pointer result = frame->payload.stack_frame.more;
for ( int a = for ( int a =
c_nilp( result ) ? frame->payload.stack_frame.args - c_nilp( result ) ? frame->payload.stack_frame.args -
1 : args_in_frame - 1; a >= 0; a-- ) { 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; return result;
@ -1191,7 +948,7 @@ struct pso_pointer lisp_let( struct pso4 *frame,
struct pso_pointer bindings = env; struct pso_pointer bindings = env;
struct pso_pointer result = nil; 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 ) ) { tp( cursor ); cursor = c_cdr( cursor ) ) {
struct pso_pointer pair = c_car( cursor ); struct pso_pointer pair = c_car( cursor );
struct pso_pointer symbol = c_car( pair ); 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 ); 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 */ /* i.e., no exception yet */
for ( int form = 1; for ( int form = 1;
!exceptionp( result ) && form < frame->payload.stack_frame.args; !exceptionp( result ) && form < frame->payload.stack_frame.args;
@ -1225,12 +993,6 @@ struct pso_pointer lisp_let( struct pso4 *frame,
bindings ); 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; return result;
} }
@ -1246,7 +1008,7 @@ struct pso_pointer lisp_let( struct pso4 *frame,
struct pso_pointer lisp_and( struct pso4 *frame, struct pso_pointer lisp_and( struct pso4 *frame,
struct pso_pointer frame_pointer, struct pso_pointer frame_pointer,
struct pso_pointer env ) { struct pso_pointer env ) {
bool accumulator = t; bool accumulator = true;
struct pso_pointer result = frame->payload.stack_frame.more; struct pso_pointer result = frame->payload.stack_frame.more;
for ( int a = 0; accumulator == t && a < frame->payload.stack_frame.args; for ( int a = 0; accumulator == t && a < frame->payload.stack_frame.args;

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

@ -17,6 +17,7 @@
#include "memory/pso2.h" #include "memory/pso2.h"
#include "memory/pso4.h" #include "memory/pso4.h"
#include "memory/tags.h" #include "memory/tags.h"
#include "ops/inspect.h"
#include "ops/stack_ops.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 ) ); : get_default_stream( false, fetch_env( frame_pointer ) );
URL_FILE *output; URL_FILE *output;
if ( writep( out_stream ) ) { dump_object( frame_pointer, fetch_arg(frame,1), fetch_arg(frame, 0) );
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 ); 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 #ifndef psse_ops_inspect
#define 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 ); struct pso_pointer lisp_inspect( struct pso_pointer frame_pointer );
#endif #endif

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

@ -20,14 +20,15 @@
* @brief an implementation of `keys` convenient for calling from C * @brief an implementation of `keys` convenient for calling from C
* *
* @param */ * @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; struct pso_pointer result = nil;
if ( consp( store ) ) { if ( consp( store ) ) {
for ( struct pso_pointer pair = c_car( store ); !c_nilp( pair ); for ( struct pso_pointer pair = c_car( store ); !c_nilp( pair );
pair = c_car( store ) ) { pair = c_car( store ) ) {
if ( consp( pair ) ) { if ( consp( pair ) ) {
result = cons( c_car( pair ), result ); result = make_cons( frame_pointer, c_car( pair ), result );
// } else if ( hashtabp( pair ) ) { // } else if ( hashtabp( pair ) ) {
// result = c_append( hashmap_keys( pair ), result ); // 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) { 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/node.h"
#include "memory/pointer.h" #include "memory/pointer.h"
#include "memory/pso.h" #include "memory/pso.h"
#include "memory/pso4.h"
#include "memory/tags.h" #include "memory/tags.h"
#include "ops/reverse.h" #include "ops/reverse.h"
#include "ops/truth.h" #include "ops/truth.h"
#include "payloads/cons.h" #include "payloads/cons.h"
struct pso_pointer lisp_mapcar( struct pso4 *frame, struct pso_pointer lisp_mapcar( struct pso_pointer frame_pointer ) {
struct pso_pointer frame_pointer, struct pso_pointer result = nil;
struct pso_pointer env ) { struct pso4* frame = pointer_to_pso4(frame_pointer);
struct pso_pointer result = nil;
debug_print( U"Mapcar: ", DEBUG_EVAL, 0 ); debug_print( U"Mapcar: ", DEBUG_EVAL, 0 );
debug_dump_object( frame_pointer, DEBUG_EVAL, 0 ); debug_dump_object( frame_pointer, DEBUG_EVAL, 0 );
int i = 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_printf( DEBUG_EVAL, 0, U"Mapcar %d, evaluating ", i );
debug_print_object( expr, DEBUG_EVAL, 0 ); 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 ); 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)) { if (consp(frame->payload.stack_frame.more)) {
result = result = c_progn(frame, frame_pointer, frame->payload.stack_frame.more,
c_progn(frame, frame_pointer, frame->payload.stack_frame.more, env); fetch_env(frame_pointer));
} }
return result; return result;

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

@ -93,7 +93,7 @@ void repl( struct pso_pointer frame_pointer ) {
dec_ref( next ); dec_ref( next );
next = inc_ref( make_frame( 1, base_of_stack, read_value ) ); 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( next );
dec_ref( read_value ); dec_ref( read_value );

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

@ -12,20 +12,13 @@
#include <stdbool.h> #include <stdbool.h>
#include "memory/pointer.h" #include "memory/pointer.h"
#include "memory/pso2.h"
#include "memory/pso4.h" #include "memory/pso4.h"
#define CONS_SIZE_CLASS 2 #define CONS_SIZE_CLASS 2
/** /* NOTE THAT the definition of a cons payload has to be in memory/pso2.h to
* @brief A cons cell. * 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;
};
struct pso_pointer car( struct pso_pointer frame_pointer ); 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 { } else {
struct pso_pointer x_frame = inc_ref(make_frame( struct pso_pointer x_frame = inc_ref(make_frame(
2, frame_pointer, message, 2, frame_pointer, message,
(nilp(location) (c_nilp(location)
? nil ? nil
: make_cons(frame_pointer, : make_cons(frame_pointer,
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 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 #endif