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

My monster, it not only compiles, it now runs!

Browse source
This commit is contained in:
Simon Brooke 2026-03-30 11:52:41 +01:00
parent 60921be3d4
commit a8b4a6e69d
26 changed files with 244 additions and 172 deletions
Download patch file Download diff file Expand all files Collapse all files

5
Makefile
View file

@ -8,8 +8,9 @@ DEPS := $(OBJS:.o=.d)
TESTS := $(shell find unit-tests -name *.sh) TESTS := $(shell find unit-tests -name *.sh)
INC_DIRS := $(shell find $(SRC_DIRS) -type d) # INC_DIRS := $(shell find $(SRC_DIRS) -type d)
INC_FLAGS := $(addprefix -I,$(INC_DIRS)) # INC_FLAGS := $(addprefix -I,$(INC_DIRS))
INC_FLAGS := -I $(SRC_DIRS)
TMP_DIR ?= ./tmp TMP_DIR ?= ./tmp

2
src/c/debug.c
View file

@ -127,4 +127,4 @@ void debug_printf( int level, int indent, wchar_t *format, ... ) {
} }
// debug_dump_object, debug_print_binding, debug_print_exception, debug_print_object, // debug_dump_object, debug_print_binding, debug_print_exception, debug_print_object,
// not yet implemented but probably will be. // not yet implemented but probably will be.

8
src/c/environment/environment.c
View file

@ -23,14 +23,14 @@ bool environment_initialised = false;
* @param node theindex of the node we are initialising. * @param node theindex of the node we are initialising.
* @return struct pso_pointer t on success, else an exception. * @return struct pso_pointer t on success, else an exception.
*/ */
struct pso_pointer initialise_environment( uint32_t node) { struct pso_pointer initialise_environment( uint32_t node ) {
struct pso_pointer result = t; struct pso_pointer result = t;
if (environment_initialised) { if ( environment_initialised ) {
// TODO: throw an exception "Attempt to reinitialise environment" // TODO: throw an exception "Attempt to reinitialise environment"
} else { } else {
// TODO: actually initialise it. // TODO: actually initialise it.
} }
return result; return result;
} }

4
src/c/memory/memory.c
View file

@ -34,10 +34,10 @@ bool memory_initialised = false;
* @return int * @return int
*/ */
struct pso_pointer initialise_memory( uint32_t node ) { struct pso_pointer initialise_memory( uint32_t node ) {
if (memory_initialised) { if ( memory_initialised ) {
// TODO: throw an exception // TODO: throw an exception
} else { } else {
for (uint8_t i = 0; i <= MAX_SIZE_CLASS; i++) { for ( uint8_t i = 0; i <= MAX_SIZE_CLASS; i++ ) {
freelists[i] = nil; freelists[i] = nil;
} }
memory_initialised = true; memory_initialised = true;

4
src/c/memory/node.c
View file

@ -37,13 +37,13 @@ uint32_t node_index = 0;
* @brief The canonical `nil` pointer * @brief The canonical `nil` pointer
* *
*/ */
struct pso_pointer nil = (struct pso_pointer) { 0, 0, 0}; struct pso_pointer nil = ( struct pso_pointer ) { 0, 0, 0 };
/** /**
* @brief the canonical `t` (true) pointer. * @brief the canonical `t` (true) pointer.
* *
*/ */
struct pso_pointer t = (struct pso_pointer) { 0, 0, 1 }; struct pso_pointer t = ( struct pso_pointer ) { 0, 0, 1 };
/** /**

75
src/c/memory/page.c
View file

@ -38,7 +38,7 @@
* to hold the number of pages we *might* create at start up time. We need a * to hold the number of pages we *might* create at start up time. We need a
* way to grow the number of pages, while keeping access to them cheap. * way to grow the number of pages, while keeping access to them cheap.
*/ */
union page * pages[NPAGES]; union page *pages[NPAGES];
/** /**
* @brief the number of pages which have thus far been allocated. * @brief the number of pages which have thus far been allocated.
@ -55,25 +55,30 @@ uint32_t npages_allocated = 0;
* @param freelist the freelist for objects of this size class. * @param freelist the freelist for objects of this size class.
* @return struct pso_pointer the new head for the freelist for this size_class, * @return struct pso_pointer the new head for the freelist for this size_class,
*/ */
struct pso_pointer initialise_page( union page* page_addr, uint16_t page_index, struct pso_pointer initialise_page( union page *page_addr, uint16_t page_index,
uint8_t size_class, struct pso_pointer freelist) { uint8_t size_class,
struct pso_pointer freelist ) {
struct pso_pointer result = freelist; struct pso_pointer result = freelist;
int obj_size = pow(2, size_class); int obj_size = pow( 2, size_class );
int obj_bytes = obj_size * sizeof(uint64_t); int obj_bytes = obj_size * sizeof( uint64_t );
int objs_in_page = PAGE_BYTES/obj_bytes; int objs_in_page = PAGE_BYTES / obj_bytes;
// we do this backwards (i--) so that object {0, 0, 0} will be first on the // we do this backwards (i--) so that object {0, 0, 0} will be first on the
// freelist when the first page is initiated, so we can grab that one for // freelist when the first page is initiated, so we can grab that one for
// `nil` and the next on for `t`. // `nil` and the next on for `t`.
for (int i = objs_in_page - 1; i >= 0; i--) { for ( int i = objs_in_page - 1; i >= 0; i-- ) {
// it should be safe to cast any pso object to a pso2 // it should be safe to cast any pso object to a pso2
struct pso2* object = (struct pso2 *)(page_addr + (i * obj_bytes)); struct pso2 *object =
( struct pso2 * ) ( page_addr + ( i * obj_bytes ) );
object->header.tag.bytes.size_class = size_class; object->header.tag.bytes.size_class = size_class;
strncpy( &(object->header.tag.bytes.mnemonic[0]), FREETAG, TAGLENGTH); strncpy( &( object->header.tag.bytes.mnemonic[0] ), FREETAG,
TAGLENGTH );
object->payload.free.next = result; object->payload.free.next = result;
result = make_pointer( node_index, page_index, (uint16_t)( i * obj_size)); result =
make_pointer( node_index, page_index,
( uint16_t ) ( i * obj_size ) );
} }
return result; return result;
@ -89,56 +94,56 @@ struct pso_pointer initialise_page( union page* page_addr, uint16_t page_index,
struct pso_pointer allocate_page( uint8_t size_class ) { struct pso_pointer allocate_page( uint8_t size_class ) {
struct pso_pointer result = t; struct pso_pointer result = t;
if ( npages_allocated == 0) { if ( npages_allocated == 0 ) {
for (int i = 0; i < NPAGES; i++) { for ( int i = 0; i < NPAGES; i++ ) {
pages[i] = NULL; pages[i] = NULL;
} }
debug_print( L"Pages array zeroed.\n", DEBUG_ALLOC, 0); debug_print( L"Pages array zeroed.\n", DEBUG_ALLOC, 0 );
} }
if ( npages_allocated < NPAGES) { if ( npages_allocated < NPAGES ) {
if ( size_class >= 2 && size_class <= MAX_SIZE_CLASS ) { if ( size_class >= 2 && size_class <= MAX_SIZE_CLASS ) {
void* pg = malloc( sizeof( union page ) ); void *pg = malloc( sizeof( union page ) );
if ( pg != NULL ) { if ( pg != NULL ) {
memset( pg, 0, sizeof( union page ) ); memset( pg, 0, sizeof( union page ) );
pages[ npages_allocated] = pg; pages[npages_allocated] = pg;
debug_printf( DEBUG_ALLOC, 0, debug_printf( DEBUG_ALLOC, 0,
L"Allocated page %d for objects of size class %x.\n", L"Allocated page %d for objects of size class %x.\n",
npages_allocated, size_class); npages_allocated, size_class );
freelists[size_class] = freelists[size_class] =
initialise_page( (union page*)pg, npages_allocated, size_class, freelists[size_class] ); initialise_page( ( union page * ) pg, npages_allocated,
size_class, freelists[size_class] );
debug_printf( DEBUG_ALLOC, 0, debug_printf( DEBUG_ALLOC, 0,
L"Initialised page %d; freelist for size class %x updated.\n", L"Initialised page %d; freelist for size class %x updated.\n",
npages_allocated, npages_allocated, size_class );
size_class);
npages_allocated ++; npages_allocated++;
} else { } else {
// TODO: exception when we have one. // TODO: exception when we have one.
result = nil; result = nil;
fwide( stderr, 1 ); fwide( stderr, 1 );
fwprintf( stderr, fwprintf( stderr,
L"\nCannot allocate page: heap exhausted,\n", L"\nCannot allocate page: heap exhausted,\n",
size_class, MAX_SIZE_CLASS ); size_class, MAX_SIZE_CLASS );
} }
} else { } else {
// TODO: exception when we have one. // TODO: exception when we have one.
result = nil; result = nil;
fwide( stderr, 1 ); fwide( stderr, 1 );
fwprintf( stderr, fwprintf( stderr,
L"\nCannot allocate page for size class %x, min is 2 max is %x.\n", L"\nCannot allocate page for size class %x, min is 2 max is %x.\n",
size_class, MAX_SIZE_CLASS ); size_class, MAX_SIZE_CLASS );
} }
} else { } else {
// TODO: exception when we have one. // TODO: exception when we have one.
result = nil; result = nil;
fwide( stderr, 1 ); fwide( stderr, 1 );
fwprintf( stderr, fwprintf( stderr,
L"\nCannot allocate page: page space exhausted.\n", L"\nCannot allocate page: page space exhausted.\n",
size_class, MAX_SIZE_CLASS ); size_class, MAX_SIZE_CLASS );
} }
return result; return result;

16
src/c/memory/pointer.c
View file

@ -22,8 +22,9 @@
* @param offset The offset, in words, within that page, of the object. * @param offset The offset, in words, within that page, of the object.
* @return struct pso_pointer a pointer referencing the specified object. * @return struct pso_pointer a pointer referencing the specified object.
*/ */
struct pso_pointer make_pointer( uint32_t node, uint16_t page, uint16_t offset) { struct pso_pointer make_pointer( uint32_t node, uint16_t page,
return (struct pso_pointer){ node, page, offset}; uint16_t offset ) {
return ( struct pso_pointer ) { node, page, offset };
} }
/** /**
@ -36,16 +37,15 @@ struct pso_pointer make_pointer( uint32_t node, uint16_t page, uint16_t offset)
* @param pointer a pso_pointer which references an object. * @param pointer a pso_pointer which references an object.
* @return struct pso2* the actual address in memory of that object. * @return struct pso2* the actual address in memory of that object.
*/ */
struct pso2* pointer_to_object( struct pso_pointer pointer) { struct pso2 *pointer_to_object( struct pso_pointer pointer ) {
struct pso2* result = NULL; struct pso2 *result = NULL;
if ( pointer.node == node_index) { if ( pointer.node == node_index ) {
union page* pg = pages[pointer.page]; union page *pg = pages[pointer.page];
result = (struct pso2*) &pg->words[pointer.offset]; result = ( struct pso2 * ) &pg->words[pointer.offset];
} }
// TODO: else if we have a copy of the object in cache, return that; // TODO: else if we have a copy of the object in cache, return that;
// else request a copy of the object from the node which curates it. // else request a copy of the object from the node which curates it.
return result; return result;
} }

85
src/c/memory/pso.c
View file

@ -33,58 +33,61 @@
* @param size_class The size class for the object to be allocated; * @param size_class The size class for the object to be allocated;
* @return struct pso_pointer a pointer to the newly allocated object * @return struct pso_pointer a pointer to the newly allocated object
*/ */
struct pso_pointer allocate( char* tag, uint8_t size_class) { struct pso_pointer allocate( char *tag, uint8_t size_class ) {
struct pso_pointer result = nil; struct pso_pointer result = nil;
if (size_class <= MAX_SIZE_CLASS) { if ( size_class <= MAX_SIZE_CLASS ) {
if (nilp( freelists[size_class])) { if ( nilp( freelists[size_class] ) ) {
result = allocate_page(size_class); result = allocate_page( size_class );
} }
if ( !exceptionp( result) && not( freelists[size_class] ) ) { if ( !exceptionp( result ) && not( freelists[size_class] ) ) {
result = freelists[size_class]; result = freelists[size_class];
struct pso2* object = pointer_to_object( result); struct pso2 *object = pointer_to_object( result );
freelists[size_class] = object->payload.free.next; freelists[size_class] = object->payload.free.next;
strncpy( (char *)(object->header.tag.bytes.mnemonic), tag, TAGLENGTH); strncpy( ( char * ) ( object->header.tag.bytes.mnemonic ), tag,
TAGLENGTH );
/* the object ought already to have the right size class in its tag /* the object ought already to have the right size class in its tag
* because it was popped off the freelist for that size class. */ * because it was popped off the freelist for that size class. */
if ( object->header.tag.bytes.size_class != size_class) { if ( object->header.tag.bytes.size_class != size_class ) {
// TODO: return an exception instead? Or warn, set it, and continue? // TODO: return an exception instead? Or warn, set it, and continue?
} }
/* the objext ought to have a reference count ot zero, because it's /* the objext ought to have a reference count ot zero, because it's
* on the freelist, but again we should sanity check. */ * on the freelist, but again we should sanity check. */
if ( object->header.count != 0) { if ( object->header.count != 0 ) {
// TODO: return an exception instead? Or warn, set it, and continue? // TODO: return an exception instead? Or warn, set it, and continue?
} }
} }
} // TODO: else throw exception } // TODO: else throw exception
return result; return result;
} }
uint32_t payload_size( struct pso2* object) { uint32_t payload_size( struct pso2 *object ) {
// TODO: Unit tests DEFINITELY needed! // TODO: Unit tests DEFINITELY needed!
return ((1 << object->header.tag.bytes.size_class) - sizeof( struct pso_header)); return ( ( 1 << object->header.tag.bytes.size_class ) -
sizeof( struct pso_header ) );
} }
void free_cell( struct pso_pointer p) { void free_cell( struct pso_pointer p ) {
struct pso2* p2 = pointer_to_object( p); struct pso2 *p2 = pointer_to_object( p );
uint32_t array_size = payload_size(p2); uint32_t array_size = payload_size( p2 );
uint8_t size_class = p2->header.tag.bytes.size_class; uint8_t size_class = p2->header.tag.bytes.size_class;
strncpy( (char *)(p2->header.tag.bytes.mnemonic), FREETAG, TAGLENGTH); strncpy( ( char * ) ( p2->header.tag.bytes.mnemonic ), FREETAG,
TAGLENGTH );
/* will C just let me cheerfully walk off the end of the array I've declared? */ /* will C just let me cheerfully walk off the end of the array I've declared? */
for (int i = 0; i < array_size; i++) { for ( int i = 0; i < array_size; i++ ) {
p2->payload.words[i] = 0; p2->payload.words[i] = 0;
} }
/* TODO: obtain mutex on freelist */ /* TODO: obtain mutex on freelist */
p2->payload.free.next = freelists[size_class]; p2->payload.free.next = freelists[size_class];
freelists[size_class] = p; freelists[size_class] = p;
} }
/** /**
@ -103,12 +106,13 @@ struct pso_pointer inc_ref( struct pso_pointer pointer ) {
#ifdef DEBUG #ifdef DEBUG
debug_printf( DEBUG_ALLOC, 0, debug_printf( DEBUG_ALLOC, 0,
L"\nIncremented object of type %3.3s at page %u, offset %u to count %u", L"\nIncremented object of type %3.3s at page %u, offset %u to count %u",
( ( char * ) &object->header.tag.bytes.mnemonic[0] ), pointer.page, ( ( char * ) &object->header.tag.bytes.mnemonic[0] ),
pointer.offset, object->header.count ); pointer.page, pointer.offset, object->header.count );
if ( vectorpointp( pointer) ) { if ( vectorpointp( pointer ) ) {
debug_printf( DEBUG_ALLOC, 0, debug_printf( DEBUG_ALLOC, 0,
L"; pointer to vector object of type %3.3s.\n", L"; pointer to vector object of type %3.3s.\n",
( ( char * ) &( object->payload.vectorp.tag.bytes[0] ) ) ); ( ( char * )
&( object->payload.vectorp.tag.bytes[0] ) ) );
} else { } else {
debug_println( DEBUG_ALLOC ); debug_println( DEBUG_ALLOC );
} }
@ -134,12 +138,13 @@ struct pso_pointer dec_ref( struct pso_pointer pointer ) {
#ifdef DEBUG #ifdef DEBUG
debug_printf( DEBUG_ALLOC, 0, debug_printf( DEBUG_ALLOC, 0,
L"\nDecremented object of type %4.4s at page %d, offset %d to count %d", L"\nDecremented object of type %4.4s at page %d, offset %d to count %d",
( ( char * ) (object->header.tag.bytes.mnemonic )), pointer.page, ( ( char * ) ( object->header.tag.bytes.mnemonic ) ),
pointer.offset, object->header.count ); pointer.page, pointer.offset, object->header.count );
if ( vectorpointp( pointer)) { if ( vectorpointp( pointer ) ) {
debug_printf( DEBUG_ALLOC, 0, debug_printf( DEBUG_ALLOC, 0,
L"; pointer to vector object of type %3.3s.\n", L"; pointer to vector object of type %3.3s.\n",
( ( char * ) &( object->payload.vectorp.tag.bytes ) ) ); ( ( char * )
&( object->payload.vectorp.tag.bytes ) ) );
} else { } else {
debug_println( DEBUG_ALLOC ); debug_println( DEBUG_ALLOC );
} }
@ -159,8 +164,8 @@ struct pso_pointer dec_ref( struct pso_pointer pointer ) {
* *
* @param pointer pointer to an object to lock. * @param pointer pointer to an object to lock.
*/ */
void lock_object( struct pso_pointer pointer) { void lock_object( struct pso_pointer pointer ) {
struct pso2* object = pointer_to_object( pointer ); struct pso2 *object = pointer_to_object( pointer );
object->header.count = MAXREFERENCE; object->header.count = MAXREFERENCE;
} }
@ -173,12 +178,12 @@ void lock_object( struct pso_pointer pointer) {
* @param pointer a pointer to an object. * @param pointer a pointer to an object.
* @return the tag value of the object indicated. * @return the tag value of the object indicated.
*/ */
uint32_t get_tag_value( struct pso_pointer pointer) { uint32_t get_tag_value( struct pso_pointer pointer ) {
struct pso2* object = pointer_to_object( pointer); struct pso2 *object = pointer_to_object( pointer );
uint32_t result = (object->header.tag.value & 0xffffff); uint32_t result = ( object->header.tag.value & 0xffffff );
if (vectorpointp( pointer)) { if ( vectorpointp( pointer ) ) {
result = (object->payload.vectorp.tag.value & 0xffffff); result = ( object->payload.vectorp.tag.value & 0xffffff );
} }
return result; return result;

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

@ -13,6 +13,7 @@
#include "memory/node.h" #include "memory/node.h"
#include "memory/pointer.h" #include "memory/pointer.h"
#include "payloads/stack.h" #include "payloads/stack.h"
#include "ops/stack_ops.h"
#include "ops/truth.h" #include "ops/truth.h"
/** /**
@ -48,9 +49,12 @@ struct pso_pointer lisp_eq( struct pso4 *frame,
struct pso_pointer env ) { struct pso_pointer env ) {
struct pso_pointer result = t; struct pso_pointer result = t;
if ( frame->args > 1 ) { if ( frame->payload.stack_frame.args > 1 ) {
for ( int b = 1; ( truep( result ) ) && ( b < frame->args ); b++ ) { for ( int b = 1;
result = eq( fetch_arg(frame, 0), fetch_arg( frame, b ) ) ? t : nil; ( truep( result ) ) && ( b < frame->payload.stack_frame.args );
b++ ) {
result =
eq( fetch_arg( frame, 0 ), fetch_arg( frame, b ) ) ? t : nil;
} }
} }

15
src/c/ops/repl.h
View file

@ -0,0 +1,15 @@
/**
* ops/repl.h
*
* The read/eval/print loop.
*
* (c) 2026 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __psse_ops_repl_h
#define __psse_ops_repl_h
// struct pso_pointer repl( struct pso_pointer prompt, struct pso_pointer readtable);
#endif

4
src/c/payloads/stack.c → src/c/ops/stack_ops.c
View file

@ -32,10 +32,10 @@ struct pso_pointer fetch_arg( struct pso4 *frame, unsigned int index ) {
struct pso_pointer p = frame->payload.stack_frame.more; struct pso_pointer p = frame->payload.stack_frame.more;
for ( int i = args_in_frame; i < index; i++ ) { for ( int i = args_in_frame; i < index; i++ ) {
p = pointer_to_object( p)->payload.cons.cdr; p = pointer_to_object( p )->payload.cons.cdr;
} }
result = pointer_to_object( p)->payload.cons.car; result = pointer_to_object( p )->payload.cons.car;
} }
return result; return result;

30
src/c/ops/stack_ops.h Normal file
View file

@ -0,0 +1,30 @@
/**
* ops/stack_ops.h
*
* Operations on a Lisp stack frame.
*
* (c) 2026 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __psse_ops_stack_ops_h
#define __psse_ops_stack_ops_h
#include "memory/pointer.h"
#include "memory/pso4.h"
/*
* number of arguments stored in a stack frame
*/
#define args_in_frame 8
/**
* @brief The maximum depth of stack before we throw an exception.
*
* `0` is interpeted as `unlimited`.
*/
extern uint32_t stack_limit;
struct pso_pointer fetch_arg( struct pso4 *frame, unsigned int index );
#endif

42
src/c/ops/truth.c
View file

@ -9,6 +9,12 @@
* 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.
*/ */
#include <stdbool.h>
#include "memory/node.h"
#include "memory/pointer.h"
#include "ops/stack_ops.h"
/** /**
* @brief true if `p` points to `nil`, else false. * @brief true if `p` points to `nil`, else false.
* *
@ -20,8 +26,8 @@
* @return true if `p` points to `nil`. * @return true if `p` points to `nil`.
* @return false otherwise. * @return false otherwise.
*/ */
bool nilp( struct pso_pointer p) { bool nilp( struct pso_pointer p ) {
return (p.page == 0 && p.offset = 0); return ( p.page == 0 && p.offset == 0 );
} }
/** /**
@ -31,8 +37,8 @@ bool nilp( struct pso_pointer p) {
* @return true if `p` points to `nil`; * @return true if `p` points to `nil`;
* @return false otherwise. * @return false otherwise.
*/ */
bool not( struct pso_pointer p) { bool not( struct pso_pointer p ) {
return !nilp( p); return !nilp( p );
} }
/** /**
@ -46,8 +52,8 @@ bool not( struct pso_pointer p) {
* @return true if `p` points to `t`. * @return true if `p` points to `t`.
* @return false otherwise. * @return false otherwise.
*/ */
bool truep( struct pso_pointer p) { bool truep( struct pso_pointer p ) {
return (p.page == 0 && p.offset = 1); return ( p.page == 0 && p.offset == 1 );
} }
/** /**
@ -58,10 +64,10 @@ bool truep( struct pso_pointer p) {
* @param env the evaluation environment. * @param env the evaluation environment.
* @return `t` if the first argument in this frame is `nil`, else `t` * @return `t` if the first argument in this frame is `nil`, else `t`
*/ */
pso_pointer lisp_nilp( struct pso4 *frame, struct pso_pointer lisp_nilp( struct pso4 *frame,
struct pso_pointer frame_pointer, struct pso_pointer frame_pointer,
struct pso_pointer env ){ struct pso_pointer env ) {
return (nilp(frame->payload.stack_frame.arg[0]) ? t : nil); return ( nilp( fetch_arg( frame, 0 )) ? t : nil );
} }
/** /**
@ -72,10 +78,10 @@ pso_pointer lisp_nilp( struct pso4 *frame,
* @param env the evaluation environment. * @param env the evaluation environment.
* @return `t` if the first argument in this frame is `t`, else `nil`. * @return `t` if the first argument in this frame is `t`, else `nil`.
*/ */
pso_pointer lisp_truep( struct pso4 *frame, struct pso_pointer lisp_truep( struct pso4 *frame,
struct pso_pointer frame_pointer, struct pso_pointer frame_pointer,
struct pso_pointer env ){ struct pso_pointer env ) {
return (truep(frame->payload.stack_frame.arg[0]) ? t : nil); return ( truep( fetch_arg( frame, 0 ) ) ? t : nil );
} }
/** /**
@ -87,8 +93,8 @@ pso_pointer lisp_truep( struct pso4 *frame,
* @param env the evaluation environment. * @param env the evaluation environment.
* @return `t` if the first argument in this frame is not `nil`, else `t`. * @return `t` if the first argument in this frame is not `nil`, else `t`.
*/ */
pso_pointer lisp_not( struct pso4 *frame, struct pso_pointer lisp_not( struct pso4 *frame,
struct pso_pointer frame_pointer, struct pso_pointer frame_pointer,
struct pso_pointer env ){ struct pso_pointer env ) {
return (not(frame->payload.stack_frame.arg[0]) ? t : nil); return ( not( fetch_arg( frame, 0 ) ) ? t : nil );
} }

4
src/c/ops/truth.h
View file

@ -11,6 +11,10 @@
#ifndef __psse_ops_truth_h #ifndef __psse_ops_truth_h
#define __psse_ops_truth_h #define __psse_ops_truth_h
#include <stdbool.h>
#include "memory/pointer.h"
#include "memory/pso4.h"
bool nilp( struct pso_pointer p ); bool nilp( struct pso_pointer p );

20
src/c/payloads/cons.c
View file

@ -23,15 +23,15 @@
* @param cdr the pointer which should form the cdr of this cons cell. * @param cdr the pointer which should form the cdr of this cons cell.
* @return struct pso_pointer a pointer to the newly allocated cons cell. * @return struct pso_pointer a pointer to the newly allocated cons cell.
*/ */
struct pso_pointer cons( struct pso_pointer car, struct pso_pointer cdr) { struct pso_pointer cons( struct pso_pointer car, struct pso_pointer cdr ) {
struct pso_pointer result = allocate( CONSTAG, 2); struct pso_pointer result = allocate( CONSTAG, 2 );
struct pso2 *object = pointer_to_object( result ); struct pso2 *object = pointer_to_object( result );
object->payload.cons.car = car; object->payload.cons.car = car;
object->payload.cons.cdr = cdr; object->payload.cons.cdr = cdr;
inc_ref( car); inc_ref( car );
inc_ref( cdr); inc_ref( cdr );
return result; return result;
} }
@ -43,7 +43,7 @@ struct pso_pointer cons( struct pso_pointer car, struct pso_pointer cdr) {
* @return true if `ptr` indicates a cons cell. * @return true if `ptr` indicates a cons cell.
* @return false otherwise * @return false otherwise
*/ */
bool consp( struct pso_pointer ptr) { bool consp( struct pso_pointer ptr ) {
// TODO: make it actually work! // TODO: make it actually work!
return false; return false;
} }
@ -55,11 +55,11 @@ bool consp( struct pso_pointer ptr) {
* @return the car of the indicated cell. * @return the car of the indicated cell.
* @exception if the pointer does not indicate a cons cell. * @exception if the pointer does not indicate a cons cell.
*/ */
struct pso_pointer car( struct pso_pointer cons) { struct pso_pointer car( struct pso_pointer cons ) {
struct pso_pointer result = nil; struct pso_pointer result = nil;
struct pso2 *object = pointer_to_object( result ); struct pso2 *object = pointer_to_object( result );
if ( consp( cons)) { if ( consp( cons ) ) {
result = object->payload.cons.car; result = object->payload.cons.car;
} }
// TODO: else throw an exception // TODO: else throw an exception
@ -74,14 +74,14 @@ struct pso_pointer car( struct pso_pointer cons) {
* @return the cdr of the indicated cell. * @return the cdr of the indicated cell.
* @exception if the pointer does not indicate a cons cell. * @exception if the pointer does not indicate a cons cell.
*/ */
struct pso_pointer cdr( struct pso_pointer cons) { struct pso_pointer cdr( struct pso_pointer cons ) {
struct pso_pointer result = nil; struct pso_pointer result = nil;
struct pso2 *object = pointer_to_object( result ); struct pso2 *object = pointer_to_object( result );
if ( consp( cons)) { if ( consp( cons ) ) {
result = object->payload.cons.cdr; result = object->payload.cons.cdr;
} }
// TODO: else throw an exception // TODO: else throw an exception
return result; return result;
} }

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

@ -30,12 +30,12 @@ struct cons_payload {
struct pso_pointer cdr; struct pso_pointer cdr;
}; };
struct pso_pointer car( struct pso_pointer cons); struct pso_pointer car( struct pso_pointer cons );
struct pso_pointer cdr( struct pso_pointer cons); struct pso_pointer cdr( struct pso_pointer cons );
struct pso_pointer cons( struct pso_pointer car, struct pso_pointer cdr); struct pso_pointer cons( struct pso_pointer car, struct pso_pointer cdr );
bool consp( struct pso_pointer ptr); bool consp( struct pso_pointer ptr );
#endif #endif

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

@ -1,13 +1,21 @@
/**
* payloads/exception.c
*
* An exception; required three pointers, so use object of size class 3.
*
* (c) 2026 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#import "memory/pointer.h" #include "memory/pointer.h"
#import "memory/pso.h" #include "memory/pso.h"
#import "payloads/exception.h" #include "payloads/exception.h"
/** /**
* @param p a pointer to an object. * @param p a pointer to an object.
* @return true if that object is an exception, else false. * @return true if that object is an exception, else false.
*/ */
bool exceptionp( struct pso_pointer p) { bool exceptionp( struct pso_pointer p ) {
return (get_tag_value( p) == EXCEPTIONTV); return ( get_tag_value( p ) == EXCEPTIONTV );
} }

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

@ -28,6 +28,6 @@ struct exception_payload {
struct pso_pointer cause; struct pso_pointer cause;
}; };
bool exceptionp( struct pso_pointer p); bool exceptionp( struct pso_pointer p );
#endif #endif

6
src/c/payloads/function.h
View file

@ -41,9 +41,9 @@ struct function_payload {
* a cons pointer (representing its result). * a cons pointer (representing its result).
* \todo check this documentation is current! * \todo check this documentation is current!
*/ */
struct pso_pointer ( *executable ) ( struct pso4*, struct pso_pointer ( *executable ) ( struct pso4 *,
struct pso_pointer, struct pso_pointer,
struct pso_pointer ); struct pso_pointer );
}; };
#endif #endif

10
src/c/payloads/hashtable.h
View file

@ -45,11 +45,11 @@
* i.e. either an assoc list or a further hashtable. * i.e. either an assoc list or a further hashtable.
*/ */
struct hashtable_payload { struct hashtable_payload {
struct pso_pointer hash_fn; /* function for hashing values in this hashtable, or `NIL` to use struct pso_pointer hash_fn; /* function for hashing values in this hashtable, or `NIL` to use
the default hashing function */ the default hashing function */
uint32_t n_buckets; /* number of hash buckets */ uint32_t n_buckets; /* number of hash buckets */
struct pso_pointer buckets[]; /* actual hash buckets, which should be `NIL` struct pso_pointer buckets[]; /* actual hash buckets, which should be `NIL`
* or assoc lists or (possibly) further hashtables. */ * or assoc lists or (possibly) further hashtables. */
}; };
#endif #endif

8
src/c/payloads/mutex.h
View file

@ -32,7 +32,7 @@ struct mutex_payload {
pthread_mutex_t mutex; pthread_mutex_t mutex;
}; };
struct pso_pointer make_mutex(); struct pso_pointer make_mutex( );
/** /**
* @brief evaluates these forms within the context of a thread-safe lock. * @brief evaluates these forms within the context of a thread-safe lock.
@ -50,7 +50,8 @@ struct pso_pointer make_mutex();
* @param forms a list of arbitrary Lisp forms. * @param forms a list of arbitrary Lisp forms.
* @return struct pso_pointer the result. * @return struct pso_pointer the result.
*/ */
struct pso_pointer with_lock( struct pso_pointer lock, struct pso_pointer forms); struct pso_pointer with_lock( struct pso_pointer lock,
struct pso_pointer forms );
/** /**
* @brief as with_lock, q.v. but attempts to obtain a lock and returns an * @brief as with_lock, q.v. but attempts to obtain a lock and returns an
@ -64,6 +65,7 @@ struct pso_pointer with_lock( struct pso_pointer lock, struct pso_pointer forms)
* @param forms a list of arbitrary Lisp forms. * @param forms a list of arbitrary Lisp forms.
* @return struct pso_pointer the result. * @return struct pso_pointer the result.
*/ */
struct pso_pointer attempt_with_lock( struct pso_pointer lock, struct pso_pointer forms); struct pso_pointer attempt_with_lock( struct pso_pointer lock,
struct pso_pointer forms );
#endif #endif

22
src/c/payloads/namespace.h
View file

@ -48,17 +48,17 @@
* i.e. either an assoc list or a further namespace. * i.e. either an assoc list or a further namespace.
*/ */
struct namespace_payload { struct namespace_payload {
struct pso_pointer hash_fn; /* function for hashing values in this namespace, or struct pso_pointer hash_fn; /* function for hashing values in this namespace, or
* `NIL` to use the default hashing function */ * `NIL` to use the default hashing function */
uint32_t n_buckets; /* number of hash buckets */ uint32_t n_buckets; /* number of hash buckets */
uint32_t unused; /* for word alignment and possible later expansion */ uint32_t unused; /* for word alignment and possible later expansion */
struct pso_pointer write_acl; /* it seems to me that it is likely that the struct pso_pointer write_acl; /* it seems to me that it is likely that the
* principal difference between a hashtable and a * principal difference between a hashtable and a
* namespace is that a hashtable has a write ACL * namespace is that a hashtable has a write ACL
* of `NIL`, meaning not writeable by anyone */ * of `NIL`, meaning not writeable by anyone */
struct pso_pointer mutex; /* the mutex to lock when modifying this namespace.*/ struct pso_pointer mutex; /* the mutex to lock when modifying this namespace. */
struct pso_pointer buckets[]; /* actual hash buckets, which should be `NIL` struct pso_pointer buckets[]; /* actual hash buckets, which should be `NIL`
* or assoc lists or (possibly) further hashtables. */ * or assoc lists or (possibly) further hashtables. */
}; };
#endif #endif

11
src/c/payloads/stack.h
View file

@ -13,7 +13,7 @@
#define __psse_payloads_stack_h #define __psse_payloads_stack_h
#include "memory/pointer.h" #include "memory/pointer.h"
#include "memory/pso4.h" // #include "memory/pso4.h"
#define STACKTAG "STK" #define STACKTAG "STK"
#define STACKTV 4936787 #define STACKTV 4936787
@ -23,13 +23,6 @@
*/ */
#define args_in_frame 8 #define args_in_frame 8
/**
* @brief The maximum depth of stack before we throw an exception.
*
* `0` is interpeted as `unlimited`.
*/
extern uint32_t stack_limit;
/** /**
* A stack frame. * A stack frame.
*/ */
@ -48,6 +41,4 @@ struct stack_frame_payload {
uint32_t depth; uint32_t depth;
}; };
struct pso_pointer fetch_arg( struct pso4 *frame, unsigned int index );
#endif #endif

4
src/c/payloads/vector_pointer.c
View file

@ -13,6 +13,6 @@
#include "memory/pso.h" #include "memory/pso.h"
#include "payloads/vector_pointer.h" #include "payloads/vector_pointer.h"
bool vectorpointp( struct pso_pointer p) { bool vectorpointp( struct pso_pointer p ) {
return (get_tag_value( p) == VECTORPOINTTV); return ( get_tag_value( p ) == VECTORPOINTTV );
} }

2
src/c/payloads/vector_pointer.h
View file

@ -39,6 +39,6 @@ struct vectorp_payload {
void *address; void *address;
}; };
bool vectorpointp( struct pso_pointer p); bool vectorpointp( struct pso_pointer p );
#endif #endif

1
src/c/psse.c
View file

@ -14,6 +14,7 @@
#include "psse.h" #include "psse.h"
#include "memory/node.h" #include "memory/node.h"
#include "ops/stack_ops.h"
void print_banner( ) { void print_banner( ) {
fwprintf( stdout, L"Post-Scarcity Software Environment version %s\n\n", fwprintf( stdout, L"Post-Scarcity Software Environment version %s\n\n",