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

Many more ops written, and it compiles. Nothing works yet.

Browse source
This commit is contained in:
Simon Brooke 2026-04-15 19:50:10 +01:00
parent f5f8e38b91
commit c9f50572ab
17 changed files with 290 additions and 71 deletions
Download patch file Download diff file Expand all files Collapse all files

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

72
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,7 @@ 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 +86,63 @@ 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

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

@ -21,14 +21,19 @@
#include "payloads/cons.h"
#include "payloads/stack.h"
struct pso_pointer bind( struct pso_pointer frame_pointer,
struct pso_pointer env ) {
struct pso_pointer 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 +42,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 = 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

@ -15,11 +15,16 @@
#include "memory/pointer.h"
struct pso_pointer bind( struct pso_pointer frame_pointer,
struct pso_pointer env );
struct pso_pointer c_bind( struct pso_pointer key,
struct pso_pointer value,
struct pso_pointer store );
struct pso_pointer 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,14 +89,17 @@ 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 env ) {
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;
@ -108,3 +114,30 @@ 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;
}

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

@ -16,10 +16,30 @@
#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

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 );

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;

6
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,7 @@ 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
@ -83,7 +85,7 @@ struct pso_pointer destroy_stack_frame( struct pso_pointer fp,
dec_ref( casualty->payload.stack_frame.more );
for ( int i = 0; i < args_in_frame; i++ ) {
dec_ref( casualty->payload.stack_frame.arg[0] );
dec_ref( casualty->payload.stack_frame.arg[i] );
}
casualty->payload.stack_frame.args = 0;