From a302663b324c8aa099a1254cdf89b55066048a42 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 31 Mar 2026 20:09:37 +0100 Subject: [PATCH] Well, I really made a mess with the last commit; this one sorts it out. --- archive/c/ops/equal.c | 433 +++++++++ archive/c/ops/equal.h | 36 + archive/c/ops/intern.c | 574 ++++++++++++ archive/c/ops/intern.h | 81 ++ archive/c/ops/lispops.c | 1840 +++++++++++++++++++++++++++++++++++++++ archive/c/ops/lispops.h | 250 ++++++ archive/c/ops/loop.c | 50 ++ archive/c/ops/loop.h | 10 + archive/c/ops/meta.c | 45 + archive/c/ops/meta.h | 18 + src/c/io/read.c | 72 ++ src/c/ops/assoc.c | 92 ++ src/c/ops/assoc.h | 28 + src/c/ops/reverse.c | 55 ++ src/c/ops/reverse.h | 21 + src/c/payloads/stack.c | 66 ++ 16 files changed, 3671 insertions(+) create mode 100644 archive/c/ops/equal.c create mode 100644 archive/c/ops/equal.h create mode 100644 archive/c/ops/intern.c create mode 100644 archive/c/ops/intern.h create mode 100644 archive/c/ops/lispops.c create mode 100644 archive/c/ops/lispops.h create mode 100644 archive/c/ops/loop.c create mode 100644 archive/c/ops/loop.h create mode 100644 archive/c/ops/meta.c create mode 100644 archive/c/ops/meta.h create mode 100644 src/c/io/read.c create mode 100644 src/c/ops/assoc.c create mode 100644 src/c/ops/assoc.h create mode 100644 src/c/ops/reverse.c create mode 100644 src/c/ops/reverse.h create mode 100644 src/c/payloads/stack.c diff --git a/archive/c/ops/equal.c b/archive/c/ops/equal.c new file mode 100644 index 0000000..296aea6 --- /dev/null +++ b/archive/c/ops/equal.c @@ -0,0 +1,433 @@ +/* + * equal.c + * + * Checks for shallow and deep equality + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include + +#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; +} diff --git a/archive/c/ops/equal.h b/archive/c/ops/equal.h new file mode 100644 index 0000000..061eb94 --- /dev/null +++ b/archive/c/ops/equal.h @@ -0,0 +1,36 @@ +/** + * equal.h + * + * Checks for shallow and deep equality + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include + +#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 diff --git a/archive/c/ops/intern.c b/archive/c/ops/intern.c new file mode 100644 index 0000000..989686b --- /dev/null +++ b/archive/c/ops/intern.c @@ -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 + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +/* + * wide characters + */ +#include +#include + +#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; +} diff --git a/archive/c/ops/intern.h b/archive/c/ops/intern.h new file mode 100644 index 0000000..0b8f657 --- /dev/null +++ b/archive/c/ops/intern.h @@ -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 + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __intern_h +#define __intern_h + +#include + + +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 diff --git a/archive/c/ops/lispops.c b/archive/c/ops/lispops.c new file mode 100644 index 0000000..a9dd7ea --- /dev/null +++ b/archive/c/ops/lispops.c @@ -0,0 +1,1840 @@ +/* + * lispops.c + * + * 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 + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include +#include +#include + +#include "arith/integer.h" +#include "arith/peano.h" +#include "debug.h" +#include "io/io.h" +#include "io/print.h" +#include "io/read.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" +#include "memory/stack.h" +#include "memory/vectorspace.h" +#include "memory/dump.h" +#include "ops/equal.h" +#include "ops/intern.h" +#include "ops/lispops.h" + +/** + * @brief the name of the symbol to which the prompt is bound; + * + * Set in init to `*prompt*` + */ +struct cons_pointer prompt_name; + +/* + * also to create in this section: + * struct cons_pointer lisp_let( struct cons_pointer args, struct cons_pointer env, + * struct stack_frame* frame); + * + * and others I haven't thought of yet. + */ + +/** + * 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 ) { + debug_print( L"eval_form: ", DEBUG_EVAL ); + debug_print_object( form, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); + + struct cons_pointer result = form; + switch ( pointer2cell( form ).tag.value ) { + /* things which evaluate to themselves */ + case EXCEPTIONTV: + case FREETV: // shouldn't happen, but anyway... + case INTEGERTV: + case KEYTV: + case LOOPTV: // don't think this should happen... + case NILTV: + case RATIOTV: + case REALTV: + case READTV: + case STRINGTV: + case TIMETV: + case TRUETV: + case WRITETV: + break; + default: + { + struct cons_pointer next_pointer = + make_empty_frame( parent_pointer ); + + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct stack_frame *next = get_stack_frame( next_pointer ); + set_reg( next, 0, form ); + next->args = 1; + + result = lisp_eval( next, next_pointer, env ); + + if ( !exceptionp( result ) ) { + /* if we're returning an exception, we should NOT free the + * stack frame. Corollary is, when we free an exception, we + * should free all the frames it's holding on to. */ + dec_ref( next_pointer ); + } + } + } + break; + } + + debug_print( L"eval_form ", DEBUG_EVAL ); + debug_print_object( form, DEBUG_EVAL ); + debug_print( L" returning: ", DEBUG_EVAL ); + debug_print_object( result, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); + + return result; +} + +/** + * Evaluate 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. + * @param frame the stack frame. + * @param list the list of forms to be evaluated. + * @param env the evaluation environment. + * @return a list of the the results of evaluating the forms. + */ +struct cons_pointer eval_forms( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer list, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + + while ( consp( list ) ) { + result = + make_cons( eval_form( frame, frame_pointer, c_car( list ), env ), + result ); + list = c_cdr( list ); + } + + return c_reverse( result ); +} + +/** + * OK, the idea here (and I know this is less than perfect) is that the basic `try` + * special form in PSSE takes two arguments, the first, `body`, being a list of forms, + * and the second, `catch`, being a catch handler (which is also a list of forms). + * Forms from `body` are evaluated in turn until one returns an exception object, + * or until the list is exhausted. If the list was exhausted, then the value of + * evaluating the last form in `body` is returned. If an exception was encountered, + * then each of the forms in `catch` is evaluated and the value of the last of + * those is returned. + * + * This is experimental. It almost certainly WILL change. + */ +struct cons_pointer lisp_try( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = + c_progn( frame, frame_pointer, frame->arg[0], env ); + + if ( exceptionp( result ) ) { + // TODO: need to put the exception into the environment! + result = c_progn( frame, frame_pointer, frame->arg[1], + make_cons( make_cons + ( c_string_to_lisp_symbol + ( L"*exception*" ), result ), env ) ); + } + + return result; +} + + +/** + * Return the object list (root namespace). + * + * * (oblist) + * + * @param frame the stack frame in which the expression is to be interpreted; + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the root namespace. + */ +struct cons_pointer +lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return oblist; +} + +/** + * Used to construct the body for `lambda` and `nlambda` expressions. + */ +struct cons_pointer compose_body( struct stack_frame *frame ) { + struct cons_pointer body = frame->more; + + for ( int i = args_in_frame - 1; i > 0; i-- ) { + if ( !nilp( body ) ) { + body = make_cons( frame->arg[i], body ); + } else if ( !nilp( frame->arg[i] ) ) { + body = make_cons( frame->arg[i], body ); + } + } + + debug_print( L"compose_body returning ", DEBUG_LAMBDA ); + debug_dump_object( body, DEBUG_LAMBDA ); + + return body; +} + +/** + * Construct an interpretable function. *NOTE* that if `args` is a single symbol + * rather than a list, a varargs function will be created. + * + * (lambda args body) + * + * @param frame the stack frame in which the expression is to be interpreted; + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment in which it is to be intepreted. + * @return an interpretable function with these `args` and this `body`. + */ +struct cons_pointer +lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return make_lambda( frame->arg[0], compose_body( frame ) ); +} + +/** + * Construct an interpretable special form. *NOTE* that if `args` is a single symbol + * rather than a list, a varargs special form will be created. + * + * (nlambda args body) + * + * @param frame the stack frame in which the expression is to be interpreted; + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment in which it is to be intepreted. + * @return an interpretable special form with these `args` and this `body`. + */ +struct cons_pointer +lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return make_nlambda( frame->arg[0], compose_body( frame ) ); +} + + +/** + * Evaluate a lambda or nlambda expression. + */ +struct cons_pointer +eval_lambda( struct cons_space_object *cell, struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ) { + struct cons_pointer result = NIL; +#ifdef DEBUG + debug_print( L"eval_lambda called\n", DEBUG_LAMBDA ); + debug_println( DEBUG_LAMBDA ); +#endif + + struct cons_pointer new_env = env; + struct cons_pointer names = cell->payload.lambda.args; + struct cons_pointer body = cell->payload.lambda.body; + + if ( consp( names ) ) { + /* if `names` is a list, bind successive items from that list + * to values of arguments */ + for ( int i = 0; i < frame->args && consp( names ); i++ ) { + struct cons_pointer name = c_car( names ); + struct cons_pointer val = frame->arg[i]; + + new_env = set( name, val, new_env ); + debug_print_binding( name, val, false, DEBUG_BIND ); + + names = c_cdr( names ); + } + + /* \todo if there's more than `args_in_frame` arguments, bind those too. */ + } else if ( symbolp( names ) ) { + /* if `names` is a symbol, rather than a list of symbols, + * then bind a list of the values of args to that symbol. */ + /* \todo eval all the things in frame->more */ + struct cons_pointer vals = + eval_forms( frame, frame_pointer, frame->more, env ); + + for ( int i = args_in_frame - 1; i >= 0; i-- ) { + struct cons_pointer val = + eval_form( frame, frame_pointer, frame->arg[i], env ); + + if ( nilp( val ) && nilp( vals ) ) { /* nothing */ + } else { + vals = make_cons( val, vals ); + } + } + + new_env = set( names, vals, new_env ); + } + + while ( !nilp( body ) ) { + struct cons_pointer sexpr = c_car( body ); + body = c_cdr( body ); + + debug_print( L"In lambda: evaluating ", DEBUG_LAMBDA ); + debug_print_object( sexpr, DEBUG_LAMBDA ); + // debug_print( L"\t env is: ", DEBUG_LAMBDA ); + // debug_print_object( new_env, DEBUG_LAMBDA ); + debug_println( DEBUG_LAMBDA ); + + /* if a result is not the terminal result in the lambda, it's a + * side effect, and needs to be GCed */ + dec_ref( result ); + + result = eval_form( frame, frame_pointer, sexpr, new_env ); + + if ( exceptionp( result ) ) { + break; + } + } + + // TODO: I think we do need to dec_ref everything on new_env back to env + // dec_ref( new_env ); + + debug_print( L"eval_lambda returning: \n", DEBUG_LAMBDA ); + debug_print_object( result, DEBUG_LAMBDA ); + debug_println( DEBUG_LAMBDA ); + + return result; +} + +/** + * if `r` is an exception, and it doesn't have a location, fix up its location from + * the name associated with this fn_pointer, if any. + */ +struct cons_pointer maybe_fixup_exception_location( struct cons_pointer r, + struct cons_pointer + fn_pointer ) { + struct cons_pointer result = r; + + if ( exceptionp( result ) + && ( functionp( fn_pointer ) || specialp( fn_pointer ) ) ) { + struct cons_space_object *fn_cell = &pointer2cell( fn_pointer ); + + struct cons_pointer payload = + pointer2cell( result ).payload.exception.payload; + + switch ( get_tag_value( payload ) ) { + case NILTV: + case CONSTV: + case HASHTV: + { + if ( nilp( c_assoc( privileged_keyword_location, + payload ) ) ) { + pointer2cell( result ).payload.exception.payload = + set( privileged_keyword_location, + c_assoc( privileged_keyword_name, + fn_cell->payload.function.meta ), + payload ); + } + } + break; + default: + pointer2cell( result ).payload.exception.payload = + make_cons( make_cons( privileged_keyword_location, + c_assoc( privileged_keyword_name, + fn_cell->payload.function. + meta ) ), + make_cons( make_cons + ( privileged_keyword_payload, + payload ), NIL ) ); + } + } + + return result; +} + + +/** + * Internal guts of apply. + * @param frame the stack frame, expected to have only one argument, a list + * comprising something that evaluates to a function and its arguments. + * @param env The evaluation environment. + * @return the result of evaluating the function with its arguments. + */ +struct cons_pointer +c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + debug_print( L"Entering c_apply\n", DEBUG_EVAL ); + struct cons_pointer result = NIL; + + struct cons_pointer fn_pointer = + eval_form( frame, frame_pointer, c_car( frame->arg[0] ), env ); + + if ( exceptionp( fn_pointer ) ) { + result = fn_pointer; + } else { + struct cons_space_object *fn_cell = &pointer2cell( fn_pointer ); + struct cons_pointer args = c_cdr( frame->arg[0] ); + + switch ( get_tag_value( fn_pointer ) ) { + case EXCEPTIONTV: + /* just pass exceptions straight back */ + result = fn_pointer; + break; + + case FUNCTIONTV: + { + struct cons_pointer exep = NIL; + struct cons_pointer next_pointer = + make_stack_frame( frame_pointer, args, env ); + + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct stack_frame *next = + get_stack_frame( next_pointer ); + + result = maybe_fixup_exception_location( ( * + ( fn_cell->payload.function.executable ) ) + ( next, + next_pointer, + env ), + fn_pointer ); + dec_ref( next_pointer ); + } + } + break; + + case KEYTV: + result = c_assoc( fn_pointer, + eval_form( frame, + frame_pointer, + c_car( c_cdr( frame->arg[0] ) ), + env ) ); + break; + + case LAMBDATV: + { + struct cons_pointer exep = NIL; + struct cons_pointer next_pointer = + make_stack_frame( frame_pointer, args, env ); + + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct stack_frame *next = + get_stack_frame( next_pointer ); + result = + eval_lambda( fn_cell, next, next_pointer, env ); + if ( !exceptionp( result ) ) { + dec_ref( next_pointer ); + } + } + } + break; + + case HASHTV: + /* \todo: if arg[0] is a CONS, treat it as a path */ + result = c_assoc( eval_form( frame, + frame_pointer, + c_car( c_cdr + ( frame->arg + [0] ) ), env ), + fn_pointer ); + break; + + case NLAMBDATV: + { + struct cons_pointer next_pointer = + make_special_frame( frame_pointer, args, env ); + + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct stack_frame *next = + get_stack_frame( next_pointer ); + result = + eval_lambda( fn_cell, next, next_pointer, env ); + dec_ref( next_pointer ); + } + } + break; + + case SPECIALTV: + { + struct cons_pointer next_pointer = + make_special_frame( frame_pointer, args, env ); + + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + result = maybe_fixup_exception_location( ( * + ( fn_cell->payload.special.executable ) ) + ( get_stack_frame( next_pointer ), next_pointer, env ), fn_pointer ); + debug_print( L"Special form returning: ", DEBUG_EVAL ); + debug_print_object( result, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); + dec_ref( next_pointer ); + } + } + break; + + default: + { + int bs = sizeof( wchar_t ) * 1024; + wchar_t *buffer = malloc( bs ); + memset( buffer, '\0', bs ); + swprintf( buffer, bs, + L"Unexpected cell with tag %d (%4.4s) in function position", + fn_cell->tag.value, &( fn_cell->tag.bytes[0] ) ); + struct cons_pointer message = + c_string_to_lisp_string( buffer ); + free( buffer ); + result = + throw_exception( c_string_to_lisp_symbol( L"apply" ), + message, frame_pointer ); + } + } + + } + + debug_print( L"c_apply: returning: ", DEBUG_EVAL ); + debug_print_object( result, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); + + return result; +} + +/** + * Function; evaluate the expression which is the first argument in the frame; + * further arguments are ignored. + * + * * (eval expression) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return + * * If `expression` is a number, string, `nil`, or `t`, returns `expression`. + * * If `expression` is a symbol, returns the value that expression is bound + * to in the evaluation environment (`env`). + * * If `expression` is a list, expects the car to be something that evaluates to a + * function or special form: + * * If a function, evaluates all the other top level elements in `expression` and + * passes them in a stack frame as arguments to the function; + * * If a special form, passes the cdr of expression to the special form as argument. + * @exception if `expression` is a symbol which is not bound in `env`. + */ +struct cons_pointer +lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + debug_print( L"Eval: ", DEBUG_EVAL ); + debug_dump_object( frame_pointer, DEBUG_EVAL ); + + struct cons_pointer result = frame->arg[0]; + struct cons_space_object *cell = &pointer2cell( frame->arg[0] ); + + switch ( cell->tag.value ) { + case CONSTV: + result = c_apply( frame, frame_pointer, env ); + break; + + case SYMBOLTV: + { + struct cons_pointer canonical = interned( frame->arg[0], env ); + if ( nilp( canonical ) ) { + struct cons_pointer message = + make_cons( c_string_to_lisp_string + ( L"Attempt to take value of unbound symbol." ), + frame->arg[0] ); + result = + throw_exception( c_string_to_lisp_symbol( L"eval" ), + message, frame_pointer ); + } else { + result = c_assoc( canonical, env ); +// inc_ref( result ); + } + } + break; + /* + * \todo + * the Clojure practice of having a map serve in the function place of + * an s-expression is a good one and I should adopt it; + * H'mmm... this is working, but it isn't here. Where is it? + */ + default: + result = frame->arg[0]; + break; + } + + debug_print( L"Eval returning ", DEBUG_EVAL ); + debug_dump_object( result, DEBUG_EVAL ); + + return result; +} + + +/** + * Function; apply the function which is the result of evaluating the + * first argument to the list of values which is the result of evaluating + * the second argument + * + * * (apply fn args) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return the result of applying `fn` to `args`. + */ +struct cons_pointer +lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + debug_print( L"Apply: ", DEBUG_EVAL ); + debug_dump_object( frame_pointer, DEBUG_EVAL ); + + set_reg( frame, 0, make_cons( frame->arg[0], frame->arg[1] ) ); + set_reg( frame, 1, NIL ); + + struct cons_pointer result = c_apply( frame, frame_pointer, env ); + + debug_print( L"Apply returning ", DEBUG_EVAL ); + debug_dump_object( result, DEBUG_EVAL ); + + return result; +} + + +/** + * Special form; + * returns its argument (strictly first argument - only one is expected but + * this isn't at this stage checked) unevaluated. + * + * * (quote a) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return `a`, unevaluated, + */ +struct cons_pointer +lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return frame->arg[0]; +} + + +/** + * Function; + * binds the value of `name` in the `namespace` to value of `value`, altering + * the namespace in so doing. Retuns `value`. + * `namespace` defaults to the oblist. + * \todo doesn't actually work yet for namespaces which are not the oblist. + * + * * (set name value) + * * (set name value namespace) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return `value` + */ +struct cons_pointer +lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + struct cons_pointer namespace = + nilp( frame->arg[2] ) ? oblist : frame->arg[2]; + + if ( symbolp( frame->arg[0] ) ) { + deep_bind( frame->arg[0], frame->arg[1] ); + result = frame->arg[1]; + } else { + result = + throw_exception( c_string_to_lisp_symbol( L"set" ), + make_cons + ( c_string_to_lisp_string + ( L"The first argument to `set` is not a symbol: " ), + make_cons( frame->arg[0], NIL ) ), + frame_pointer ); + } + + return result; +} + + +/** + * Special form; + * binds `symbol` in the `namespace` to value of `value`, altering + * the namespace in so doing, and returns value. `namespace` defaults to + * the value of `oblist`. + * \todo doesn't actually work yet for namespaces which are not the oblist. + * + * * (set! symbol value) + * * (set! symbol value namespace) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return `value` + */ +struct cons_pointer +lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + struct cons_pointer namespace = frame->arg[2]; + + if ( symbolp( frame->arg[0] ) ) { + struct cons_pointer val = + eval_form( frame, frame_pointer, frame->arg[1], env ); + deep_bind( frame->arg[0], val ); + result = val; + } else { + result = + throw_exception( c_string_to_lisp_symbol( L"set!" ), + make_cons + ( c_string_to_lisp_string + ( L"The first argument to `set!` is not a symbol: " ), + make_cons( frame->arg[0], NIL ) ), + frame_pointer ); + } + + return result; +} + +/** + * @return true if `arg` represents an end of string, else false. + * \todo candidate for moving to a memory/string.c file + */ +bool end_of_stringp( struct cons_pointer arg ) { + return nilp( arg ) || + ( stringp( arg ) && + pointer2cell( arg ).payload.string.character == ( wint_t ) '\0' ); +} + +/** + * Function; + * returns a cell constructed from a and b. If a is of type string but its + * cdr is nill, and b is of type string, then returns a new string cell; + * otherwise returns a new cons cell. + * + * Thus: `(cons "a" "bcd") -> "abcd"`, but `(cons "ab" "cd") -> ("ab" . "cd")` + * + * * (cons a b) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return a new cons cell whose `car` is `a` and whose `cdr` is `b`. + */ +struct cons_pointer +lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer car = frame->arg[0]; + struct cons_pointer cdr = frame->arg[1]; + struct cons_pointer result; + + if ( nilp( car ) && nilp( cdr ) ) { + return NIL; + } else if ( stringp( car ) && stringp( cdr ) && + end_of_stringp( c_cdr( car ) ) ) { + result = + make_string( pointer2cell( car ).payload.string.character, cdr ); + } else { + result = make_cons( car, cdr ); + } + + return result; +} + +/** + * Function; + * returns the first item (head) of a sequence. Valid for cons cells, + * strings, read streams and TODO other things which can be considered as sequences. + * + * * (car expression) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the first item (head) of `expression`. + * @exception if `expression` is not a sequence. + */ +struct cons_pointer +lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + struct cons_space_object *cell = &pointer2cell( frame->arg[0] ); + + switch ( cell->tag.value ) { + case CONSTV: + result = cell->payload.cons.car; + break; + case NILTV: + break; + case READTV: + result = + make_string( url_fgetwc( cell->payload.stream.stream ), NIL ); + break; + case STRINGTV: + result = make_string( cell->payload.string.character, NIL ); + break; + default: + result = + throw_exception( c_string_to_lisp_symbol( L"car" ), + c_string_to_lisp_string + ( L"Attempt to take CAR of non sequence" ), + frame_pointer ); + } + + return result; +} + +/** + * Function; + * returns the remainder of a sequence when the head is removed. Valid for cons cells, + * strings, read streams and TODO other things which can be considered as sequences. + * *NOTE* that if the argument is an input stream, the first character is removed AND + * DISCARDED. + * + * * (cdr expression) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the remainder of `expression` when the head is removed. + * @exception if `expression` is not a sequence. + */ +struct cons_pointer +lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + struct cons_space_object *cell = &pointer2cell( frame->arg[0] ); + + switch ( cell->tag.value ) { + case CONSTV: + result = cell->payload.cons.cdr; + break; + case NILTV: + break; + case READTV: + url_fgetwc( cell->payload.stream.stream ); + result = frame->arg[0]; + break; + case STRINGTV: + result = cell->payload.string.cdr; + break; + default: + result = + throw_exception( c_string_to_lisp_symbol( L"cdr" ), + c_string_to_lisp_string + ( L"Attempt to take CDR of non sequence" ), + frame_pointer ); + } + + return result; +} + +/** + * Function: return, as an integer, the length of the sequence indicated by + * the first argument, or zero if it is not a sequence. + * + * * (length any) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the length of `any`, if it is a sequence, or zero otherwise. + */ +struct cons_pointer lisp_length( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return make_integer( c_length( frame->arg[0] ), NIL ); +} + +/** + * Function; look up the value of a `key` in a `store`. + * + * * (assoc key store) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the value associated with `key` in `store`, or `nil` if not found. + */ +struct cons_pointer +lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return c_assoc( frame->arg[0], + nilp( frame->arg[1] ) ? oblist : frame->arg[1] ); +} + +/** + * @brief `(interned? key store)`: Return `t` if the symbol or keyword `key` is bound in this `store`, else `nil`. + * + * @param frame + * @param frame_pointer + * @param env + * @return struct cons_pointer + */ +struct cons_pointer +lisp_internedp( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = internedp( frame->arg[0], + nilp( frame->arg[1] ) ? oblist : + frame->arg[1] ); + + if ( exceptionp( result ) ) { + struct cons_pointer old = result; + struct cons_space_object *cell = &( pointer2cell( result ) ); + result = + throw_exception( c_string_to_lisp_symbol( L"interned?" ), + cell->payload.exception.payload, frame_pointer ); + dec_ref( old ); + } + + return result; +} + +struct cons_pointer c_keys( struct cons_pointer store ) { + struct cons_pointer result = NIL; + + if ( consp( store ) ) { + for ( struct cons_pointer pair = c_car( store ); !nilp( pair ); + pair = c_car( store ) ) { + if ( consp( pair ) ) { + result = make_cons( c_car( pair ), result ); + } else if ( hashmapp( pair ) ) { + result = c_append( hashmap_keys( pair ), result ); + } + + store = c_cdr( store ); + } + } else if ( hashmapp( store ) ) { + result = hashmap_keys( store ); + } + + return result; +} + + + +struct cons_pointer lisp_keys( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return c_keys( frame->arg[0] ); +} + +/** + * Function; are these two objects the same object? Shallow, cheap equality. + * + * * (eq a b) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return `t` if `a` and `b` are pointers to the same object, else `nil`; + */ +struct cons_pointer lisp_eq( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = TRUE; + + if ( frame->args > 1 ) { + for ( int b = 1; ( truep( result ) ) && ( b < frame->args ); b++ ) { + result = eq( frame->arg[0], fetch_arg( frame, b ) ) ? TRUE : NIL; + } + } + + return result; +} + +/** + * Function; are these two arguments identical? Deep, expensive equality. + * + * * (equal a b) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return `t` if `a` and `b` are recursively identical, else `nil`. + */ +struct cons_pointer +lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = TRUE; + + if ( frame->args > 1 ) { + for ( int b = 1; ( truep( result ) ) && ( b < frame->args ); b++ ) { + result = + equal( frame->arg[0], fetch_arg( frame, b ) ) ? TRUE : NIL; + } + } + + return result; +} + +long int c_count( struct cons_pointer p ) { + struct cons_space_object *cell = &pointer2cell( p ); + int result = 0; + + switch ( cell->tag.value ) { + case CONSTV: + case STRINGTV: + /* I think doctrine is that you cannot treat symbols or keywords as + * sequences, although internally, of course, they are. Integers are + * also internally sequences, but also should not be treated as such. + */ + for ( p; !nilp( p ); p = c_cdr( p ) ) { + result++; + } + } + + return result; +} + +/** + * Function: return the number of top level forms in the object which is + * the first (and only) argument, if it is a sequence (which for current + * purposes means a list or a string) + * + * * (count l) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the number of top level forms in a list, or characters in a + * string, else 0. + */ +struct cons_pointer +lisp_count( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return acquire_integer( c_count( frame->arg[0] ), NIL ); +} + +/** + * Function; read one complete lisp form and return it. If read-stream is specified and + * is a read stream, then read from that stream, else the stream which is the value of + * `*in*` in the environment. + * + * * (read) + * * (read read-stream) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return the expression read. + */ +struct cons_pointer +lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { +#ifdef DEBUG + debug_print( L"entering lisp_read\n", DEBUG_IO ); +#endif + URL_FILE *input; + + struct cons_pointer in_stream = readp( frame->arg[0] ) ? + frame->arg[0] : get_default_stream( true, env ); + + if ( readp( in_stream ) ) { + debug_print( L"lisp_read: setting input stream\n", + DEBUG_IO | DEBUG_REPL ); + debug_dump_object( in_stream, DEBUG_IO ); + input = pointer2cell( in_stream ).payload.stream.stream; + inc_ref( in_stream ); + } else { + /* should not happen, but has done. */ + debug_print( L"WARNING: invalid input stream; defaulting!\n", + DEBUG_IO | DEBUG_REPL ); + input = file_to_url_file( stdin ); + } + + struct cons_pointer result = read( frame, frame_pointer, env, input ); + debug_print( L"lisp_read returning\n", DEBUG_IO ); + debug_dump_object( result, DEBUG_IO ); + + if ( readp( in_stream ) ) { + dec_ref( in_stream ); + } else { + free( input ); + } + + + return result; +} + + +/** + * reverse a sequence (if it is a sequence); else return it unchanged. + */ +struct cons_pointer c_reverse( struct cons_pointer arg ) { + struct cons_pointer result = NIL; + + if ( sequencep( arg ) ) { + for ( struct cons_pointer p = arg; sequencep( p ); p = c_cdr( p ) ) { + struct cons_space_object o = pointer2cell( p ); + switch ( o.tag.value ) { + case CONSTV: + result = make_cons( o.payload.cons.car, result ); + break; + case STRINGTV: + result = make_string( o.payload.string.character, result ); + break; + case SYMBOLTV: + result = + make_symbol_or_key( o.payload.string.character, result, + SYMBOLTV ); + break; + } + } + } else { + result = arg; + } + + return result; +} + + +/** + * Function; reverse the order of members in s sequence. + * + * * (reverse sequence) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return a sequence like this `sequence` but with the members in the reverse order. + */ +struct cons_pointer lisp_reverse( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return c_reverse( frame->arg[0] ); +} + +/** + * Function: dump/inspect one complete lisp expression and return NIL. If + * write-stream is specified and is a write stream, then print to that stream, + * else the stream which is the value of + * `*out*` in the environment. + * + * * (inspect expr) + * * (inspect expr write-stream) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (from which the stream may be extracted). + * @return NIL. + */ +struct cons_pointer lisp_inspect( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + debug_print( L"Entering lisp_inspect\n", DEBUG_IO ); + struct cons_pointer result = NIL; + struct cons_pointer out_stream = writep( frame->arg[1] ) + ? frame->arg[1] + : get_default_stream( false, env ); + URL_FILE *output; + + if ( writep( out_stream ) ) { + debug_print( L"lisp_inspect: setting output stream\n", DEBUG_IO ); + debug_dump_object( out_stream, DEBUG_IO ); + output = pointer2cell( out_stream ).payload.stream.stream; + } else { + output = file_to_url_file( stderr ); + } + + dump_object( output, frame->arg[0] ); + + debug_print( L"Leaving lisp_inspect", DEBUG_IO ); + + return result; +} + + +/** + * Function: get the Lisp type of the single argument. + * + * * (type expression) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return As a Lisp string, the tag of `expression`. + */ +struct cons_pointer +lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return c_type( frame->arg[0] ); +} + +/** + * Evaluate each of these expressions in this `env`ironment over this `frame`, + * returning only the value of the last. + */ +struct cons_pointer +c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer expressions, struct cons_pointer env ) { + struct cons_pointer result = NIL; + + while ( consp( expressions ) ) { + struct cons_pointer r = result; + + result = eval_form( frame, frame_pointer, c_car( expressions ), env ); + dec_ref( r ); + + expressions = exceptionp( result ) ? NIL : c_cdr( expressions ); + } + + return result; +} + + +/** + * Special form; evaluate the expressions which are listed in my arguments + * sequentially and return the value of the last. This function is called 'do' + * in some dialects of Lisp. + * + * * (progn expressions...) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment in which expressions are evaluated. + * @return the value of the last `expression` of 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 ) { + struct cons_pointer result = NIL; + + for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) { + struct cons_pointer r = result; + + result = eval_form( frame, frame_pointer, frame->arg[i], env ); + + dec_ref( r ); + } + + if ( consp( frame->more ) ) { + result = c_progn( frame, frame_pointer, frame->more, env ); + } + + return result; +} + +/** + * @brief evaluate a single cond clause; if the test part succeeds return a + * pair whose car is TRUE and whose cdr is the value of the action part + */ +struct cons_pointer eval_cond_clause( struct cons_pointer clause, + struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + +#ifdef DEBUG + debug_print( L"\n\tCond clause: ", DEBUG_EVAL ); + debug_print_object( clause, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); +#endif + + if ( consp( clause ) ) { + struct cons_pointer val = + eval_form( frame, frame_pointer, c_car( clause ), + env ); + + if ( !nilp( val ) ) { + result = + make_cons( TRUE, + c_progn( frame, frame_pointer, c_cdr( clause ), + env ) ); + +#ifdef DEBUG + debug_print( L"\n\t\tCond clause ", DEBUG_EVAL ); + debug_print_object( clause, DEBUG_EVAL ); + debug_print( L" succeeded; returning: ", DEBUG_EVAL ); + debug_print_object( result, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); + } else { + debug_print( L"\n\t\tCond clause ", DEBUG_EVAL ); + debug_print_object( clause, DEBUG_EVAL ); + debug_print( L" failed.\n", DEBUG_EVAL ); +#endif + } + } else { + result = throw_exception( c_string_to_lisp_symbol( L"cond" ), + c_string_to_lisp_string + ( L"Arguments to `cond` must be lists" ), + frame_pointer ); + } + + return result; +} + +/** + * Special form: conditional. Each `clause` 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. + * + * * (cond clauses...) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment in which arguments will be evaluated. + * @return the value of the last expression 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 result = NIL; + bool done = false; + + for ( int i = 0; ( i < frame->args ) && !done; i++ ) { + struct cons_pointer clause_pointer = fetch_arg( frame, i ); + + result = eval_cond_clause( clause_pointer, frame, frame_pointer, env ); + + if ( !nilp( result ) && truep( c_car( result ) ) ) { + result = c_cdr( result ); + done = true; + break; + } + } +#ifdef DEBUG + debug_print( L"\tCond returning: ", DEBUG_EVAL ); + debug_print_object( result, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); +#endif + + return result; +} + +/** + * Throw an exception with a cause. + * `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. + * object pointing to it. Then this should become a normal lisp function + * which expects a normally bound frame and environment, such that + * frame->arg[0] is the payload, frame->arg[1] is the cause, and frame->arg[2] is the cons-space + * pointer to the frame in which the exception occurred. + */ +struct cons_pointer throw_exception_with_cause( struct cons_pointer location, + struct cons_pointer message, + struct cons_pointer cause, + struct cons_pointer + frame_pointer ) { + struct cons_pointer result = NIL; + +#ifdef DEBUG + debug_print( L"\nERROR: `", 511 ); + debug_print_object( message, 511 ); + debug_print( L"` at `", 511 ); + debug_print_object( location, 511 ); + debug_print( L"`\n", 511 ); + if ( !nilp( cause ) ) { + debug_print( L"\tCaused by: ", 511 ); + debug_print_object( cause, 511 ); + debug_print( L"`\n", 511 ); + } +#endif + struct cons_space_object *cell = &pointer2cell( message ); + + if ( cell->tag.value == EXCEPTIONTV ) { + result = message; + } else { + result = + make_exception( make_cons + ( make_cons( privileged_keyword_location, + location ), + make_cons( make_cons + ( privileged_keyword_payload, + message ), + ( nilp( cause ) ? NIL : + make_cons( make_cons + ( privileged_keyword_cause, + cause ), NIL ) ) ) ), + frame_pointer ); + } + + return result; + +} + +/** + * 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. + * object pointing to it. Then this should become a normal lisp function + * which expects a normally bound frame and environment, such that + * frame->arg[0] is the payload, frame->arg[1] is the cause, and frame->arg[2] is the cons-space + * pointer to the frame in which the exception occurred. + */ +struct cons_pointer +throw_exception( struct cons_pointer location, + struct cons_pointer payload, + struct cons_pointer frame_pointer ) { + return throw_exception_with_cause( location, payload, NIL, frame_pointer ); +} + +/** + * Function; create an exception. Exceptions are special in as much as if an + * exception is created in the binding of the arguments of any function, the + * function will return the exception rather than whatever else it would + * normally return. A function which detects a problem it cannot resolve + * *should* return an exception. + * + * * (exception message location) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment in which arguments will be evaluated. + * @return areturns an exception whose message is this `message`, and whose + * stack frame is the parent stack frame when the function is invoked. + * `message` does not have to be a string but should be something intelligible + * which can be read. + * If `message` is itself an exception, returns that instead. + */ +struct cons_pointer +lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer message = frame->arg[0]; + + return exceptionp( message ) ? message : + throw_exception_with_cause( message, frame->arg[1], frame->arg[2], + frame->previous ); +} + +/** + * Function: the read/eval/print loop. + * + * * (repl) + * * (repl prompt) + * * (repl prompt input_stream output_stream) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment in which epressions will be evaluated. + * @return the value of the last expression read. + */ +struct cons_pointer lisp_repl( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer expr = NIL; + +#ifdef DEBUG + debug_print( L"Entering new inner REPL\n\tenv is `", DEBUG_REPL ); + debug_print_object( env, DEBUG_REPL ); + debug_print( L"`\n", DEBUG_REPL ); +#endif + + struct cons_pointer input = get_default_stream( true, env ); + struct cons_pointer output = get_default_stream( false, env ); + struct cons_pointer old_oblist = oblist; + struct cons_pointer new_env = env; + + if ( truep( frame->arg[0] ) ) { + new_env = set( prompt_name, frame->arg[0], new_env ); + } + if ( readp( frame->arg[1] ) ) { + new_env = + set( c_string_to_lisp_symbol( L"*in*" ), frame->arg[1], new_env ); + input = frame->arg[1]; + } + if ( writep( frame->arg[2] ) ) { + new_env = + set( c_string_to_lisp_symbol( L"*out*" ), frame->arg[2], new_env ); + output = frame->arg[2]; + } + + inc_ref( input ); + inc_ref( output ); + inc_ref( prompt_name ); + + /* output should NEVER BE nil; but during development it has happened. + * To allow debugging under such circumstances, we need an emergency + * default. */ + URL_FILE *os = + !writep( output ) ? file_to_url_file( stdout ) : + pointer2cell( output ).payload.stream.stream; + if ( !writep( output ) ) { + debug_print( L"WARNING: invalid output; defaulting!\n", + DEBUG_IO | DEBUG_REPL ); + } + + /* \todo this is subtly wrong. If we were evaluating + * (print (eval (read))) + * then the stack frame for read would have the stack frame for + * eval as parent, and it in turn would have the stack frame for + * print as parent. + */ + while ( readp( input ) && writep( output ) + && !url_feof( pointer2cell( input ).payload.stream.stream ) ) { + /* OK, here's a really subtle problem: because lists are immutable, anything + * bound in the oblist subsequent to this function being invoked isn't in the + * environment. So, for example, changes to *prompt* or *log* made in the oblist + * are not visible. So copy changes made in the oblist into the enviroment. + * \todo the whole process of resolving symbol values needs to be revisited + * when we get onto namespaces. */ + /* OK, there's something even more subtle here if the root namespace is a map. + * H'mmmm... + * I think that now the oblist is a hashmap masquerading as a namespace, + * we should no longer have to do this. TODO: test, and if so, delete this + * statement. */ + if ( !eq( oblist, old_oblist ) ) { + struct cons_pointer cursor = oblist; + + while ( !nilp( cursor ) && !eq( cursor, old_oblist ) ) { + struct cons_pointer old_new_env = new_env; + debug_print + ( L"lisp_repl: copying new oblist binding into REPL environment:\n", + DEBUG_REPL ); + debug_print_object( c_car( cursor ), DEBUG_REPL ); + debug_println( DEBUG_REPL ); + + new_env = make_cons( c_car( cursor ), new_env ); + inc_ref( new_env ); + dec_ref( old_new_env ); + cursor = c_cdr( cursor ); + } + old_oblist = oblist; + } + + println( os ); + + struct cons_pointer prompt = c_assoc( prompt_name, new_env ); + if ( !nilp( prompt ) ) { + print( os, prompt ); + } + + expr = lisp_read( get_stack_frame( frame_pointer ), frame_pointer, + new_env ); + + if ( exceptionp( expr ) + && url_feof( pointer2cell( input ).payload.stream.stream ) ) { + /* suppress printing end of stream exception */ + dec_ref( expr ); + break; + } + + println( os ); + + print( os, eval_form( frame, frame_pointer, expr, new_env ) ); + + dec_ref( expr ); + } + + if ( nilp( output ) ) { + free( os ); + } + dec_ref( input ); + dec_ref( output ); + dec_ref( prompt_name ); + dec_ref( new_env ); + + debug_printf( DEBUG_REPL, L"Leaving inner repl\n" ); + + return expr; +} + +/** + * Function. return the source code of the object which is its first argument, + * if it is an executable and has source code. + * + * * (source object) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment (ignored). + * @return the source of the `object` indicated, if it is a function, a lambda, + * an nlambda, or a spcial form; else `nil`. + */ +struct cons_pointer lisp_source( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + struct cons_space_object *cell = &pointer2cell( frame->arg[0] ); + struct cons_pointer source_key = c_string_to_lisp_keyword( L"source" ); + switch ( cell->tag.value ) { + case FUNCTIONTV: + result = c_assoc( source_key, cell->payload.function.meta ); + break; + case SPECIALTV: + result = c_assoc( source_key, cell->payload.special.meta ); + break; + case LAMBDATV: + result = make_cons( c_string_to_lisp_symbol( L"lambda" ), + make_cons( cell->payload.lambda.args, + cell->payload.lambda.body ) ); + break; + case NLAMBDATV: + result = make_cons( c_string_to_lisp_symbol( L"nlambda" ), + make_cons( cell->payload.lambda.args, + cell->payload.lambda.body ) ); + break; + } + // \todo suffers from premature GC, and I can't see why! + inc_ref( result ); + + return result; +} + +/** + * A version of append which can conveniently be called from C. + */ +struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) { + switch ( pointer2cell( l1 ).tag.value ) { + case CONSTV: + if ( pointer2cell( l1 ).tag.value == pointer2cell( l2 ).tag.value ) { + if ( nilp( c_cdr( l1 ) ) ) { + return make_cons( c_car( l1 ), l2 ); + } else { + return make_cons( c_car( l1 ), + c_append( c_cdr( l1 ), l2 ) ); + } + } else { + throw_exception( c_string_to_lisp_symbol( L"append" ), + c_string_to_lisp_string + ( L"Can't append: not same type" ), NIL ); + } + break; + case KEYTV: + case STRINGTV: + case SYMBOLTV: + if ( pointer2cell( l1 ).tag.value == pointer2cell( l2 ).tag.value ) { + if ( nilp( c_cdr( l1 ) ) ) { + return + make_string_like_thing( ( pointer2cell( l1 ). + payload.string.character ), + l2, + pointer2cell( l1 ).tag.value ); + } else { + return + make_string_like_thing( ( pointer2cell( l1 ). + payload.string.character ), + c_append( c_cdr( l1 ), l2 ), + pointer2cell( l1 ).tag.value ); + } + } else { + throw_exception( c_string_to_lisp_symbol( L"append" ), + c_string_to_lisp_string + ( L"Can't append: not same type" ), NIL ); + } + break; + default: + throw_exception( c_string_to_lisp_symbol( L"append" ), + c_string_to_lisp_string + ( L"Can't append: not a sequence" ), NIL ); + break; + } +} + +/** + * should really be overwritten with a version in Lisp, since this is much easier to write in Lisp + */ +struct cons_pointer lisp_append( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = fetch_arg( frame, ( frame->args - 1 ) ); + + for ( int a = frame->args - 2; a >= 0; a-- ) { + result = c_append( fetch_arg( frame, a ), result ); + } + + return result; +} + +struct cons_pointer lisp_mapcar( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + debug_print( L"Mapcar: ", DEBUG_EVAL ); + debug_dump_object( frame_pointer, DEBUG_EVAL ); + int i = 0; + + for ( struct cons_pointer c = frame->arg[1]; truep( c ); c = c_cdr( c ) ) { + struct cons_pointer expr = + make_cons( frame->arg[0], make_cons( c_car( c ), NIL ) ); + + debug_printf( DEBUG_EVAL, L"Mapcar %d, evaluating ", i ); + debug_print_object( expr, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); + + struct cons_pointer r = eval_form( frame, frame_pointer, expr, env ); + + if ( exceptionp( r ) ) { + result = r; + inc_ref( expr ); // to protect exception from the later dec_ref + break; + } else { + result = make_cons( r, result ); + } + debug_printf( DEBUG_EVAL, L"Mapcar %d, result is ", i++ ); + debug_print_object( result, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); + + dec_ref( expr ); + } + + result = consp( result ) ? c_reverse( result ) : result; + + debug_print( L"Mapcar returning: ", DEBUG_EVAL ); + debug_print_object( result, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); + + return result; +} + +/** + * @brief construct and return a list of arbitrarily many arguments. + * + * @param frame The stack frame. + * @param frame_pointer A pointer to the stack frame. + * @param env The evaluation environment. + * @return struct cons_pointer a pointer to the result + */ +struct cons_pointer lisp_list( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = frame->more; + + for ( int a = nilp( result ) ? frame->args - 1 : args_in_frame - 1; + a >= 0; a-- ) { + result = make_cons( fetch_arg( frame, a ), result ); + } + + return result; +} + + + +/** + * Special form: evaluate a series of forms in an environment in which + * these bindings are bound. + * This is `let*` in Common Lisp parlance; `let` in Clojure parlance. + */ +struct cons_pointer lisp_let( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer bindings = env; + struct cons_pointer result = NIL; + + for ( struct cons_pointer cursor = frame->arg[0]; + truep( cursor ); cursor = c_cdr( cursor ) ) { + struct cons_pointer pair = c_car( cursor ); + struct cons_pointer symbol = c_car( pair ); + + if ( symbolp( symbol ) ) { + struct cons_pointer val = + eval_form( frame, frame_pointer, c_cdr( pair ), + bindings ); + + debug_print_binding( symbol, val, false, DEBUG_BIND ); + + bindings = make_cons( make_cons( symbol, val ), bindings ); + } else { + result = + throw_exception( c_string_to_lisp_symbol( L"let" ), + c_string_to_lisp_string + ( L"Let: cannot bind, not a symbol" ), + frame_pointer ); + break; + } + } + + debug_print( L"\nlet: bindings complete.\n", DEBUG_BIND ); + + /* i.e., no exception yet */ + for ( int form = 1; !exceptionp( result ) && form < frame->args; form++ ) { + result = + eval_form( frame, frame_pointer, fetch_arg( frame, form ), + bindings ); + } + + /* release the local bindings as they go out of scope! **BUT** + * bindings were consed onto the front of env, so caution... */ + // for (struct cons_pointer cursor = bindings; !eq( cursor, env); cursor = c_cdr(cursor)) { + // dec_ref( cursor); + // } + + return result; + +} + +/** + * @brief Boolean `and` of arbitrarily many arguments. + * + * @param frame The stack frame. + * @param frame_pointer A pointer to the stack frame. + * @param env The evaluation environment. + * @return struct cons_pointer a pointer to the result + */ +struct cons_pointer lisp_and( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + bool accumulator = true; + struct cons_pointer result = frame->more; + + for ( int a = 0; accumulator == true && a < frame->args; a++ ) { + accumulator = truthy( fetch_arg( frame, a ) ); + } +# + return accumulator ? TRUE : NIL; +} + +/** + * @brief Boolean `or` of arbitrarily many arguments. + * + * @param frame The stack frame. + * @param frame_pointer A pointer to the stack frame. + * @param env The evaluation environment. + * @return struct cons_pointer a pointer to the result + */ +struct cons_pointer lisp_or( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + bool accumulator = false; + struct cons_pointer result = frame->more; + + for ( int a = 0; accumulator == false && a < frame->args; a++ ) { + accumulator = truthy( fetch_arg( frame, a ) ); + } + + return accumulator ? TRUE : NIL; +} + +/** + * @brief Logical inverese: if the first argument is `nil`, return `t`, else `nil`. + * + * @param frame The stack frame. + * @param frame_pointer A pointer to the stack frame. + * @param env The evaluation environment. + * @return struct cons_pointer `t` if the first argument is `nil`, else `nil`. + */ +struct cons_pointer lisp_not( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return nilp( frame->arg[0] ) ? TRUE : NIL; +} diff --git a/archive/c/ops/lispops.h b/archive/c/ops/lispops.h new file mode 100644 index 0000000..66f46c8 --- /dev/null +++ b/archive/c/ops/lispops.h @@ -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 + * 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 diff --git a/archive/c/ops/loop.c b/archive/c/ops/loop.c new file mode 100644 index 0000000..6ccada6 --- /dev/null +++ b/archive/c/ops/loop.c @@ -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 + * 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]; + +} diff --git a/archive/c/ops/loop.h b/archive/c/ops/loop.h new file mode 100644 index 0000000..27714a8 --- /dev/null +++ b/archive/c/ops/loop.h @@ -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 + * Licensed under GPL version 2.0, or, at your option, any later version. + */ diff --git a/archive/c/ops/meta.c b/archive/c/ops/meta.c new file mode 100644 index 0000000..f00824f --- /dev/null +++ b/archive/c/ops/meta.c @@ -0,0 +1,45 @@ +/* + * meta.c + * + * Get metadata from a cell which has it. + * + * (c) 2019 Simon Brooke + * 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; +} diff --git a/archive/c/ops/meta.h b/archive/c/ops/meta.h new file mode 100644 index 0000000..f441a50 --- /dev/null +++ b/archive/c/ops/meta.h @@ -0,0 +1,18 @@ +/* + * meta.h + * + * Get metadata from a cell which has it. + * + * (c) 2019 Simon Brooke + * 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 diff --git a/src/c/io/read.c b/src/c/io/read.c new file mode 100644 index 0000000..9760023 --- /dev/null +++ b/src/c/io/read.c @@ -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 + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include +#include + +/* + * wide characters + */ +#include +#include + +#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 diff --git a/src/c/ops/assoc.c b/src/c/ops/assoc.c new file mode 100644 index 0000000..8589966 --- /dev/null +++ b/src/c/ops/assoc.c @@ -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 + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include + +#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)); +} diff --git a/src/c/ops/assoc.h b/src/c/ops/assoc.h new file mode 100644 index 0000000..e5572f9 --- /dev/null +++ b/src/c/ops/assoc.h @@ -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 + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_ops_assoc_h +#define __psse_ops_assoc_h + +#include + +#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 diff --git a/src/c/ops/reverse.c b/src/c/ops/reverse.c new file mode 100644 index 0000000..1b70342 --- /dev/null +++ b/src/c/ops/reverse.c @@ -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 + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include + +#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; +} diff --git a/src/c/ops/reverse.h b/src/c/ops/reverse.h new file mode 100644 index 0000000..18cb36e --- /dev/null +++ b/src/c/ops/reverse.h @@ -0,0 +1,21 @@ +/** + * ops/reverse.h + * + * Post Scarcity Software Environment: reverse. + * + * Reverse a sequence. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_ops_reverse_h +#define __psse_ops_reverse_h + +#include + +#include "memory/pointer.h" + +struct pso_pointer reverse( struct pso_pointer sequence); + +#endif diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c new file mode 100644 index 0000000..7008b20 --- /dev/null +++ b/src/c/payloads/stack.c @@ -0,0 +1,66 @@ +/** + * payloads/stack.h + * + * a Lisp stack frame. + * + * Sits in a pso4. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include + +#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; +}