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

Initialisation almost succeeds. nil and t are successfully instantiated.

Browse source 
We then go into a mess of exceptions which trigger exceptions until we run out
of allocatable memory, but all those exceptions and stack frames are correctly
allocated and torn down again afterwards, so.... sort of good?
This commit is contained in:
Simon Brooke 2026-04-16 11:39:01 +01:00
commit ba985474f6
31 changed files with 869 additions and 199 deletions
Download patch file Download diff file Expand all files Collapse all files

2
docs/Compiler.md
View file

@ -67,7 +67,7 @@ That's the list of things I've found so far that look useful to me. If I find ot
### Tag location
Objects in Lisp have to know that they are. This is what makes it possible to compute with an 'untyped' language: the type is not encoded in the program but in the data. In most conventional Lisp systems, things are typed by having a tag. Back in the day, when we had hardware specially built to run Lisp, Lisp specific hardware often had a word size — and thus registers, and a data bus — wider than the address bus, wider by the number of bits in the tag, and stored the tag on the pointer.
Objects in Lisp have to know what they are. This is what makes it possible to compute with an 'untyped' language: the type is not encoded in the program but in the data. In most conventional Lisp systems, things are typed by having a tag. Back in the day, when we had hardware specially built to run Lisp, Lisp specific hardware often had a word size — and thus registers, and a data bus — wider than the address bus, wider by the number of bits in the tag, and stored the tag on the pointer.
Modern Lisps still, I think, mostly store the tag on the pointer, but they run on commodity hardware which doesn't have those extra bits in the word size. That means that the size of an integer, or the precision of a real, that you can store in one word of memory is much less. It also means either that they can address much less memory than other programming languages on the same hardware, because for every bit you steal out of the address bus you halve the amount of memory you can address; or else that they bit shift up every address before they fetch it.

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

@ -1,5 +1,81 @@
# State of Play
## 20260415
OK, I have been diverted down a side-project on a side-project. I decided
that since Post Scarcity definitely needs a compiler, I should learn to write
a compiler, and so I should start by writing one for a simpler Lisp than Post
Scarcity. So I started to write
[one in Guile Scheme for Beowulf](https://git.journeyman.cc/simon/naegling).
This is started but a long way from finished. I'm also not very enamoured of
Guile Scheme, and am starting to wonder whether in fact I should be writing
if in [Beowulf](https://git.journeyman.cc/simon/beowulf) for Beowulf.
I do believe I can complete the Naegling/Beowulf compiler, and that having
written it, I can write a Post Scarcity compiler in Post Scarcity. But to do
that I still need to have to have at least all of
* apply
* assoc
* bind! (or put! or set!, but I *think* I prefer `bind!`)
* car
* cdr
* cons
* cond
* eq?
* equal?
* eval
* λ
* nil
* print
* read
* t
and, essentially, have all the parts of a working REPL.
My brain is not working very well at present; I can't do more than a very few
hours of focussed work a day, and jumping between Naegling and Post Scarcity
is probably not a good plan; but in periods when I need to do thinking about
where I'm going with Naegling I may switch to Post Scarcity (and vice versa).
### Standard signature for compiled functions
While I'm on this, I'm wondering whether I've got the standard signature for
compiled functions right. What we've inherited from the `0.0.X` branch is
documented as:
```c
/**
* pointer to a function which takes a cons pointer (representing
* its argument list) and a cons pointer (representing its environment) and a
* stack frame (representing the previous stack frame) as arguments and returns
* a cons pointer (representing its result).
* \todo check this documentation is current!
*/
struct cons_pointer ( *executable ) ( struct stack_frame *,
struct cons_pointer,
struct cons_pointer );
```
But actually the documentation here is wrong, because what we actually pass
is a C pointer to a stack frame object (which in `0.0.X` is in vector space),
a cons pointer to the cons space object which is the vector pointer to that
stack frame, and a cons pointer to the environment.
We definitely don't need to pass a pointer to the argument list (and in fact
we didn't before, the documentation is *wrong*); we also don't need to pass
both a C pointer and a cons pointer to the frame, since the frame is now in
paged space, so passing our managed pointer is enough.
It *might be* that passing both an unmanaged and a managed pointer is worth
doing, since recovering the managed pointer from the unmanaged pointer is
very expensive, and while recovering the unmanaged pointer from the
managed pointer is cheap, it isn't free.
But it's worth thinking about.
## 20260331
Substrate layer `print` is written; all the building blocks for substrate

1
src/c/debug.c
View file

@ -123,7 +123,6 @@ void debug_printf( int level, int indent, wchar_t *format, ... ) {
#ifdef DEBUG
if ( level & verbosity ) {
fwide( stderr, 1 );
fputws( L"\n", stderr );
for ( int i = 0; i < indent; i++ ) {
fputws( L" ", stderr );
}

66
src/c/environment/environment.c
View file

@ -9,8 +9,23 @@
#include <stdbool.h>
#include "debug.h"
#include "memory/memory.h"
#include "memory/node.h"
#include "memory/pointer.h"
#include "memory/pso.h"
#include "memory/pso2.h"
#include "memory/tags.h"
#include "ops/bind.h"
#include "ops/string_ops.h"
#include "payloads/cons.h"
#include "payloads/exception.h"
#include "payloads/psse_string.h"
#include "ops/truth.h"
/**
* @brief Flag to prevent re-initialisation.
@ -20,16 +35,57 @@ bool environment_initialised = false;
/**
* @brief Initialise a minimal environment, so that Lisp can be bootstrapped.
*
* @param node theindex of the node we are initialising.
* @param node the index of the node we are initialising.
* @return struct pso_pointer t on success, else an exception.
*/
struct pso_pointer initialise_environment( uint32_t node ) {
struct pso_pointer result = t;
if ( environment_initialised ) {
// TODO: throw an exception "Attempt to reinitialise environment"
struct pso_pointer result = initialise_memory( node );
if ( truep( result ) ) {
debug_print( L"Initialising `nil`... ", DEBUG_BOOTSTRAP, 0);
struct pso_pointer n = allocate( NILTAG, 2 );
if ( ( n.page == 0 ) && ( n.offset == 0 ) ) {
struct pso2 *object = pointer_to_object( n );
object->payload.cons.car = nil;
object->payload.cons.cdr = nil;
nil = n;
debug_print( L"success\n", DEBUG_BOOTSTRAP, 0);
} else {
// TODO: actually initialise it.
result =
make_exception( c_string_to_lisp_string
( L"Unexpected cell while allocating `nil`." ),
nil, n );
debug_print( L"fail\n", DEBUG_BOOTSTRAP, 0);
}
}
if ( !exceptionp( result ) ) {
debug_print( L"Initialising `t`... ", DEBUG_BOOTSTRAP, 0);
struct pso_pointer n = allocate( TRUETAG, 2 );
// offset is in words, and size of a pso2 is four words
if ( ( n.page == 0 ) && ( n.offset == 4 ) ) {
struct pso2 *object = pointer_to_object( n );
object->payload.string.character = L't';
object->payload.cons.cdr = t;
t = n;
debug_print( L"success\n", DEBUG_BOOTSTRAP, 0);
} else {
result =
make_exception( c_string_to_lisp_string
( L"Unexpected cell while allocating `t`." ),
nil, n );
debug_print( L"fail\n", DEBUG_BOOTSTRAP, 0);
}
}
if ( !exceptionp( result ) ) {
result = c_bind( c_string_to_lisp_symbol( L"nil" ), nil, nil );
result = c_bind( c_string_to_lisp_symbol( L"t" ), t, result );
environment_initialised = true;
}
return result;

21
src/c/io/io.c
View file

@ -114,7 +114,7 @@ char *lisp_string_to_c_string( struct pso_pointer s ) {
if ( stringp( s ) || symbolp( s ) ) {
int len = 0;
for ( struct pso_pointer c = s; !nilp( c ); c = cdr( c ) ) {
for ( struct pso_pointer c = s; !nilp( c ); c = c_cdr( c ) ) {
len++;
}
@ -123,7 +123,7 @@ char *lisp_string_to_c_string( struct pso_pointer s ) {
result = calloc( ( len * 4 ) + 1, sizeof( char ) );
int i = 0;
for ( struct pso_pointer c = s; !nilp( c ); c = cdr( c ) ) {
for ( struct pso_pointer c = s; !nilp( c ); c = c_cdr( c ) ) {
buffer[i++] = pointer_to_object( c )->payload.string.character;
}
@ -286,8 +286,8 @@ struct pso_pointer push_back_character( struct pso_pointer c,
if ( characterp( c ) && readp( r ) ) {
if ( url_ungetwc( ( wint_t )
( pointer_to_object( c )->payload.character.
character ),
( pointer_to_object( c )->payload.
character.character ),
pointer_to_object( r )->payload.stream.stream ) >=
0 ) {
result = t;
@ -315,8 +315,8 @@ lisp_close( struct pso_pointer frame_pointer, struct pso_pointer env ) {
if ( readp( fetch_arg( frame, 0 ) ) || writep( fetch_arg( frame, 0 ) ) ) {
if ( url_fclose
( pointer_to_object( fetch_arg( frame, 0 ) )->payload.
stream.stream )
( pointer_to_object( fetch_arg( frame, 0 ) )->payload.stream.
stream )
== 0 ) {
result = t;
}
@ -328,8 +328,7 @@ lisp_close( struct pso_pointer frame_pointer, struct pso_pointer env ) {
struct pso_pointer add_meta_integer( struct pso_pointer meta, wchar_t *key,
long int value ) {
return
cons( cons
( c_string_to_lisp_keyword( key ),
c_cons( c_cons( c_string_to_lisp_keyword( key ),
make_integer( value ) ), meta );
}
@ -339,7 +338,7 @@ struct pso_pointer add_meta_string( struct pso_pointer meta, wchar_t *key,
wchar_t buffer[strlen( value ) + 1];
mbstowcs( buffer, value, strlen( value ) + 1 );
return cons( cons( c_string_to_lisp_keyword( key ),
return c_cons( c_cons( c_string_to_lisp_keyword( key ),
c_string_to_lisp_string( buffer ) ), meta );
}
@ -570,8 +569,8 @@ lisp_read_char( struct pso_pointer frame_pointer, struct pso_pointer env ) {
if ( readp( fetch_arg( frame, 0 ) ) ) {
result =
make_string( url_fgetwc
( pointer_to_object( fetch_arg( frame, 0 ) )->payload.
stream.stream ), nil );
( pointer_to_object( fetch_arg( frame, 0 ) )->
payload.stream.stream ), nil );
}
return result;

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

@ -42,7 +42,7 @@ struct pso_pointer print_list_content( struct pso_pointer p, URL_FILE *output )
struct pso_pointer result = nil;
if ( consp( p ) ) {
for ( ; consp( p ); p = cdr( p ) ) {
for ( ; consp( p ); p = c_cdr( p ) ) {
struct pso2 *object = pointer_to_object( p );
result = in_print( object->payload.cons.car, output );

2
src/c/io/read.c
View file

@ -185,7 +185,7 @@ struct pso_pointer read( struct pso_pointer frame_pointer,
character = get_character( stream );
}
struct pso_pointer readmacro = assoc( character, readtable );
struct pso_pointer readmacro = c_assoc( character, readtable );
if ( !nilp( readmacro ) ) {
// invoke the read macro on the stream

20
src/c/memory/memory.c
View file

@ -10,9 +10,19 @@
#include <stdbool.h>
#include <stdio.h>
#include "debug.h"
#include "memory/memory.h"
#include "memory/node.h"
#include "memory/pointer.h"
#include "memory/pso.h"
#include "memory/pso2.h"
#include "memory/tags.h"
#include "payloads/exception.h"
#include "ops/bind.h"
#include "ops/string_ops.h"
/**
* @brief Freelists for each size class.
@ -24,6 +34,7 @@ struct pso_pointer freelists[MAX_SIZE_CLASS];
*/
bool memory_initialised = false;
/**
* @brief Initialise the memory allocation system.
*
@ -34,12 +45,19 @@ bool memory_initialised = false;
* @return int
*/
struct pso_pointer initialise_memory( uint32_t node ) {
struct pso_pointer result = nil;
if ( memory_initialised ) {
// TODO: throw an exception
result =
make_exception( c_string_to_lisp_string
( L"Attenpt to reinitialise memory." ), nil,
nil );
} else {
for ( uint8_t i = 0; i <= MAX_SIZE_CLASS; i++ ) {
freelists[i] = nil;
}
#ifdef DEBUG
debug_print(L"Memory initialised", DEBUG_BOOTSTRAP, 0);
#endif
memory_initialised = true;
}

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

@ -55,11 +55,7 @@ struct pso_pointer t = ( struct pso_pointer ) { 0, 0, 1 };
struct pso_pointer initialise_node( uint32_t index ) {
node_index = index;
struct pso_pointer result = initialise_memory( index );
if ( c_eq( result, t ) ) {
result = initialise_environment( index );
}
struct pso_pointer result = initialise_environment( index );
return result;
}

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

@ -36,6 +36,8 @@
#include "payloads/free.h"
#include "ops/truth.h"
/**
* @brief The pages which have so far been initialised.
*
@ -52,15 +54,11 @@ union page *pages[NPAGES];
uint32_t npages_allocated = 0;
/**
* @brief private to allocate_page; do not use.
*
* @param page_addr address of the newly allocated page to be initialised;
* @param page_index its location in the pages[] array;
* @param size_class the size class of objects in this page;
* @param freelist the freelist for objects of this size class.
* @return struct pso_pointer the new head for the freelist for this size_class,
* Initialise arrays for objects of different size classes, in this case class 2.
* This is boilerplate code and there must be some way of doing it better, but I don't
* know it. Macro?
*/
struct pso_pointer initialise_page( union page *page_addr, uint16_t page_index,
struct pso_pointer initialise_pso2_array(union page *page_addr, uint16_t page_index,
uint8_t size_class,
struct pso_pointer freelist ) {
struct pso_pointer result = freelist;
@ -72,10 +70,8 @@ struct pso_pointer initialise_page( union page *page_addr, uint16_t page_index,
// freelist when the first page is initiated, so we can grab that one for
// `nil` and the next on for `t`.
for ( int i = objs_in_page - 1; i >= 0; i-- ) {
// it should be safe to cast any pso object to a pso2
struct pso2 *object =
( struct pso2 * ) ( page_addr + ( i * obj_bytes ) );
( struct pso2 * ) &page_addr->pso2s[i];
object->header.tag.bytes.size_class = size_class;
strncpy( &( object->header.tag.bytes.mnemonic[0] ), FREETAG,
TAGLENGTH );
@ -88,6 +84,183 @@ struct pso_pointer initialise_page( union page *page_addr, uint16_t page_index,
return result;
}
/**
* Initialise arrays for objects of different size classes, in this case class 3.
* This is boilerplate code and there must be some way of doing it better, but I don't
* know it. Macro?
*/
struct pso_pointer initialise_pso3_array(union page *page_addr, uint16_t page_index,
uint8_t size_class,
struct pso_pointer freelist ) {
struct pso_pointer result = freelist;
int obj_size = pow( 2, size_class );
int obj_bytes = obj_size * sizeof( uint64_t );
int objs_in_page = PAGE_BYTES / obj_bytes;
for ( int i = objs_in_page - 1; i >= 0; i-- ) {
struct pso3 *object =
( struct pso3 * ) &page_addr->pso3s[i];
object->header.tag.bytes.size_class = size_class;
strncpy( &( object->header.tag.bytes.mnemonic[0] ), FREETAG,
TAGLENGTH );
object->payload.free.next = result;
result =
make_pointer( node_index, page_index,
( uint16_t ) ( i * obj_size ) );
}
return result;
}
/**
* Initialise arrays for objects of different size classes, in this case class 4.
* This is boilerplate code and there must be some way of doing it better, but I don't
* know it. Macro?
*/
struct pso_pointer initialise_pso4_array(union page *page_addr, uint16_t page_index,
uint8_t size_class,
struct pso_pointer freelist ) {
struct pso_pointer result = freelist;
int obj_size = pow( 2, size_class );
int obj_bytes = obj_size * sizeof( uint64_t );
int objs_in_page = PAGE_BYTES / obj_bytes;
for ( int i = objs_in_page - 1; i >= 0; i-- ) {
struct pso4 *object =
( struct pso4 * ) &page_addr->pso4s[i];
object->header.tag.bytes.size_class = size_class;
strncpy( &( object->header.tag.bytes.mnemonic[0] ), FREETAG,
TAGLENGTH );
object->payload.free.next = result;
result =
make_pointer( node_index, page_index,
( uint16_t ) ( i * obj_size ) );
}
return result;
}
/**
* Initialise arrays for objects of different size classes, in this case class 5.
* This is boilerplate code and there must be some way of doing it better, but I don't
* know it. Macro?
*/
struct pso_pointer initialise_pso5_array(union page *page_addr, uint16_t page_index,
uint8_t size_class,
struct pso_pointer freelist ) {
struct pso_pointer result = freelist;
int obj_size = pow( 2, size_class );
int obj_bytes = obj_size * sizeof( uint64_t );
int objs_in_page = PAGE_BYTES / obj_bytes;
for ( int i = objs_in_page - 1; i >= 0; i-- ) {
struct pso5 *object =
( struct pso5 * ) &page_addr->pso5s[i];
object->header.tag.bytes.size_class = size_class;
strncpy( &( object->header.tag.bytes.mnemonic[0] ), FREETAG,
TAGLENGTH );
object->payload.free.next = result;
result =
make_pointer( node_index, page_index,
( uint16_t ) ( i * obj_size ) );
}
return result;
}
/**
* Initialise arrays for objects of different size classes, in this case class 6.
* This is boilerplate code and there must be some way of doing it better, but I don't
* know it. Macro?
*/
struct pso_pointer initialise_pso6_array(union page *page_addr, uint16_t page_index,
uint8_t size_class,
struct pso_pointer freelist ) {
struct pso_pointer result = freelist;
int obj_size = pow( 2, size_class );
int obj_bytes = obj_size * sizeof( uint64_t );
int objs_in_page = PAGE_BYTES / obj_bytes;
for ( int i = objs_in_page - 1; i >= 0; i-- ) {
struct pso6 *object =
( struct pso6 * ) &page_addr->pso6s[i];
object->header.tag.bytes.size_class = size_class;
strncpy( &( object->header.tag.bytes.mnemonic[0] ), FREETAG,
TAGLENGTH );
object->payload.free.next = result;
result =
make_pointer( node_index, page_index,
( uint16_t ) ( i * obj_size ) );
}
return result;
}
/**
* Initialise arrays for objects of different size classes, in this case class 7.
* This is boilerplate code and there must be some way of doing it better, but I don't
* know it. Macro?
*/
struct pso_pointer initialise_pso7_array(union page *page_addr, uint16_t page_index,
uint8_t size_class,
struct pso_pointer freelist ) {
struct pso_pointer result = freelist;
int obj_size = pow( 2, size_class );
int obj_bytes = obj_size * sizeof( uint64_t );
int objs_in_page = PAGE_BYTES / obj_bytes;
for ( int i = objs_in_page - 1; i >= 0; i-- ) {
struct pso7 *object =
( struct pso7 * ) &page_addr->pso7s[i];
object->header.tag.bytes.size_class = size_class;
strncpy( &( object->header.tag.bytes.mnemonic[0] ), FREETAG,
TAGLENGTH );
object->payload.free.next = result;
result =
make_pointer( node_index, page_index,
( uint16_t ) ( i * obj_size ) );
}
return result;
}
/**
* @brief private to allocate_page; do not use.
*
* @param page_addr address of the newly allocated page to be initialised;
* @param page_index its location in the pages[] array;
* @param size_class the size class of objects in this page;
* @param freelist the freelist for objects of 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,
uint8_t size_class,
struct pso_pointer freelist ) {
struct pso_pointer result = nil;
int obj_size = pow( 2, size_class );
int obj_bytes = obj_size * sizeof( uint64_t );
int objs_in_page = PAGE_BYTES / obj_bytes;
debug_printf(DEBUG_ALLOC, 0,
L"Initialising page %d for objects of size class %d...",
page_index, size_class);
switch (size_class) {
case 2: result=initialise_pso2_array(page_addr, page_index, size_class, freelist); break;
case 3: result=initialise_pso2_array(page_addr, page_index, size_class, freelist); break;
case 4: result=initialise_pso2_array(page_addr, page_index, size_class, freelist); break;
case 5: result=initialise_pso2_array(page_addr, page_index, size_class, freelist); break;
case 6: result=initialise_pso2_array(page_addr, page_index, size_class, freelist); break;
case 7: result=initialise_pso2_array(page_addr, page_index, size_class, freelist); break;
default:
result = nil;
}
debug_print( nilp(result)? L"fail.\n" : L"success.\n", DEBUG_ALLOC, 0);
return result;
}
/**
* @brief Allocate a page for objects of this size class, initialise it, and
@ -121,15 +294,12 @@ struct pso_pointer allocate_page( uint8_t size_class ) {
initialise_page( ( union page * ) pg, npages_allocated,
size_class, freelists[size_class] );
debug_printf( DEBUG_ALLOC, 0,
L"Initialised page %d; freelist for size class %x updated.\n",
npages_allocated, size_class );
// result = freelists[size_class];
if ( npages_allocated == 0 ) {
// first page allocated; initialise nil and t
nil = lock_object( allocate( NILTAG, 2 ) );
t = lock_object( allocate( TRUETAG, 2 ) );
}
debug_printf( DEBUG_ALLOC, 0,
L"Initialised page %d; freelist for size class %x updated with head at page %d, offset %d.\n",
npages_allocated, size_class,
freelists[size_class].page, freelists[size_class].offset);
npages_allocated++;
} else {

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

@ -18,6 +18,7 @@
#include <string.h>
#include "debug.h"
#include "memory/destroy.h"
#include "memory/header.h"
#include "memory/memory.h"
@ -39,12 +40,16 @@
struct pso_pointer allocate( char *tag, uint8_t size_class ) {
struct pso_pointer result = nil;
#ifdef DEBUG
debug_printf( DEBUG_ALLOC, 0, L"Allocating object of size class %d with tag `%s`... ", size_class, tag);
#endif
if ( size_class <= MAX_SIZE_CLASS ) {
if ( nilp( freelists[size_class] ) ) {
result = allocate_page( size_class );
}
if ( !exceptionp( result ) && not( freelists[size_class] ) ) {
if ( !exceptionp( result ) ) {
result = freelists[size_class];
struct pso2 *object = pointer_to_object( result );
freelists[size_class] = object->payload.free.next;
@ -52,6 +57,8 @@ struct pso_pointer allocate( char *tag, uint8_t size_class ) {
strncpy( ( char * ) ( object->header.tag.bytes.mnemonic ), tag,
TAGLENGTH );
debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ", result.page, result.offset);
/* the object ought already to have the right size class in its tag
* because it was popped off the freelist for that size class. */
if ( object->header.tag.bytes.size_class != size_class ) {
@ -66,6 +73,10 @@ struct pso_pointer allocate( char *tag, uint8_t size_class ) {
}
} // TODO: else throw exception
#ifdef DEBUG
debug_print(exceptionp(result)? L"fail\n" : L"success\n", DEBUG_ALLOC, 0);
#endif
return result;
}
@ -118,11 +129,11 @@ struct pso_pointer inc_ref( struct pso_pointer pointer ) {
struct pso_pointer dec_ref( struct pso_pointer pointer ) {
struct pso2 *object = pointer_to_object( pointer );
if ( object->header.count > 0 && object->header.count != MAXREFERENCE ) {
if ( !nilp(pointer) && object->header.count > 0 && object->header.count != MAXREFERENCE ) {
object->header.count--;
#ifdef DEBUG
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 %3.3s at page %d, offset %d to count %d",
( ( char * ) ( object->header.tag.bytes.mnemonic ) ),
pointer.page, pointer.offset, object->header.count );
if ( vectorpointp( pointer ) ) {

76
src/c/ops/assoc.c
View file

@ -19,6 +19,7 @@
#include "payloads/cons.h"
#include "ops/eq.h"
#include "ops/stack_ops.h"
#include "ops/truth.h"
/**
@ -40,12 +41,12 @@ struct pso_pointer search( struct pso_pointer key,
if ( consp( store ) ) {
for ( struct pso_pointer cursor = store;
consp( store ) && found == false; cursor = cdr( cursor ) ) {
struct pso_pointer pair = car( cursor );
consp( store ) && found == false; cursor = c_cdr( cursor ) ) {
struct pso_pointer pair = c_car( cursor );
if ( consp( pair ) && c_equal( car( pair ), key ) ) {
if ( consp( pair ) && c_equal( c_car( pair ), key ) ) {
found = true;
result = return_key ? car( pair ) : cdr( pair );
result = return_key ? c_car( pair ) : c_cdr( pair );
}
}
}
@ -61,7 +62,7 @@ struct pso_pointer search( struct pso_pointer key,
*
* @return a pointer to the value of the key in the store, or nil if not found
*/
struct pso_pointer assoc( struct pso_pointer key, struct pso_pointer store ) {
struct pso_pointer c_assoc( struct pso_pointer key, struct pso_pointer store ) {
return search( key, store, false );
}
@ -73,7 +74,8 @@ struct pso_pointer assoc( struct pso_pointer key, struct pso_pointer store ) {
*
* @return a pointer to the copy of the key in the store, or nil if not found.
*/
struct pso_pointer interned( struct pso_pointer key, struct pso_pointer store ) {
struct pso_pointer c_interned( struct pso_pointer key,
struct pso_pointer store ) {
return search( key, store, true );
}
@ -85,6 +87,66 @@ struct pso_pointer interned( struct pso_pointer key, struct pso_pointer store )
*
* @return `true` if a pointer the key was found in the store..
*/
bool internedp( struct pso_pointer key, struct pso_pointer store ) {
bool c_internedp( struct pso_pointer key, struct pso_pointer store ) {
return !nilp( search( key, store, true ) );
}
/**
* @prief: bootstap layer assoc; Lisp calling signature.
*
* @return a pointer to the value of the key in the store, or nil if not found
*/
struct pso_pointer assoc(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer,
struct pso_pointer env ) {
#ifdef MANAGED_POINTER_ONLY
struct pso4 *frame = pointer_to_pso4( frame_pointer );
#endif
struct pso_pointer key = fetch_arg( frame, 0 );
struct pso_pointer store = fetch_arg( frame, 1 );
return c_assoc( key, store );
}
/**
* @prief: bootstap layer interned; Lisp calling signature.
*
* @return a pointer to the copy of the key in the store, or nil if not found.
*/
struct pso_pointer interned(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer,
struct pso_pointer env ) {
#ifdef MANAGED_POINTER_ONLY
struct pso4 *frame = pointer_to_pso4( frame_pointer );
#endif
struct pso_pointer key = fetch_arg( frame, 0 );
struct pso_pointer store = fetch_arg( frame, 1 );
return c_interned( key, store );
}
/**
* @prief: bootstap layer interned?; Lisp calling signature.
*
* @return `t` if a pointer to a copy of `key` is found in the store, or `nil` if not found.
*/
struct pso_pointer internedp(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer,
struct pso_pointer env ) {
#ifdef MANAGED_POINTER_ONLY
struct pso4 *frame = pointer_to_pso4( frame_pointer );
#endif
struct pso_pointer key = fetch_arg( frame, 0 );
struct pso_pointer store = fetch_arg( frame, 1 );
return c_interned( key, store );
}

8
src/c/ops/assoc.h
View file

@ -16,13 +16,13 @@
#include "memory/pointer.h"
struct cons_pointer search( struct pso_pointer key,
struct pso_pointer search( struct pso_pointer key,
struct pso_pointer store, bool return_key );
struct pso_pointer assoc( struct pso_pointer key, struct pso_pointer store );
struct pso_pointer c_assoc( struct pso_pointer key, struct pso_pointer store );
struct pso_pointer interned( struct pso_pointer key,
struct pso_pointer c_interned( struct pso_pointer key,
struct pso_pointer store );
bool internedp( struct pso_pointer key, struct pso_pointer store );
bool c_internedp( struct pso_pointer key, struct pso_pointer store );
#endif

16
src/c/ops/bind.c
View file

@ -21,14 +21,20 @@
#include "payloads/cons.h"
#include "payloads/stack.h"
struct pso_pointer bind( struct pso_pointer frame_pointer,
struct pso_pointer lisp_bind(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer,
struct pso_pointer env ) {
#ifdef MANAGED_POINTER_ONLY
struct pso4 *frame = pointer_to_pso4( frame_pointer );
#endif
struct pso_pointer key = fetch_arg( frame, 0 );
struct pso_pointer value = fetch_arg( frame, 1 );
struct pso_pointer store = fetch_arg( frame, 2 );
return cons( cons( key, value ), store );
return c_cons( c_cons( key, value ), store );
}
struct pso_pointer c_bind( struct pso_pointer key,
@ -37,7 +43,11 @@ struct pso_pointer c_bind( struct pso_pointer key,
struct pso_pointer result = nil;
struct pso_pointer next = make_frame( nil, key, value, store );
inc_ref( next );
result = bind( next, nil );
result = lisp_bind(
#ifndef MANAGED_POINTER_ONLY
pointer_to_pso4( next ),
#endif
next, nil );
dec_ref( next );
return result;

11
src/c/ops/bind.h
View file

@ -14,12 +14,17 @@
#include <stdbool.h>
#include "memory/pointer.h"
struct pso_pointer bind( struct pso_pointer frame_pointer,
struct pso_pointer env );
#include "memory/pso4.h"
struct pso_pointer c_bind( struct pso_pointer key,
struct pso_pointer value,
struct pso_pointer store );
struct pso_pointer lisp_bind(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer,
struct pso_pointer env );
#endif

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

@ -16,6 +16,7 @@
#include "memory/tags.h"
#include "payloads/cons.h"
#include "payloads/function.h"
#include "payloads/integer.h"
#include "payloads/stack.h"
#include "ops/stack_ops.h"
@ -26,6 +27,8 @@
*
* Shallow, cheap equality.
*
* Bootstrap function: only knows about character, cons, integer, and
* string-like-thing equality.
* TODO: if either of these pointers points to a cache cell, then what
* we need to check is the cached value, which is not so cheap. Ouch!
*
@ -53,8 +56,8 @@ bool c_equal( struct pso_pointer a, struct pso_pointer b ) {
ob->payload.character.character );
break;
case CONSTV:
result = ( c_equal( car( a ), car( b ) )
&& c_equal( cdr( a ), cdr( b ) ) );
result = ( c_equal( c_car( a ), c_car( b ) )
&& c_equal( c_cdr( a ), c_cdr( b ) ) );
break;
case INTEGERTV:
result = ( oa->payload.integer.value
@ -63,11 +66,11 @@ bool c_equal( struct pso_pointer a, struct pso_pointer b ) {
case KEYTV:
case STRINGTV:
case SYMBOLTV:
while ( result == false && !nilp( a ) && !nilp( b ) ) {
while ( !nilp( a ) && !nilp( b ) ) {
if ( pointer_to_object( a )->payload.string.character ==
pointer_to_object( b )->payload.string.character ) {
a = cdr( a );
b = cdr( b );
a = c_cdr( a );
b = c_cdr( b );
}
}
result = nilp( a ) && nilp( b );
@ -86,15 +89,19 @@ bool c_equal( struct pso_pointer a, struct pso_pointer b ) {
*
* * (eq? args...)
*
* @param frame my stack_frame.
* @param frame_pointer a pointer to my stack_frame.
* @param env my environment (ignored).
* @return `t` if all args are pointers to the same object, else `nil`;
*/
struct pso_pointer eq( struct pso_pointer frame_pointer,
struct pso_pointer eq(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer,
struct pso_pointer env ) {
#ifdef MANAGED_POINTER_ONLY
struct pso4 *frame = pointer_to_pso4( frame_pointer );
#endif
struct pso_pointer result = t;
if ( frame->payload.stack_frame.args > 1 ) {
@ -108,3 +115,31 @@ struct pso_pointer eq( struct pso_pointer frame_pointer,
return result;
}
/**
* Function; do all arguments to this finction point to the same object?
*
* Deep, expensive equality. Bootstrap version: only knows
* * cons cells
* * integers
* * keywords
* * symbols
* * strings
*
* * (equal? arg1 qrg2)
*
* @return `t` if all args are pointers to the same object, else `nil`;
*/
struct pso_pointer equal(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer,
struct pso_pointer env ) {
#ifdef MANAGED_POINTER_ONLY
struct pso4 *frame = pointer_to_pso4( frame_pointer );
#endif
return c_equal( fetch_arg( frame, 0 ), fetch_arg( frame, 1 ) ) ? t : nil;
}

18
src/c/ops/eq.h
View file

@ -16,10 +16,28 @@
#include "memory/pointer.h"
#include "memory/pso4.h"
#include "payloads/function.h"
bool c_eq( struct pso_pointer a, struct pso_pointer b );
struct pso_pointer eq( struct pso_pointer frame_pointer,
struct pso_pointer env );
bool c_equal( struct pso_pointer a, struct pso_pointer b );
struct pso_pointer eq(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer,
struct pso_pointer env );
struct pso_pointer equal(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer,
struct pso_pointer env );
#endif

76
src/c/ops/eval.c
View file

@ -1,76 +0,0 @@
/**
* ops/eval.c
*
* Post Scarcity Software Environment: eval.
*
* Evaluate an arbitrary Lisp expression.
*
* (c) 2026 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include "memory/pointer.h"
#include "memory/pso.h"
#include "memory/pso2.h"
#include "memory/pso3.h"
#include "memory/pso4.h"
#include "memory/tags.h"
#include "payloads/cons.h"
#include "payloads/exception.h"
#include "payloads/function.h"
#include "payloads/keyword.h"
#include "payloads/lambda.h"
#include "payloads/nlambda.h"
#include "payloads/special.h"
#include "payloads/stack.h"
#include "ops/truth.h"
/**
* @brief Despatch eval based on tag of the form in the first position.
*
* @param frame The current stack frame;
* @param frame_pointer A pointer to the current stack frame;
* @param env the evaluation environment.
* @return struct pso_pointer
*/
struct pso_pointer lisp_eval( struct pso_pointer frame_pointer,
struct pso_pointer env ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer result = frame->payload.stack_frame.arg[0];
switch ( get_tag_value( result)) {
// case CONSTV:
// result = eval_cons( frame, frame_pointer, env);
// break;
// case KEYTV:
case SYMBOLTV:
result = eval_symbol( frame_pointer, env);
break;
case LAMBDATV:
result = eval_lambda( frame_pointer, env);
break;
case NLAMBDATV:
result = eval_nlambda( frame_pointer, env);
break;
case SPECIALTV:
result = eval_special( frame, frame_pointer, env);
break;
}
if ( exceptionp( result ) ) {
struct pso3 *x =
( struct pso3 * ) pointer_to_object_with_tag_value( result,
EXCEPTIONTV );
if ( nilp( x->payload.exception.stack ) ) {
inc_ref( result );
result =
make_exception( x->payload.exception.message, frame_pointer,
result );
}
}
return result;
}

106
src/c/ops/eval_apply.c Normal file
View file

@ -0,0 +1,106 @@
/**
* ops/apply.c
*
* Post Scarcity Software Environment: apply.
*
* Add a applying for a key/value pair to a store -- at this stage, just an
* association list.
*
* (c) 2026 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include "memory/node.h"
#include "memory/pointer.h"
#include "memory/pso.h"
#include "memory/pso3.h"
#include "memory/pso4.h"
#include "memory/tags.h"
#include "ops/assoc.h"
#include "ops/stack_ops.h"
#include "ops/string_ops.h"
#include "ops/truth.h"
#include "payloads/cons.h"
#include "payloads/stack.h"
/**
* @brief Apply a function to arguments in an environment.
*
* * (apply fn args)
*/
struct pso_pointer apply(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer,
struct pso_pointer env ) {
#ifdef MANAGED_POINTER_ONLY
struct pso4 *frame = pointer_to_pso4( frame_pointer );
#endif
// TODO.
}
/**
* @brief Evaluate a form, in an environment
*
* * (eval form)
*/
struct pso_pointer eval(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer,
struct pso_pointer env ) {
#ifdef MANAGED_POINTER_ONLY
struct pso4 *frame = pointer_to_pso4( frame_pointer );
#endif
struct pso_pointer result = fetch_arg( frame, 0 );
switch ( get_tag_value( result ) ) {
// case CONSTV:
// result = eval_cons( frame, frame_pointer, env);
// break;
case INTEGERTV:
case KEYTV:
case STRINGTV:
// self evaluating
break;
case SYMBOLTV:
result = c_assoc( result, env );
break;
// case LAMBDATV:
// result = eval_lambda( frame, frame_pointer, env);
// break;
// case NLAMBDATV:
// result = eval_nlambda( frame, frame_pointer, env);
// break;
// case SPECIALTV:
// result = eval_special( frame, frame_pointer, env);
// break;
default:
result =
make_exception( c_cons
( c_string_to_lisp_string
( L"Can't yet evaluate things of this type: " ),
result ), frame_pointer, nil );
}
if ( exceptionp( result ) ) {
struct pso3 *x =
( struct pso3 * ) pointer_to_object_with_tag_value( result,
EXCEPTIONTV );
if ( nilp( x->payload.exception.stack ) ) {
inc_ref( result );
result =
make_exception( x->payload.exception.message, frame_pointer,
result );
}
}
return result;
}

36
src/c/ops/eval_apply.h Normal file
View file

@ -0,0 +1,36 @@
/**
* ops/eval_apply.h
*
* Post Scarcity Software Environment: eval, apply.
*
* apply: Apply a function to arguments in an environment.
* eval: Evaluate a form in an environment.
*
* (c) 2026 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __psse_ops_eval_apply_h
#define __psse_ops_eval_apply_h
#include "memory/pointer.h"
#include "memory/pso4.h"
#include "payloads/function.h"
struct pso_pointer apply(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer,
struct pso_pointer env );
struct pso_pointer eval(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer,
struct pso_pointer env );
#endif

72
src/c/ops/list_ops.c Normal file
View file

@ -0,0 +1,72 @@
/**
* ops/list_ops.h
*
* Post Scarcity Software Environment: list_ops.
*
* Operations on cons cells.
*
* (c) 2026 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __psse_ops_list_ops_h
#define __psse_ops_list_ops_h
#include "memory/pointer.h"
#include "memory/pso.h"
#include "memory/pso4.h"
#include "memory/tags.h"
#include "ops/stack_ops.h"
#include "payloads/cons.h"
#include "payloads/stack.h"
struct pso_pointer car(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer,
struct pso_pointer env ) {
#ifdef MANAGED_POINTER_ONLY
struct pso4 *frame = pointer_to_pso4( frame_pointer );
#endif
return c_car( fetch_arg( frame, 0 ) );
}
struct pso_pointer cdr(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer,
struct pso_pointer env ) {
#ifdef MANAGED_POINTER_ONLY
struct pso4 *frame = pointer_to_pso4( frame_pointer );
#endif
return c_cdr( fetch_arg( frame, 0 ) );
}
/**
* @brief allocate a cons cell from the first two args in this frame, and
* return a pointer to it.
*
* Lisp calling conventions.
*
* @return struct pso_pointer a pointer to the newly allocated cons cell.
*/
struct pso_pointer cons(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer,
struct pso_pointer env ) {
#ifdef MANAGED_POINTER_ONLY
struct pso4 *frame = pointer_to_pso4( frame_pointer );
#endif
return c_cons( fetch_arg( frame, 0 ), fetch_arg( frame, 1 ) );
}
#endif

39
src/c/ops/list_ops.h Normal file
View file

@ -0,0 +1,39 @@
/**
* ops/list_ops.h
*
* Post Scarcity Software Environment: list_ops.
*
* Operations on cons cells.
*
* (c) 2026 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __psse_ops_list_ops_h
#define __psse_ops_list_ops_h
#include "memory/pointer.h"
#include "memory/pso4.h"
struct pso_pointer car(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer,
struct pso_pointer env );
struct pso_pointer cdr(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer,
struct pso_pointer env );
struct pso_pointer cons(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer,
struct pso_pointer env );
#endif

6
src/c/ops/reverse.c
View file

@ -39,13 +39,14 @@ struct pso_pointer reverse( struct pso_pointer sequence ) {
struct pso_pointer result = nil;
for ( struct pso_pointer cursor = sequence; !nilp( sequence );
cursor = cdr( cursor ) ) {
cursor = c_cdr( cursor ) ) {
struct pso2 *object = pointer_to_object( cursor );
switch ( get_tag_value( cursor ) ) {
case CONSTV:
result = cons( car( cursor ), result );
result = c_cons( c_car( cursor ), result );
break;
case KEYTV:
// TODO: should you be able to reverse keywords and symbols?
result =
make_string_like_thing( object->payload.string.character,
result, KEYTAG );
@ -56,6 +57,7 @@ struct pso_pointer reverse( struct pso_pointer sequence ) {
result, STRINGTAG );
break;
case SYMBOLTV:
// TODO: should you be able to reverse keywords and symbols?
result =
make_string_like_thing( object->payload.string.character,
result, SYMBOLTAG );

26
src/c/ops/string_ops.c
View file

@ -73,7 +73,7 @@ struct pso_pointer make_string_like_thing( wint_t c, struct pso_pointer tail,
char *tag ) {
struct pso_pointer pointer = nil;
if ( check_type( tail, tag ) || check_tag( tail, NILTV ) ) {
if ( check_type( tail, tag ) || nilp(tail) ) {
pointer = allocate( tag, CONS_SIZE_CLASS );
struct pso2 *cell = pointer_to_object( pointer );
@ -85,9 +85,10 @@ struct pso_pointer make_string_like_thing( wint_t c, struct pso_pointer tail,
debug_println( DEBUG_ALLOC );
} else {
// \todo should throw an exception!
struct pso2* tobj = pointer_to_object( tail);
debug_printf( DEBUG_ALLOC, 0,
L"Warning: only %4.4s can be prepended to %4.4s\n",
tag, tag );
L"Warning: %3.3s cannot be prepended to %3.3s\n",
tag, tobj->header.tag.bytes.mnemonic );
}
return pointer;
@ -145,6 +146,25 @@ struct pso_pointer c_string_to_lisp_string( wchar_t *string ) {
return result;
}
/**
* Return a lisp symbol representation of this wide character string. In
* symbols, I am accepting only lower case characters.
*/
struct pso_pointer c_string_to_lisp_symbol( wchar_t *symbol ) {
struct pso_pointer result = nil;
for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) {
wchar_t c = towlower( symbol[i] );
if ( iswalpha( c ) || c == L'-' ) {
result = make_symbol( c, result );
}
}
return result;
}
/**
* Return a lisp keyword representation of this wide character string. In
* keywords, I am accepting only lower case characters and numbers.

2
src/c/ops/string_ops.h
View file

@ -29,4 +29,6 @@ struct pso_pointer c_string_to_lisp_string( wchar_t *string );
struct pso_pointer c_string_to_lisp_keyword( wchar_t *symbol );
struct pso_pointer c_string_to_lisp_symbol( wchar_t *symbol );
#endif

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

@ -19,6 +19,7 @@
#include "payloads/cons.h"
#include "payloads/exception.h"
#include "ops/stack_ops.h"
#include "ops/string_ops.h"
/**
@ -29,7 +30,7 @@
* @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.
*/
struct pso_pointer cons( struct pso_pointer car, struct pso_pointer cdr ) {
struct pso_pointer c_cons( struct pso_pointer car, struct pso_pointer cdr ) {
struct pso_pointer result = allocate( CONSTAG, 2 );
struct pso2 *object = pointer_to_object( result );
@ -47,7 +48,7 @@ struct pso_pointer cons( struct pso_pointer car, struct pso_pointer cdr ) {
* @return the car of the indicated cell.
* @exception if the pointer does not indicate a cons cell.
*/
struct pso_pointer car( struct pso_pointer cons ) {
struct pso_pointer c_car( struct pso_pointer cons ) {
struct pso_pointer result = nil;
struct pso2 *object = pointer_to_object( result );
@ -66,7 +67,7 @@ struct pso_pointer car( struct pso_pointer cons ) {
* @return the cdr of the indicated cell.
* @exception if the pointer does not indicate a cons cell.
*/
struct pso_pointer cdr( struct pso_pointer p ) {
struct pso_pointer c_cdr( struct pso_pointer p ) {
struct pso_pointer result = nil;
struct pso2 *object = pointer_to_object( result );
@ -81,7 +82,7 @@ struct pso_pointer cdr( struct pso_pointer p ) {
break;
default:
result =
make_exception( cons
make_exception( c_cons
( c_string_to_lisp_string
( L"Invalid type for cdr" ), p ), nil, nil );
break;
@ -104,7 +105,7 @@ struct pso_pointer destroy_cons( struct pso_pointer fp,
if ( stackp( fp ) ) {
struct pso4 *frame = pointer_to_pso4( fp );
struct pso_pointer p = frame->payload.stack_frame.arg[0];
dec_ref( car( p ) );
dec_ref( cdr( p ) );
dec_ref( c_car( p ) );
dec_ref( c_cdr( p ) );
}
}

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

@ -26,11 +26,11 @@ struct cons_payload {
struct pso_pointer cdr;
};
struct pso_pointer car( struct pso_pointer cons );
struct pso_pointer c_car( struct pso_pointer cons );
struct pso_pointer cdr( struct pso_pointer cons );
struct pso_pointer c_cdr( struct pso_pointer cons );
struct pso_pointer cons( struct pso_pointer car, struct pso_pointer cdr );
struct pso_pointer c_cons( struct pso_pointer car, struct pso_pointer cdr );
struct pso_pointer destroy_cons( struct pso_pointer fp,
struct pso_pointer env );

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

@ -13,29 +13,43 @@
#include "memory/pointer.h"
#include "memory/pso4.h"
/**
* I don't think it's necessary to pass both an unmanaged and a managed
* frame pointer into a function, but it may prove to be more efficient to do
* so. For the present we'll assume not. See state of play for 15042026.
*/
#define MANAGED_POINTER_ONLY TRUE
/**
* @brief Payload of a function cell.
* `source` points to the source from which the function was compiled, or NIL
* if it is a primitive.
* `executable` points to a function which takes a pointer to a stack frame
* (representing its stack frame) and a cons pointer (representing its
* environment) as arguments and returns a cons pointer (representing its
* result).
*/
struct function_payload {
/**
* pointer to metadata (e.g. the source from which the function was compiled).
* pointer to metadata (e.g. the source from which the function was compiled,
* something to help estimate the cost of the function?).
*/
struct pso_pointer meta;
/** pointer to a function which takes a cons pointer (representing
* its argument list) and a cons pointer (representing its environment) and a
* stack frame (representing the previous stack frame) as arguments and returns
* a cons pointer (representing its result).
* \todo check this documentation is current!
#ifdef MANAGED_POINTER_ONLY
/**
* pointer to a C function which takes a managed pointer to the same stack
* frame and a managed pointer to the environment as arguments. Arguments
* to the Lisp function are assumed to be loaded into the frame before
* invocation.
*/
struct pso_pointer ( *executable ) ( struct pso4 *,
struct pso_pointer,
struct pso_pointer );
struct pso_pointer ( *executable ) ( struct pso_pointer frame_pointer,
struct pso_pointer env );
#else
/**
* pointer to a C function which takes an unmanaged pointer to a stack frame,
* a managed pointer to the same stack frame, and a managed pointer to the
* environment as arguments. Arguments to the Lisp function are assumed to be
* loaded into the frame before invocation.
*/
struct pso_pointer ( *executable ) ( struct pso4 * frame,
struct pso_pointer frame_pointer,
struct pso_pointer env );
#endif
};
#endif

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

@ -38,7 +38,7 @@ struct pso_pointer destroy_string( struct pso_pointer fp,
struct pso4 *frame = pointer_to_pso4( fp );
struct pso_pointer p = frame->payload.stack_frame.arg[0];
dec_ref( cdr( p ) );
dec_ref( c_cdr( p ) );
}
return nil;

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

@ -33,8 +33,6 @@ struct string_payload {
struct pso_pointer cdr;
};
struct pso_pointer make_string( wint_t c, struct pso_pointer tail );
struct pso_pointer destroy_string( struct pso_pointer fp,
struct pso_pointer env );

19
src/c/payloads/stack.c
View file

@ -18,6 +18,8 @@
#include "memory/pso4.h"
#include "memory/tags.h"
#include "payloads/cons.h"
/**
* @brief Construct a stack frame with this `previous` pointer, and arguments
* taken from the remaining arguments to this function, which should all be
@ -50,7 +52,8 @@ struct pso_pointer make_frame( struct pso_pointer previous, ... ) {
struct pso_pointer more_args = nil;
for ( ; cursor < count; cursor++ ) {
more_args = cons( va_arg( args, struct pso_pointer ), more_args );
more_args =
c_cons( va_arg( args, struct pso_pointer ), more_args );
}
// should be frame->payload.stack_frame.more = reverse( more_args), but
@ -75,19 +78,17 @@ struct pso_pointer destroy_stack_frame( struct pso_pointer fp,
struct pso_pointer env ) {
if ( stackp( fp ) ) {
struct pso4 *frame = pointer_to_pso4( fp );
struct pso4 *casualty =
pointer_to_pso4( frame->payload.stack_frame.arg[0] );
dec_ref( casualty->payload.stack_frame.previous );
dec_ref( casualty->payload.stack_frame.function );
dec_ref( casualty->payload.stack_frame.more );
dec_ref( frame->payload.stack_frame.previous );
dec_ref( frame->payload.stack_frame.function );
dec_ref( frame->payload.stack_frame.more );
for ( int i = 0; i < args_in_frame; i++ ) {
dec_ref( casualty->payload.stack_frame.arg[0] );
dec_ref( frame->payload.stack_frame.arg[i] );
}
casualty->payload.stack_frame.args = 0;
casualty->payload.stack_frame.depth = 0;
frame->payload.stack_frame.args = 0;
frame->payload.stack_frame.depth = 0;
}
return nil;