diff --git a/Makefile b/Makefile index 49bf5e1..701b16b 100644 --- a/Makefile +++ b/Makefile @@ -21,13 +21,14 @@ INDENT_FLAGS := -nbad -bap -nbc -br -brf -brs -c33 -cd33 -ncdb -ce -ci4 -cli4 \ CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g -DDEBUG LDFLAGS := -lm -lcurl DEBUGFLAGS := -g3 +GCCFLAGS := -std=gnu23 all: $(TARGET) Debug: $(TARGET) $(TARGET): $(OBJS) Makefile - $(CC) $(DEBUGFLAGS) $(LDFLAGS) $(OBJS) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS) + $(CC) $(GCCFLAGS) $(DEBUGFLAGS) $(LDFLAGS) $(OBJS) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS) doc: $(SRCS) Makefile Doxyfile doxygen diff --git a/archive/c/ops/equal.c b/archive/c/ops/equal.c deleted file mode 100644 index 296aea6..0000000 --- a/archive/c/ops/equal.c +++ /dev/null @@ -1,433 +0,0 @@ -/* - * 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 deleted file mode 100644 index 061eb94..0000000 --- a/archive/c/ops/equal.h +++ /dev/null @@ -1,36 +0,0 @@ -/** - * 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 deleted file mode 100644 index 989686b..0000000 --- a/archive/c/ops/intern.c +++ /dev/null @@ -1,574 +0,0 @@ -/* - * 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 deleted file mode 100644 index 0b8f657..0000000 --- a/archive/c/ops/intern.h +++ /dev/null @@ -1,81 +0,0 @@ -/* - * 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 deleted file mode 100644 index a9dd7ea..0000000 --- a/archive/c/ops/lispops.c +++ /dev/null @@ -1,1840 +0,0 @@ -/* - * 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 deleted file mode 100644 index 66f46c8..0000000 --- a/archive/c/ops/lispops.h +++ /dev/null @@ -1,250 +0,0 @@ -/** - * 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 deleted file mode 100644 index 6ccada6..0000000 --- a/archive/c/ops/loop.c +++ /dev/null @@ -1,50 +0,0 @@ -/* - * 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 deleted file mode 100644 index 27714a8..0000000 --- a/archive/c/ops/loop.h +++ /dev/null @@ -1,10 +0,0 @@ -/* - * 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 deleted file mode 100644 index f00824f..0000000 --- a/archive/c/ops/meta.c +++ /dev/null @@ -1,45 +0,0 @@ -/* - * 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 deleted file mode 100644 index f441a50..0000000 --- a/archive/c/ops/meta.h +++ /dev/null @@ -1,18 +0,0 @@ -/* - * 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/memory/page.c b/src/c/memory/page.c index 2d3319d..c5c735e 100644 --- a/src/c/memory/page.c +++ b/src/c/memory/page.c @@ -152,3 +152,11 @@ struct pso_pointer allocate_page( uint8_t size_class ) { return result; } + +/** + * @brief allow other files to see the current value of npages_allocated, but not + * change it. + */ +uint32_t get_pages_allocated() { + return npages_allocated; +} diff --git a/src/c/memory/page.h b/src/c/memory/page.h index ba64d38..3df37e6 100644 --- a/src/c/memory/page.h +++ b/src/c/memory/page.h @@ -74,4 +74,6 @@ union page { struct pso_pointer allocate_page( uint8_t size_class ); +uint32_t get_pages_allocated(); + #endif diff --git a/src/c/memory/pointer.c b/src/c/memory/pointer.c index 8227151..8120e78 100644 --- a/src/c/memory/pointer.c +++ b/src/c/memory/pointer.c @@ -41,8 +41,13 @@ struct pso2 *pointer_to_object( struct pso_pointer pointer ) { struct pso2 *result = NULL; if ( pointer.node == node_index ) { - union page *pg = pages[pointer.page]; - result = ( struct pso2 * ) &pg->words[pointer.offset]; + if (pointer.page < get_pages_allocated() && pointer.offset < (PAGE_BYTES / 8)) { + // TODO: that's not really a safe test of whether this is a valid pointer. + union page *pg = pages[pointer.page]; + result = ( struct pso2 * ) &pg->words[pointer.offset]; + } else { + // TODO: throw bad pointer exception. + } } // TODO: else if we have a copy of the object in cache, return that; // else request a copy of the object from the node which curates it. diff --git a/src/c/memory/pso2.h b/src/c/memory/pso2.h index 0c36b29..812d582 100644 --- a/src/c/memory/pso2.h +++ b/src/c/memory/pso2.h @@ -12,6 +12,7 @@ #include +#include "../payloads/psse_string.h" #include "memory/header.h" #include "payloads/character.h" #include "payloads/cons.h" @@ -22,7 +23,6 @@ #include "payloads/lambda.h" #include "payloads/nlambda.h" #include "payloads/read_stream.h" -#include "payloads/psse-string.h" #include "payloads/symbol.h" #include "payloads/time.h" #include "payloads/vector_pointer.h" diff --git a/src/c/ops/eq.c b/src/c/ops/eq.c index 8ca0550..ed274f9 100644 --- a/src/c/ops/eq.c +++ b/src/c/ops/eq.c @@ -3,7 +3,7 @@ * * Post Scarcity Software Environment: eq. * - * Test for pointer equality. + * Test for pointer equality; bootstrap level tests for object equality. * * (c) 2026 Simon Brooke * Licensed under GPL version 2.0, or, at your option, any later version. @@ -12,6 +12,11 @@ #include "memory/memory.h" #include "memory/node.h" #include "memory/pointer.h" +#include "memory/pso2.h" +#include "memory/tags.h" + +#include "payloads/cons.h" +#include "payloads/integer.h" #include "payloads/stack.h" #include "ops/stack_ops.h" #include "ops/truth.h" @@ -32,6 +37,39 @@ bool eq( struct pso_pointer a, struct pso_pointer b ) { return ( a.node == b.node && a.page == b.page && a.offset == b.offset ); } +bool equal( struct pso_pointer a, struct pso_pointer b) { + bool result = false; + + if ( eq( a, b)) { + result = true; + } else if ( get_tag_value(a) == get_tag_value(b)) { + switch ( get_tag_value(a)) { + case CONSTV : + result = (equal( car(a), car(b)) && equal( cdr(a), cdr(b))); + break; + case INTEGERTV : + result = (pointer_to_object(a)->payload.integer.value == + pointer_to_object(b)->payload.integer.value); + break; + case KEYTV: + case STRINGTV : + case SYMBOLTV : + while (result == false && !nilp(a) && !nilp(b)) { + if (pointer_to_object(a)->payload.string.character == + pointer_to_object(b)->payload.string.character) { + a = cdr(a); + b = cdr(b); + } + } + result = nilp(a) && nilp(b); + break; + } + } + + return result; +} + + /** * Function; do all arguments to this finction point to the same object? * @@ -60,3 +98,5 @@ struct pso_pointer lisp_eq( struct pso4 *frame, return result; } + + diff --git a/src/c/ops/eq.h b/src/c/ops/eq.h index ca330f4..4b4300c 100644 --- a/src/c/ops/eq.h +++ b/src/c/ops/eq.h @@ -22,4 +22,5 @@ struct pso_pointer lisp_eq( struct pso4 *frame, struct pso_pointer frame_pointer, struct pso_pointer env ); +bool equal( struct pso_pointer a, struct pso_pointer b); #endif diff --git a/src/c/payloads/cons.c b/src/c/payloads/cons.c index 2417385..8fde4b4 100644 --- a/src/c/payloads/cons.c +++ b/src/c/payloads/cons.c @@ -14,7 +14,11 @@ #include "memory/pso.h" #include "memory/pso2.h" #include "memory/tags.h" + #include "payloads/cons.h" +#include "payloads/exception.h" + +#include "ops/string_ops.h" /** * @brief allocate a cons cell with this car and this cdr, and return a pointer @@ -58,19 +62,29 @@ struct pso_pointer car( struct pso_pointer cons ) { } /** - * @brief return the cdr of this cons cell. + * @brief return the cdr of this cons (or other sequence) cell. * * @param cons a pointer to the cell. * @return the cdr of the indicated cell. * @exception if the pointer does not indicate a cons cell. */ -struct pso_pointer cdr( struct pso_pointer cons ) { +struct pso_pointer cdr( struct pso_pointer p ) { struct pso_pointer result = nil; struct pso2 *object = pointer_to_object( result ); - if ( consp( cons ) ) { - result = object->payload.cons.cdr; + switch (get_tag_value( p)) { + case CONSTV : result = object->payload.cons.cdr; break; + case KEYTV : + case STRINGTV : + case SYMBOLTV : + result = object->payload.string.cdr; break; + default : + result = make_exception( + cons(c_string_to_lisp_string(L"Invalid type for cdr"), p), + nil, nil); + break; } + // TODO: else throw an exception return result; diff --git a/src/c/payloads/exception.h b/src/c/payloads/exception.h index 1b082ae..bb1777f 100644 --- a/src/c/payloads/exception.h +++ b/src/c/payloads/exception.h @@ -24,6 +24,7 @@ struct exception_payload { struct pso_pointer cause; }; -struct pso_pointer make_exception( struct pso_pointer message, struct pso_pointer frame_pointer, struct pso_pointer cause); +struct pso_pointer make_exception( struct pso_pointer message, + struct pso_pointer frame_pointer, struct pso_pointer cause); #endif diff --git a/src/c/payloads/psse-string.h b/src/c/payloads/psse_string.h similarity index 100% rename from src/c/payloads/psse-string.h rename to src/c/payloads/psse_string.h diff --git a/src/c/payloads/stack.h b/src/c/payloads/stack.h index b33d7a3..a43b1e8 100644 --- a/src/c/payloads/stack.h +++ b/src/c/payloads/stack.h @@ -37,4 +37,6 @@ struct stack_frame_payload { uint32_t depth; }; +struct pso_pointer make_frame( struct pso_pointer previous, ...); + #endif