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

Well, I really made a mess with the last commit; this one sorts it out.

Browse source
This commit is contained in:
Simon Brooke 2026-03-31 20:09:37 +01:00
parent 1196b3eb1d
commit a302663b32
16 changed files with 3671 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

433
archive/c/ops/equal.c Normal file
View file

@ -0,0 +1,433 @@
/*
* equal.c
*
* Checks for shallow and deep equality
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <math.h>
#include <stdbool.h>
#include <string.h>
#include "arith/integer.h"
#include "arith/peano.h"
#include "arith/ratio.h"
#include "debug.h"
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
#include "memory/vectorspace.h"
#include "ops/equal.h"
#include "ops/intern.h"
/**
* Shallow, and thus cheap, equality: true if these two objects are
* the same object, else false.
*/
bool eq( struct cons_pointer a, struct cons_pointer b ) {
return ( ( a.page == b.page ) && ( a.offset == b.offset ) );
}
/**
* True if the objects at these two cons pointers have the same tag, else false.
* @param a a pointer to a cons-space object;
* @param b another pointer to a cons-space object.
* @return true if the objects at these two cons pointers have the same tag,
* else false.
*/
bool same_type( struct cons_pointer a, struct cons_pointer b ) {
struct cons_space_object *cell_a = &pointer2cell( a );
struct cons_space_object *cell_b = &pointer2cell( b );
return cell_a->tag.value == cell_b->tag.value;
}
/**
* Some strings will be null terminated and some will be NIL terminated... ooops!
* @param string the string to test
* @return true if it's the end of a string.
*/
bool end_of_string( struct cons_pointer string ) {
return nilp( string ) ||
pointer2cell( string ).payload.string.character == '\0';
}
/**
* @brief compare two long doubles and returns true if they are the same to
* within a tolerance of one part in a billion.
*
* @param a
* @param b
* @return true if `a` and `b` are equal to within one part in a billion.
* @return false otherwise.
*/
bool equal_ld_ld( long double a, long double b ) {
long double fa = fabsl( a );
long double fb = fabsl( b );
/* difference of magnitudes */
long double diff = fabsl( fa - fb );
/* average magnitude of the two */
long double av = ( fa > fb ) ? ( fa - diff ) : ( fb - diff );
/* amount of difference we will tolerate for equality */
long double tolerance = av * 0.000000001;
bool result = ( fabsl( a - b ) < tolerance );
debug_printf( DEBUG_EQUAL, L"\nequal_ld_ld returning %d\n", result );
return result;
}
/**
* @brief Private function, don't use. It depends on its arguments being
* numbers and doesn't sanity check them.
*
* @param a a lisp integer -- if it isn't an integer, things will break.
* @param b a lisp real -- if it isn't a real, things will break.
* @return true if the two numbers have equal value.
* @return false if they don't.
*/
bool equal_integer_real( struct cons_pointer a, struct cons_pointer b ) {
debug_print( L"\nequal_integer_real: ", DEBUG_ARITH );
debug_print_object( a, DEBUG_ARITH );
debug_print( L" = ", DEBUG_ARITH );
debug_print_object( b, DEBUG_ARITH );
bool result = false;
struct cons_space_object *cell_a = &pointer2cell( a );
struct cons_space_object *cell_b = &pointer2cell( b );
if ( nilp( cell_a->payload.integer.more ) ) {
result =
equal_ld_ld( ( long double ) cell_a->payload.integer.value,
cell_b->payload.real.value );
} else {
fwprintf( stderr,
L"\nequality is not yet implemented for bignums compared to reals." );
}
debug_printf( DEBUG_ARITH, L"\nequal_integer_real returning %d\n",
result );
return result;
}
/**
* @brief Private function, don't use. It depends on its arguments being
* numbers and doesn't sanity check them.
*
* @param a a lisp integer -- if it isn't an integer, things will break.
* @param b a lisp number.
* @return true if the two numbers have equal value.
* @return false if they don't.
*/
bool equal_integer_number( struct cons_pointer a, struct cons_pointer b ) {
debug_print( L"\nequal_integer_number: ", DEBUG_ARITH );
debug_print_object( a, DEBUG_ARITH );
debug_print( L" = ", DEBUG_ARITH );
debug_print_object( b, DEBUG_ARITH );
bool result = false;
struct cons_space_object *cell_b = &pointer2cell( b );
switch ( cell_b->tag.value ) {
case INTEGERTV:
result = equal_integer_integer( a, b );
break;
case REALTV:
result = equal_integer_real( a, b );
break;
case RATIOTV:
result = false;
break;
}
debug_printf( DEBUG_ARITH, L"\nequal_integer_number returning %d\n",
result );
return result;
}
/**
* @brief Private function, don't use. It depends on its arguments being
* numbers and doesn't sanity check them.
*
* @param a a lisp real -- if it isn't an real, things will break.
* @param b a lisp number.
* @return true if the two numbers have equal value.
* @return false if they don't.
*/
bool equal_real_number( struct cons_pointer a, struct cons_pointer b ) {
debug_print( L"\nequal_real_number: ", DEBUG_ARITH );
debug_print_object( a, DEBUG_ARITH );
debug_print( L" = ", DEBUG_ARITH );
debug_print_object( b, DEBUG_ARITH );
bool result = false;
struct cons_space_object *cell_b = &pointer2cell( b );
switch ( cell_b->tag.value ) {
case INTEGERTV:
result = equal_integer_real( b, a );
break;
case REALTV:{
struct cons_space_object *cell_a = &pointer2cell( a );
result =
equal_ld_ld( cell_a->payload.real.value,
cell_b->payload.real.value );
}
break;
case RATIOTV:
struct cons_space_object *cell_a = &pointer2cell( a );
result =
equal_ld_ld( c_ratio_to_ld( b ), cell_a->payload.real.value );
break;
}
debug_printf( DEBUG_ARITH, L"\nequal_real_number returning %d\n", result );
return result;
}
/**
* @brief Private function, don't use. It depends on its arguments being
* numbers and doesn't sanity check them.
*
* @param a a number
* @param b a number
* @return true if the two numbers have equal value.
* @return false if they don't.
*/
bool equal_number_number( struct cons_pointer a, struct cons_pointer b ) {
bool result = eq( a, b );
debug_print( L"\nequal_number_number: ", DEBUG_ARITH );
debug_print_object( a, DEBUG_ARITH );
debug_print( L" = ", DEBUG_ARITH );
debug_print_object( b, DEBUG_ARITH );
if ( !result ) {
struct cons_space_object *cell_a = &pointer2cell( a );
struct cons_space_object *cell_b = &pointer2cell( b );
switch ( cell_a->tag.value ) {
case INTEGERTV:
result = equal_integer_number( a, b );
break;
case REALTV:
result = equal_real_number( a, b );
break;
case RATIOTV:
switch ( cell_b->tag.value ) {
case INTEGERTV:
/* as ratios are simplified by make_ratio, any
* ratio that would simplify to an integer is an
* integer, TODO: no longer always true. */
result = false;
break;
case REALTV:
result = equal_real_number( b, a );
break;
case RATIOTV:
result = equal_ratio_ratio( a, b );
break;
/* can't throw an exception from here, but non-numbers
* shouldn't have been passed in anyway, so no default. */
}
break;
/* can't throw an exception from here, but non-numbers
* shouldn't have been passed in anyway, so no default. */
}
}
debug_printf( DEBUG_ARITH, L"\nequal_number_number returning %d\n",
result );
return result;
}
/**
* @brief equality of two map-like things.
*
* The list returned by `keys` on a map-like thing is not sorted, and is not
* guaranteed always to come out in the same order. So equality is established
* if:
* 1. the length of the keys list is the same; and
* 2. the value of each key in the keys list for map `a` is the same in map `a`
* and in map `b`.
*
* Private function, do not use outside this file, **WILL NOT** work
* unless both arguments are VECPs.
*
* @param a a pointer to a vector space object.
* @param b another pointer to a vector space object.
* @return true if the two objects have the same logical structure.
* @return false otherwise.
*/
bool equal_map_map( struct cons_pointer a, struct cons_pointer b ) {
bool result = false;
struct cons_pointer keys_a = hashmap_keys( a );
if ( c_length( keys_a ) == c_length( hashmap_keys( b ) ) ) {
result = true;
for ( struct cons_pointer i = keys_a; !nilp( i ); i = c_cdr( i ) ) {
struct cons_pointer key = c_car( i );
if ( !equal
( hashmap_get( a, key, false ),
hashmap_get( b, key, false ) ) ) {
result = false;
break;
}
}
}
return result;
}
/**
* @brief equality of two vector-space things.
*
* Expensive, but we need to be able to check for equality of at least hashmaps
* and namespaces.
*
* Private function, do not use outside this file, not guaranteed to work
* unless both arguments are VECPs pointing to map like things.
*
* @param a a pointer to a vector space object.
* @param b another pointer to a vector space object.
* @return true if the two objects have the same logical structure.
* @return false otherwise.
*/
bool equal_vector_vector( struct cons_pointer a, struct cons_pointer b ) {
bool result = false;
if ( eq( a, b ) ) {
result = true; // same
/* there shouldn't ever be two separate VECP cells which point to the
* same address in vector space, so I don't believe it's worth checking
* for this.
*/
} else if ( vectorp( a ) && vectorp( b ) ) {
struct vector_space_object *va = pointer_to_vso( a );
struct vector_space_object *vb = pointer_to_vso( b );
/* what we're saying here is that a namespace is not equal to a map,
* even if they have identical logical structure. Is this right? */
if ( va->header.tag.value == vb->header.tag.value ) {
switch ( va->header.tag.value ) {
case HASHTV:
case NAMESPACETV:
result = equal_map_map( a, b );
break;
}
}
}
// else can't throw an exception from here but TODO: should log.
return result;
}
/**
* Deep, and thus expensive, equality: true if these two objects have
* identical structure, else false.
*/
bool equal( struct cons_pointer a, struct cons_pointer b ) {
debug_print( L"\nequal: ", DEBUG_EQUAL );
debug_print_object( a, DEBUG_EQUAL );
debug_print( L" = ", DEBUG_EQUAL );
debug_print_object( b, DEBUG_EQUAL );
bool result = false;
if ( eq( a, b ) ) {
result = true;
} else if ( !numberp( a ) && same_type( a, b ) ) {
struct cons_space_object *cell_a = &pointer2cell( a );
struct cons_space_object *cell_b = &pointer2cell( b );
switch ( cell_a->tag.value ) {
case CONSTV:
case LAMBDATV:
case NLAMBDATV:
/* TODO: it is not OK to do this on the stack since list-like
* structures can be of indefinite extent. It *must* be done by
* iteration (and even that is problematic) */
result =
equal( cell_a->payload.cons.car, cell_b->payload.cons.car )
&& equal( cell_a->payload.cons.cdr,
cell_b->payload.cons.cdr );
break;
case KEYTV:
case STRINGTV:
case SYMBOLTV:
/* slightly complex because a string may or may not have a '\0'
* cell at the end, but I'll ignore that for now. I think in
* practice only the empty string will.
*/
/* TODO: it is not OK to do this on the stack since list-like
* structures can be of indefinite extent. It *must* be done by
* iteration (and even that is problematic) */
if ( cell_a->payload.string.hash ==
cell_b->payload.string.hash ) {
wchar_t a_buff[STRING_SHIPYARD_SIZE],
b_buff[STRING_SHIPYARD_SIZE];
uint32_t tag = cell_a->tag.value;
int i = 0;
memset( a_buff, 0, sizeof( a_buff ) );
memset( b_buff, 0, sizeof( b_buff ) );
for ( ; ( i < ( STRING_SHIPYARD_SIZE - 1 ) ) && !nilp( a )
&& !nilp( b ); i++ ) {
a_buff[i] = cell_a->payload.string.character;
a = c_cdr( a );
cell_a = &pointer2cell( a );
b_buff[i] = cell_b->payload.string.character;
b = c_cdr( b );
cell_b = &pointer2cell( b );
}
#ifdef DEBUG
debug_print( L"Comparing '", DEBUG_EQUAL );
debug_print( a_buff, DEBUG_EQUAL );
debug_print( L"' to '", DEBUG_EQUAL );
debug_print( b_buff, DEBUG_EQUAL );
debug_print( L"'\n", DEBUG_EQUAL );
#endif
/* OK, now we have wchar string buffers loaded from the objects. We
* may not have exhausted either string, so the buffers being equal
* isn't sufficient. So we recurse at least once. */
result = ( wcsncmp( a_buff, b_buff, i ) == 0 )
&& equal( c_cdr( a ), c_cdr( b ) );
}
break;
case VECTORPOINTTV:
if ( cell_b->tag.value == VECTORPOINTTV ) {
result = equal_vector_vector( a, b );
} else {
result = false;
}
break;
default:
result = false;
break;
}
} else if ( numberp( a ) && numberp( b ) ) {
result = equal_number_number( a, b );
}
/*
* there's only supposed ever to be one T and one NIL cell, so each
* should be caught by eq.
*
* I'm not certain what equality means for read and write streams, so
* I'll ignore them, too, for now.
*/
debug_printf( DEBUG_EQUAL, L"\nequal returning %d\n", result );
return result;
}

36
archive/c/ops/equal.h Normal file
View file

@ -0,0 +1,36 @@
/**
* equal.h
*
* Checks for shallow and deep equality
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <math.h>
#include <stdbool.h>
#include "consspaceobject.h"
#ifndef __equal_h
#define __equal_h
/**
* size of buffer for assembling strings. Likely to be useful to
* read, too.
*/
#define STRING_SHIPYARD_SIZE 1024
/**
* Shallow, and thus cheap, equality: true if these two objects are
* the same object, else false.
*/
bool eq( struct cons_pointer a, struct cons_pointer b );
/**
* Deep, and thus expensive, equality: true if these two objects have
* identical structure, else false.
*/
bool equal( struct cons_pointer a, struct cons_pointer b );
#endif

574
archive/c/ops/intern.c Normal file
View file

@ -0,0 +1,574 @@
/*
* intern.c
*
* For now this implements an oblist and shallow binding; local environments can
* be consed onto the front of the oblist. Later, this won't do; bindings will happen
* in namespaces, which will probably be implemented as hash tables.
*
* Doctrine is that cons cells are immutable, and life is a lot more simple if they are;
* so when a symbol is rebound in the master oblist, what in fact we do is construct
* a new oblist without the previous binding but with the new binding. Anything which,
* prior to this action, held a pointer to the old oblist (as all current threads'
* environments must do) continues to hold a pointer to the old oblist, and consequently
* doesn't see the change. This is probably good but does mean you cannot use bindings
* on the oblist to signal between threads.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdbool.h>
#include <string.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include "authorise.h"
#include "debug.h"
#include "io/io.h"
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
#include "memory/hashmap.h"
#include "ops/equal.h"
#include "ops/intern.h"
#include "ops/lispops.h"
// #include "print.h"
/**
* @brief The global object list/or, to put it differently, the root namespace.
* What is added to this during system setup is 'global', that is,
* visible to all sessions/threads. What is added during a session/thread is local to
* that session/thread (because shallow binding). There must be some way for a user to
* make the contents of their own environment persistent between threads but I don't
* know what it is yet. At some stage there must be a way to rebind deep values so
* they're visible to all users/threads, but again I don't yet have any idea how
* that will work.
*/
struct cons_pointer oblist = NIL;
/**
* @brief the symbol `NIL`, which is special!
*
*/
struct cons_pointer privileged_symbol_nil = NIL;
/**
* Return a hash value for the structure indicated by `ptr` such that if
* `x`,`y` are two separate structures whose print representation is the same
* then `(sxhash x)` and `(sxhash y)` will always be equal.
*/
uint32_t sxhash( struct cons_pointer ptr ) {
// TODO: Not Yet Implemented
/* TODO: should look at the implementation of Common Lisp sxhash?
* My current implementation of `print` only addresses URL_FILE
* streams. It would be better if it also addressed strings but
* currently it doesn't. Creating a print string of the structure
* and taking the hash of that would be one simple (but not necessarily
* cheap) solution.
*/
/* TODO: sbcl's implementation of `sxhash` is in src/compiler/sxhash.lisp
* and is EXTREMELY complex, and essentially has a different dispatch for
* every type of object. It's likely we need to do the same.
*/
return 0;
}
/**
* Get the hash value for the cell indicated by this `ptr`; currently only
* implemented for string like things and integers.
*/
uint32_t get_hash( struct cons_pointer ptr ) {
struct cons_space_object *cell = &pointer2cell( ptr );
uint32_t result = 0;
switch ( cell->tag.value ) {
case INTEGERTV:
/* Note that we're only hashing on the least significant word of an
* integer. */
result = cell->payload.integer.value & 0xffffffff;
break;
case KEYTV:
case STRINGTV:
case SYMBOLTV:
result = cell->payload.string.hash;
break;
case TRUETV:
result = 1; // arbitrarily
break;
default:
result = sxhash( ptr );
break;
}
return result;
}
/**
* Free the hashmap indicated by this `pointer`.
*/
void free_hashmap( struct cons_pointer pointer ) {
struct cons_space_object *cell = &pointer2cell( pointer );
if ( hashmapp( pointer ) ) {
struct vector_space_object *vso = cell->payload.vectorp.address;
dec_ref( vso->payload.hashmap.hash_fn );
dec_ref( vso->payload.hashmap.write_acl );
for ( int i = 0; i < vso->payload.hashmap.n_buckets; i++ ) {
if ( !nilp( vso->payload.hashmap.buckets[i] ) ) {
debug_printf( DEBUG_ALLOC,
L"Decrementing bucket [%d] of hashmap at 0x%lx\n",
i, cell->payload.vectorp.address );
dec_ref( vso->payload.hashmap.buckets[i] );
}
}
} else {
debug_printf( DEBUG_ALLOC, L"Non-hashmap passed to `free_hashmap`\n" );
}
}
/**
* Make a hashmap with this number of buckets, using this `hash_fn`. If
* `hash_fn` is `NIL`, use the standard hash funtion.
*/
struct cons_pointer make_hashmap( uint32_t n_buckets,
struct cons_pointer hash_fn,
struct cons_pointer write_acl ) {
struct cons_pointer result = make_vso( HASHTV,
( sizeof( struct cons_pointer ) *
( n_buckets + 2 ) ) +
( sizeof( uint32_t ) * 2 ) );
struct hashmap_payload *payload =
( struct hashmap_payload * ) &pointer_to_vso( result )->payload;
payload->hash_fn = inc_ref( hash_fn );
payload->write_acl = inc_ref( write_acl );
payload->n_buckets = n_buckets;
for ( int i = 0; i < n_buckets; i++ ) {
payload->buckets[i] = NIL;
}
return result;
}
/**
* return a flat list of all the keys in the hashmap indicated by `map`.
*/
struct cons_pointer hashmap_keys( struct cons_pointer mapp ) {
struct cons_pointer result = NIL;
if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) ) ) {
struct vector_space_object *map = pointer_to_vso( mapp );
for ( int i = 0; i < map->payload.hashmap.n_buckets; i++ ) {
for ( struct cons_pointer c = map->payload.hashmap.buckets[i];
!nilp( c ); c = c_cdr( c ) ) {
result = make_cons( c_car( c_car( c ) ), result );
}
}
}
return result;
}
/**
* Copy all key/value pairs in this association list `assoc` into this hashmap `mapp`. If
* current user is authorised to write to this hashmap, modifies the hashmap and
* returns it; if not, clones the hashmap, modifies the clone, and returns that.
*/
struct cons_pointer hashmap_put_all( struct cons_pointer mapp,
struct cons_pointer assoc ) {
// TODO: if current user has write access to this hashmap
if ( hashmapp( mapp ) ) {
struct vector_space_object *map = pointer_to_vso( mapp );
if ( consp( assoc ) ) {
for ( struct cons_pointer pair = c_car( assoc ); !nilp( pair );
pair = c_car( assoc ) ) {
/* TODO: this is really hammering the memory management system, because
* it will make a new clone for every key/value pair added. Fix. */
if ( consp( pair ) ) {
mapp = hashmap_put( mapp, c_car( pair ), c_cdr( pair ) );
} else if ( hashmapp( pair ) ) {
hashmap_put_all( mapp, pair );
} else {
hashmap_put( mapp, pair, TRUE );
}
assoc = c_cdr( assoc );
}
} else if ( hashmapp( assoc ) ) {
for ( struct cons_pointer keys = hashmap_keys( assoc );
!nilp( keys ); keys = c_cdr( keys ) ) {
struct cons_pointer key = c_car( keys );
hashmap_put( mapp, key, hashmap_get( assoc, key, false ) );
}
}
}
return mapp;
}
/** Get a value from a hashmap.
*
* Note that this is here, rather than in memory/hashmap.c, because it is
* closely tied in with search_store, q.v.
*/
struct cons_pointer hashmap_get( struct cons_pointer mapp,
struct cons_pointer key, bool return_key ) {
#ifdef DEBUG
debug_print( L"\nhashmap_get: key is `", DEBUG_BIND );
debug_print_object( key, DEBUG_BIND );
debug_print( L"`; store of type `", DEBUG_BIND );
debug_print_object( c_type( mapp ), DEBUG_BIND );
debug_printf( DEBUG_BIND, L"`; returning `%s`.\n",
return_key ? "key" : "value" );
#endif
struct cons_pointer result = NIL;
if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) ) && !nilp( key ) ) {
struct vector_space_object *map = pointer_to_vso( mapp );
uint32_t bucket_no = get_hash( key ) % map->payload.hashmap.n_buckets;
result =
search_store( key, map->payload.hashmap.buckets[bucket_no],
return_key );
}
#ifdef DEBUG
debug_print( L"\nhashmap_get returning: `", DEBUG_BIND );
debug_print_object( result, DEBUG_BIND );
debug_print( L"`\n", DEBUG_BIND );
#endif
return result;
}
/**
* If this `ptr` is a pointer to a hashmap, return a new identical hashmap;
* else return an exception.
*/
struct cons_pointer clone_hashmap( struct cons_pointer ptr ) {
struct cons_pointer result = NIL;
if ( truep( authorised( ptr, NIL ) ) ) {
if ( hashmapp( ptr ) ) {
struct vector_space_object const *from = pointer_to_vso( ptr );
if ( from != NULL ) {
struct hashmap_payload from_pl = from->payload.hashmap;
result =
make_hashmap( from_pl.n_buckets, from_pl.hash_fn,
from_pl.write_acl );
struct vector_space_object const *to =
pointer_to_vso( result );
struct hashmap_payload to_pl = to->payload.hashmap;
for ( int i = 0; i < to_pl.n_buckets; i++ ) {
to_pl.buckets[i] = from_pl.buckets[i];
inc_ref( to_pl.buckets[i] );
}
}
}
} else {
result =
make_exception( c_string_to_lisp_string
( L"Arg to `clone_hashmap` must "
L"be a readable hashmap.`" ), NIL );
}
return result;
}
/**
* @brief `(search-store key store return-key?)` Search this `store` for this
* a key lexically identical to this `key`.
*
* If found, then, if `return-key?` is non-nil, return the copy found in the
* `store`, else return the value associated with it.
*
* At this stage the following structures are legal stores:
* 1. an association list comprising (key . value) dotted pairs;
* 2. a hashmap;
* 3. a namespace (which for these purposes is identical to a hashmap);
* 4. a hybrid list comprising both (key . value) pairs and hashmaps as first
* level items;
* 5. such a hybrid list, but where the last CDR pointer is to a hashmap
* rather than to a cons sell or to `nil`.
*
* This is over-complex and type 5 should be disallowed, but it will do for
* now.
*/
struct cons_pointer search_store( struct cons_pointer key,
struct cons_pointer store,
bool return_key ) {
struct cons_pointer result = NIL;
#ifdef DEBUG
debug_print( L"\nsearch_store; key is `", DEBUG_BIND );
debug_print_object( key, DEBUG_BIND );
debug_print( L"`; store of type `", DEBUG_BIND );
debug_print_object( c_type( store ), DEBUG_BIND );
debug_printf( DEBUG_BIND, L"`; returning `%s`.\n",
return_key ? "key" : "value" );
#endif
switch ( get_tag_value( key ) ) {
case SYMBOLTV:
case KEYTV:
struct cons_space_object *store_cell = &pointer2cell( store );
switch ( get_tag_value( store ) ) {
case CONSTV:
for ( struct cons_pointer cursor = store;
nilp( result ) && ( consp( cursor )
|| hashmapp( cursor ) );
cursor = pointer2cell( cursor ).payload.cons.cdr ) {
switch ( get_tag_value( cursor ) ) {
case CONSTV:
struct cons_pointer entry_ptr =
c_car( cursor );
switch ( get_tag_value( entry_ptr ) ) {
case CONSTV:
if ( equal( key, c_car( entry_ptr ) ) ) {
result =
return_key ? c_car( entry_ptr )
: c_cdr( entry_ptr );
goto found;
}
break;
case HASHTV:
case NAMESPACETV:
result =
hashmap_get( entry_ptr, key,
return_key );
break;
default:
result =
throw_exception
( c_string_to_lisp_symbol
( L"search-store (entry)" ),
make_cons
( c_string_to_lisp_string
( L"Unexpected store type: " ),
c_type( c_car( entry_ptr ) ) ),
NIL );
}
break;
case HASHTV:
case NAMESPACETV:
debug_print
( L"\n\tHashmap as top-level value in list",
DEBUG_BIND );
result =
hashmap_get( cursor, key, return_key );
break;
default:
result =
throw_exception( c_string_to_lisp_symbol
( L"search-store (cursor)" ),
make_cons
( c_string_to_lisp_string
( L"Unexpected store type: " ),
c_type( cursor ) ),
NIL );
}
}
break;
case HASHTV:
case NAMESPACETV:
result = hashmap_get( store, key, return_key );
break;
default:
result =
throw_exception( c_string_to_lisp_symbol
( L"search-store (store)" ),
make_cons( c_string_to_lisp_string
( L"Unexpected store type: " ),
c_type( store ) ), NIL );
break;
}
break;
case EXCEPTIONTV:
result =
throw_exception( c_string_to_lisp_symbol
( L"search-store (exception)" ),
make_cons( c_string_to_lisp_string
( L"Unexpected key type: " ),
c_type( key ) ), NIL );
break;
default:
result =
throw_exception( c_string_to_lisp_symbol
( L"search-store (key)" ),
make_cons( c_string_to_lisp_string
( L"Unexpected key type: " ),
c_type( key ) ), NIL );
}
found:
debug_print( L"search-store: returning `", DEBUG_BIND );
debug_print_object( result, DEBUG_BIND );
debug_print( L"`\n", DEBUG_BIND );
return result;
}
struct cons_pointer interned( struct cons_pointer key,
struct cons_pointer store ) {
return search_store( key, store, true );
}
/**
* @brief Implementation of `interned?` in C.
*
* @param key the key to search for.
* @param store the store to search in.
* @return struct cons_pointer `t` if the key was found, else `nil`.
*/
struct cons_pointer internedp( struct cons_pointer key,
struct cons_pointer store ) {
struct cons_pointer result = NIL;
if ( consp( store ) ) {
for ( struct cons_pointer pair = c_car( store );
eq( result, NIL ) && !nilp( pair ); pair = c_car( store ) ) {
if ( consp( pair ) ) {
if ( equal( c_car( pair ), key ) ) {
// yes, this should be `eq`, but if symbols are correctly
// interned this will work efficiently, and if not it will
// still work.
result = TRUE;
}
} else if ( hashmapp( pair ) ) {
result = internedp( key, pair );
}
store = c_cdr( store );
}
} else if ( hashmapp( store ) ) {
struct vector_space_object *map = pointer_to_vso( store );
for ( int i = 0; i < map->payload.hashmap.n_buckets; i++ ) {
for ( struct cons_pointer c = map->payload.hashmap.buckets[i];
!nilp( c ); c = c_cdr( c ) ) {
result = internedp( key, c );
}
}
}
return result;
}
/**
* Implementation of assoc in C. Like interned?, the final implementation will
* deal with stores which can be association lists or hashtables or hybrids of
* the two, but that will almost certainly be implemented in lisp.
*
* If this key is lexically identical to a key in this store, return the value
* of that key from the store; otherwise return NIL.
*/
struct cons_pointer c_assoc( struct cons_pointer key,
struct cons_pointer store ) {
return search_store( key, store, false );
}
/**
* Store this `val` as the value of this `key` in this hashmap `mapp`. If
* current user is authorised to write to this hashmap, modifies the hashmap and
* returns it; if not, clones the hashmap, modifies the clone, and returns that.
*/
struct cons_pointer hashmap_put( struct cons_pointer mapp,
struct cons_pointer key,
struct cons_pointer val ) {
if ( hashmapp( mapp ) && !nilp( key ) ) {
struct vector_space_object *map = pointer_to_vso( mapp );
if ( nilp( authorised( mapp, map->payload.hashmap.write_acl ) ) ) {
mapp = clone_hashmap( mapp );
map = pointer_to_vso( mapp );
}
uint32_t bucket_no = get_hash( key ) % map->payload.hashmap.n_buckets;
// TODO: if there are too many values in the bucket, rehash the whole
// hashmap to a bigger number of buckets, and return that.
map->payload.hashmap.buckets[bucket_no] =
make_cons( make_cons( key, val ),
map->payload.hashmap.buckets[bucket_no] );
}
debug_print( L"hashmap_put:\n", DEBUG_BIND );
debug_dump_object( mapp, DEBUG_BIND );
return mapp;
}
/**
* If this store is modifiable, add this key value pair to it. Otherwise,
* return a new key/value store containing all the key/value pairs in this
* store with this key/value pair added to the front.
*/
struct cons_pointer set( struct cons_pointer key, struct cons_pointer value,
struct cons_pointer store ) {
struct cons_pointer result = NIL;
#ifdef DEBUG
bool deep = eq( store, oblist );
debug_print_binding( key, value, deep, DEBUG_BIND );
if ( deep ) {
debug_printf( DEBUG_BIND, L"\t-> %4.4s\n",
pointer2cell( store ).payload.vectorp.tag.bytes );
}
#endif
if ( nilp( store ) || consp( store ) ) {
result = make_cons( make_cons( key, value ), store );
} else if ( hashmapp( store ) ) {
result = hashmap_put( store, key, value );
}
return result;
}
/**
* @brief Binds this `key` to this `value` in the global oblist, and returns the `key`.
*/
struct cons_pointer
deep_bind( struct cons_pointer key, struct cons_pointer value ) {
debug_print( L"Entering deep_bind\n", DEBUG_BIND );
oblist = set( key, value, oblist );
debug_print( L"deep_bind returning ", DEBUG_BIND );
debug_print_object( key, DEBUG_BIND );
debug_println( DEBUG_BIND );
return key;
}
/**
* Ensure that a canonical copy of this key is bound in this environment, and
* return that canonical copy. If there is currently no such binding, create one
* with the value TRUE.
*/
struct cons_pointer
intern( struct cons_pointer key, struct cons_pointer environment ) {
struct cons_pointer result = environment;
struct cons_pointer canonical = internedp( key, environment );
if ( nilp( canonical ) ) {
/*
* not currently bound. TODO: this should bind to NIL?
*/
result = set( key, TRUE, environment );
}
return result;
}

81
archive/c/ops/intern.h Normal file
View file

@ -0,0 +1,81 @@
/*
* intern.h
*
* For now this implements an oblist and shallow binding; local environments can
* be consed onto the front of the oblist. Later, this won't do; bindings will happen
* in namespaces, which will probably be implemented as hash tables.
*
* Doctrine is that cons cells are immutable, and life is a lot more simple if they are;
* so when a symbol is rebound in the master oblist, what in fact we do is construct
* a new oblist without the previous binding but with the new binding. Anything which,
* prior to this action, held a pointer to the old oblist (as all current threads'
* environments must do) continues to hold a pointer to the old oblist, and consequently
* doesn't see the change. This is probably good but does mean you cannot use bindings
* on the oblist to signal between threads.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __intern_h
#define __intern_h
#include <stdbool.h>
extern struct cons_pointer privileged_symbol_nil;
extern struct cons_pointer oblist;
uint32_t get_hash( struct cons_pointer ptr );
void free_hashmap( struct cons_pointer ptr );
void dump_map( URL_FILE * output, struct cons_pointer pointer );
struct cons_pointer hashmap_get( struct cons_pointer mapp,
struct cons_pointer key, bool return_key );
struct cons_pointer hashmap_put( struct cons_pointer mapp,
struct cons_pointer key,
struct cons_pointer val );
struct cons_pointer hashmap_put_all( struct cons_pointer mapp,
struct cons_pointer assoc );
struct cons_pointer hashmap_keys( struct cons_pointer map );
struct cons_pointer make_hashmap( uint32_t n_buckets,
struct cons_pointer hash_fn,
struct cons_pointer write_acl );
struct cons_pointer search_store( struct cons_pointer key,
struct cons_pointer store, bool return_key );
struct cons_pointer c_assoc( struct cons_pointer key,
struct cons_pointer store );
struct cons_pointer interned( struct cons_pointer key,
struct cons_pointer environment );
struct cons_pointer internedp( struct cons_pointer key,
struct cons_pointer environment );
struct cons_pointer hashmap_put( struct cons_pointer mapp,
struct cons_pointer key,
struct cons_pointer val );
struct cons_pointer set( struct cons_pointer key,
struct cons_pointer value,
struct cons_pointer store );
struct cons_pointer deep_bind( struct cons_pointer key,
struct cons_pointer value );
struct cons_pointer intern( struct cons_pointer key,
struct cons_pointer environment );
struct cons_pointer internedp( struct cons_pointer key,
struct cons_pointer store );
#endif

1840
archive/c/ops/lispops.c Normal file
View file

File diff suppressed because it is too large Load diff

250
archive/c/ops/lispops.h Normal file
View file

@ -0,0 +1,250 @@
/**
* lispops.h
*
* List processing operations.
*
* The general idea here is that a list processing operation is a
* function which takes two arguments, both cons_pointers:
*
* 1. args, the argument list to this function;
* 2. env, the environment in which this function should be evaluated;
*
* and returns a cons_pointer, the result.
*
* They must all have the same signature so that I can call them as
* function pointers.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __psse_lispops_h
#define __psse_lispops_h
extern struct cons_pointer prompt_name;
/*
* utilities
*/
struct cons_pointer c_keys( struct cons_pointer store );
struct cons_pointer c_reverse( struct cons_pointer arg );
struct cons_pointer c_progn( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer expressions,
struct cons_pointer env );
/**
* Useful building block; evaluate this single form in the context of this
* parent stack frame and this environment.
* @param parent the parent stack frame.
* @param form the form to be evaluated.
* @param env the evaluation environment.
* @return the result of evaluating the form.
*/
struct cons_pointer eval_form( struct stack_frame *parent,
struct cons_pointer parent_pointer,
struct cons_pointer form,
struct cons_pointer env );
/**
* eval all the forms in this `list` in the context of this stack `frame`
* and this `env`, and return a list of their values. If the arg passed as
* `list` is not in fact a list, return nil.
*/
struct cons_pointer eval_forms( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer list,
struct cons_pointer env );
/*
* special forms
*/
struct cons_pointer lisp_eval( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_apply( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_keys( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_oblist( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_set( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_set_shriek( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
/**
* Construct an interpretable function.
*
* @param frame the stack frame in which the expression is to be interpreted;
* @param lexpr the lambda expression to be interpreted;
* @param env the environment in which it is to be intepreted.
*/
struct cons_pointer lisp_lambda( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_length( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
/**
* Construct an interpretable special form.
*
* @param frame the stack frame in which the expression is to be interpreted;
* @param env the environment in which it is to be intepreted.
*/
struct cons_pointer lisp_nlambda( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_quote( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
/*
* functions
*/
struct cons_pointer lisp_assoc( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_cons( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_car( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_cdr( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_inspect( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_internedp( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_eq( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_equal( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_read( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_repl( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_reverse( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer
lisp_count( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
/**
* Function: Get the Lisp type of the single argument.
* @param frame My stack frame.
* @param env My environment (ignored).
* @return As a Lisp string, the tag of the object which is the argument.
*/
struct cons_pointer lisp_type( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
/**
* Function; evaluate the forms which are listed in my single argument
* sequentially and return the value of the last. This function is called 'do'
* in some dialects of Lisp.
*
* @param frame My stack frame.
* @param env My environment (ignored).
* @return the value of the last form on the sequence which is my single
* argument.
*/
struct cons_pointer lisp_progn( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
/**
* Special form: conditional. Each arg is expected to be a list; if the first
* item in such a list evaluates to non-NIL, the remaining items in that list
* are evaluated in turn and the value of the last returned. If no arg (clause)
* has a first element which evaluates to non NIL, then NIL is returned.
* @param frame My stack frame.
* @param env My environment (ignored).
* @return the value of the last form of the first successful clause.
*/
struct cons_pointer lisp_cond( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer throw_exception_with_cause( struct cons_pointer location,
struct cons_pointer message,
struct cons_pointer cause,
struct cons_pointer
frame_pointer );
/**
* Throw an exception.
* `throw_exception` is a misnomer, because it doesn't obey the calling
* signature of a lisp function; but it is nevertheless to be preferred to
* make_exception. A real `throw_exception`, which does, will be needed.
*/
struct cons_pointer throw_exception( struct cons_pointer location,
struct cons_pointer message,
struct cons_pointer frame_pointer );
struct cons_pointer lisp_exception( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_source( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 );
struct cons_pointer lisp_append( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_mapcar( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_list( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_let( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_try( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_and( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_or( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_not( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
#endif

50
archive/c/ops/loop.c Normal file
View file

@ -0,0 +1,50 @@
/*
* loop.c
*
* Iteration functions. This has *a lot* of similarity to try/catch --
* essentially what `recur` does is throw a special purpose exception which is
* caught by `loop`.
*
* Essentially the syntax I want is
*
* (defun expt (n e)
* (loop ((n1 . n) (r . n) (e1 . e))
* (cond ((= e 0) r)
* (t (recur n1 (* n1 r) (- e 1)))))
*
* It might in future be good to allow the body of the loop to comprise many
* expressions, like a `progn`, but for now if you want that you can just
* shove a `progn` in. Note that, given that what `recur` is essentially
* doing is throwing a special purpose exception, the `recur` expression
* doesn't actually have to be in the same function as the `loop` expression.
*
* (c) 2021 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include "consspaceobject.h"
#include "lispops.h"
#include "loop.h"
/**
* Special form, not dissimilar to `let`. Essentially,
*
* 1. the first arg (`args`) is an assoc list;
* 2. the second arg (`body`) is an expression.
*
* Each of the vals in the assoc list is evaluated, and bound to its
* respective key in a new environment. The body is then evaled in that
* environment. If the result is an object of type LOOP, it should carry
* a list of values of the same arity as args. Each of the keys in args
* is then rebound in a new environment to the respective value from the
* LOOP object, and body is then re-evaled in that environment.
*
* If the result is not a LOOP object, it is simply returned.
*/
struct cons_pointer
lisp_loop( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer keys = c_keys( frame->arg[0] );
struct cons_pointer body = frame->arg[1];
}

10
archive/c/ops/loop.h Normal file
View file

@ -0,0 +1,10 @@
/*
* loop.h
*
* Iteration functions. This has *a lot* of similarity to try/catch --
* essentially what `recur` does is throw a special purpose exception which is
* caught by `loop`.
*
* (c) 2021 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/

45
archive/c/ops/meta.c Normal file
View file

@ -0,0 +1,45 @@
/*
* meta.c
*
* Get metadata from a cell which has it.
*
* (c) 2019 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include "memory/conspage.h"
#include "debug.h"
/**
* Function: get metadata describing my first argument.
*
* * (metadata any)
*
* @return a pointer to the metadata of my first argument, or nil if none.
*/
struct cons_pointer lisp_metadata( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
debug_print( L"lisp_metadata: entered\n", DEBUG_EVAL );
debug_dump_object( frame->arg[0], DEBUG_EVAL );
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( frame->arg[0] );
switch ( cell.tag.value ) {
case FUNCTIONTV:
result = cell.payload.function.meta;
break;
case SPECIALTV:
result = cell.payload.special.meta;
break;
case READTV:
case WRITETV:
result = cell.payload.stream.meta;
break;
}
return make_cons( make_cons( c_string_to_lisp_keyword( L"type" ),
c_type( frame->arg[0] ) ), result );
// return result;
}

18
archive/c/ops/meta.h Normal file
View file

@ -0,0 +1,18 @@
/*
* meta.h
*
* Get metadata from a cell which has it.
*
* (c) 2019 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __psse_meta_h
#define __psse_meta_h
struct cons_pointer lisp_metadata( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
#endif

72
src/c/io/read.c Normal file
View file

@ -0,0 +1,72 @@
/**
* read.c
*
* Read basic Lisp objects..This is :bootstrap layer print; it needs to be
* able to read characters, symbols, integers, lists and dotted pairs. I
* don't think it needs to be able to read anything else. It must, however,
* take a readtable as argument and expand reader macros.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <math.h>
#include <stdbool.h>
#include <stdint.h>
#include <stdio.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include "debug.h"
#include "memory/node.h"
#include "memory/pointer.h"
#include "memory/pso2.h"
#include "io/io.h"
#include "io/read.h"
#include "payloads/integer.h"
#include "ops/stack_ops.h"
// TODO: what I've copied from 0.0.6 is *wierdly* over-complex for just now.
// I think I'm going to essentially delete all this and start again. We need
// to be able to despatch on readttables, and the initial readtable functions
// don't need to be written in Lisp.
//
// In the long run a readtable ought to be a hashtable, but for now an assoc
// list will do.
//
// A readtable function is a Lisp function so needs the stackframe and the
// environment. Other arguments (including the output stream) should be passed
// in the argument, so I think the first arg in the frame is the character read;
// the next is the input stream; the next is the readtable, if any.
/*
* for the time being things which may be read are:
* * integers
* * lists
* * atoms
* * dotted pairs
*/
/**
* An example wrapper function while I work out how I'm going to do this.
*/
struct pso_pointer read_example( struct pso4 *frame,
struct pso_pointer frame_pointer,
struct pso_pointer env) {
struct pso_pointer character = fetch_arg( frame, 0);
struct pso_pointer stream = fetch_arg( frame, 1);
struct pso_pointer readtable = fetch_arg( frame, 2);
return character;
}
// struct pso_pointer read

92
src/c/ops/assoc.c Normal file
View file

@ -0,0 +1,92 @@
/**
* ops/assoc.c
*
* Post Scarcity Software Environment: assoc.
*
* Search a store for the value associated with a key.
*
* (c) 2026 Simon Brooke <simon@journeyman.cc>
* 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 "memory/pso2.h"
#include "memory/tags.h"
#include "payloads/cons.h"
#include "ops/eq.h"
#include "ops/truth.h"
/**
* @brief: fundamental search function; only knows about association lists
*
* @param key a pointer indicating the key to search for;
* @param store a pointer indicating the store to search;
* @param return_key if a binding is found for `key` in `store`, if true
* return the key found in the store, else return the value
*
* @return nil if no binding for `key` is found in `store`; otherwise, if
* `return_key` is true, return the key from the store; else
* return the binding.
*/
struct pso_pointer search( struct pso_pointer key,
struct pso_pointer store,
bool return_key ) {
struct pso_pointer result = nil;
bool found = false;
if (consp( store)) {
for ( struct pso_pointer cursor = store;
consp( store) && found == false;
cursor = cdr( cursor)) {
struct pso_pointer pair = car( cursor);
if (consp(pair) && equal(car(pair), key)) {
found = true;
result = return_key ? car(pair) : cdr( pair);
}
}
}
return result;
}
/**
* @prief: bootstap layer assoc; only knows about association lists.
*
* @param key a pointer indicating the key to search for;
* @param store a pointer indicating the store to search;
*
* @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) {
return search( key, store, false);
}
/**
* @prief: bootstap layer interned; only knows about association lists.
*
* @param key a pointer indicating the key to search for;
* @param store a pointer indicating the store to search;
*
* @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) {
return search( key, store, true);
}
/**
* @prief: bootstap layer interned; only knows about association lists.
*
* @param key a pointer indicating the key to search for;
* @param store a pointer indicating the store to search;
*
* @return `true` if a pointer the key was found in the store..
*/
bool internedp(struct pso_pointer key, struct pso_pointer store) {
return !nilp( search( key, store, true));
}

28
src/c/ops/assoc.h Normal file
View file

@ -0,0 +1,28 @@
/**
* ops/assoc.h
*
* Post Scarcity Software Environment: assoc.
*
* Search a store for the value associated with a key.
*
* (c) 2026 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __psse_ops_assoc_h
#define __psse_ops_assoc_h
#include <stdbool.h>
#include "memory/pointer.h"
struct cons_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 interned(struct pso_pointer key, struct pso_pointer store);
bool internedp(struct pso_pointer key, struct pso_pointer store);
#endif

55
src/c/ops/reverse.c Normal file
View file

@ -0,0 +1,55 @@
/**
* ops/reverse.c
*
* Post Scarcity Software Environment: reverse.
*
* Reverse a sequence. Didn'e want to do this in the substrate, but I need
* if for reading atoms!.
*
* (c) 2026 Simon Brooke <simon@journeyman.cc>
* 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 "memory/pso.h"
#include "memory/pso2.h"
#include "memory/tags.h"
#include "payloads/cons.h"
#include "payloads/exception.h"
#include "payloads/psse_string.h"
#include "ops/string_ops.h"
#include "ops/truth.h"
struct pso_pointer reverse( struct pso_pointer sequence) {
struct pso_pointer result = nil;
for (struct pso_pointer cursor = sequence; !nilp( sequence); cursor = cdr(cursor)) {
struct pso2* object = pointer_to_object( cursor);
switch (get_tag_value(cursor)) {
case CONSTV :
result = cons( car(cursor), result);
break;
case KEYTV :
result = make_string_like_thing( object->payload.string.character, result, KEYTAG);
break;
case STRINGTV :
result = make_string_like_thing( object->payload.string.character, result, STRINGTAG);
break;
case SYMBOLTV :
result = make_string_like_thing( object->payload.string.character, result, SYMBOLTAG);
break;
default :
result = make_exception( c_string_to_lisp_string(L"Invalid object in sequence"), nil, nil);
goto exit;
break;
}
}
exit:
return result;
}

21
src/c/ops/reverse.h Normal file
View file

@ -0,0 +1,21 @@
/**
* ops/reverse.h
*
* Post Scarcity Software Environment: reverse.
*
* Reverse a sequence.
*
* (c) 2026 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __psse_ops_reverse_h
#define __psse_ops_reverse_h
#include <stdbool.h>
#include "memory/pointer.h"
struct pso_pointer reverse( struct pso_pointer sequence);
#endif

66
src/c/payloads/stack.c Normal file
View file

@ -0,0 +1,66 @@
/**
* payloads/stack.h
*
* a Lisp stack frame.
*
* Sits in a pso4.
*
* (c) 2026 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdarg.h>
#include "memory/node.h"
#include "memory/pointer.h"
#include "memory/pso.h"
#include "memory/pso2.h"
#include "memory/pso4.h"
#include "memory/tags.h"
/**
* @brief Construct a stack frame with this `previous` pointer, and arguments
* taken from the remaining arguments to this function, which should all be
* struct pso_pointer.
*
* @return a pso_pointer to the stack frame.
*/
struct pso_pointer make_frame( struct pso_pointer previous, ...) {
va_list args;
va_start(args, previous);
int count = va_arg(args, int);
struct pso_pointer frame_pointer = allocate( STACKTAG, 4);
struct pso4* frame = (struct pso4*)pointer_to_object( frame_pointer);
frame->payload.stack_frame.previous = previous;
// I *think* the count starts with the number of args, so there are
// one fewer actual args. Need to test to verify this!
count --;
int cursor = 0;
frame->payload.stack_frame.args = count;
for ( ; cursor < count && cursor < args_in_frame; cursor++) {
struct pso_pointer argument = va_arg( args, struct pso_pointer);
frame->payload.stack_frame.arg[cursor] = argument;
}
if ( cursor < count) {
struct pso_pointer more_args = nil;
for (; cursor < count; cursor++) {
more_args = cons( va_arg( args, struct pso_pointer), more_args);
}
// should be frame->payload.stack_frame.more = reverse( more_args), but
// we don't have reverse yet. TODO: fix.
frame->payload.stack_frame.more = more_args;
} else {
for (; cursor < args_in_frame; cursor++) {
frame->payload.stack_frame.arg[cursor] = nil;
}
}
return frame_pointer;
}