From 72548097cf9362e0c1f29559e81403267940a8c0 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 28 Feb 2026 11:21:11 +0000 Subject: [PATCH] Rewriting intern. This is badly broken, but I think on the road to better. --- src/init.c | 3 ++ src/memory/consspaceobject.c | 2 +- src/ops/equal.c | 3 +- src/ops/intern.c | 97 +++++++++++++++++++++++------------- src/ops/intern.h | 3 ++ src/ops/lispops.c | 33 ++++++++++-- src/ops/lispops.h | 3 ++ 7 files changed, 103 insertions(+), 41 deletions(-) diff --git a/src/init.c b/src/init.c index f1301ee..5febcbc 100644 --- a/src/init.c +++ b/src/init.c @@ -401,6 +401,9 @@ int main( int argc, char *argv[] ) { bind_function( L"inspect", L"`(inspect object ouput-stream)`: Print details of this `object` to this `output-stream` or `*out*`.", &lisp_inspect ); + bind_function( L"interned?", + L"`(interned? key store)`: Return `t` if the symbol or keyword `key` is bound in this `store`, else `nil`.", + &lisp_internedp ); bind_function( L"keys", L"`(keys store)`: Return a list of all keys in this `store`.", &lisp_keys ); diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 3793709..8c4c5c0 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -388,7 +388,7 @@ struct cons_pointer make_symbol_or_key( wint_t c, struct cons_pointer tail, result = make_string_like_thing( c, tail, tag ); if ( tag == KEYTV ) { - struct cons_pointer r = internedp( result, oblist ); + struct cons_pointer r = interned( result, oblist ); if ( nilp( r ) ) { intern( result, oblist ); diff --git a/src/ops/equal.c b/src/ops/equal.c index b4412fb..ea813a9 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -375,8 +375,7 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { memset( a_buff, 0, sizeof( a_buff ) ); memset( b_buff, 0, sizeof( b_buff ) ); - for ( ; - ( i < ( STRING_SHIPYARD_SIZE - 1 ) ) && !nilp( a ) + for ( ; ( i < ( STRING_SHIPYARD_SIZE - 1 ) ) && !nilp( a ) && !nilp( b ); i++ ) { a_buff[i] = cell_a->payload.string.character; a = c_cdr( a ); diff --git a/src/ops/intern.c b/src/ops/intern.c index e064ac4..39e121f 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -270,54 +270,81 @@ struct cons_pointer clone_hashmap( struct cons_pointer ptr ) { // (keys set let quote read equal *out* *log* oblist cons source cond close meta mapcar negative? open subtract eval nλ *in* *sink* cdr set! reverse slurp try assoc eq add list time car t *prompt* absolute append apply divide exception get-hash hashmap inspect metadata multiply print put! put-all! read-char repl throw type + * - / = lambda λ nlambda progn) /** - * Implementation of interned? in C. The final implementation if interned? 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 key * from the store (so that later when we want to retrieve a value, an eq test * will work); otherwise return NIL. */ -struct cons_pointer -internedp( struct cons_pointer key, struct cons_pointer store ) { +struct cons_pointer interned( struct cons_pointer key, + struct cons_pointer store ) { struct cons_pointer result = NIL; if ( symbolp( key ) || keywordp( key ) ) { - // TODO: I see what I was doing here and it would be the right thing to - // do for stores which are old-fashioned assoc lists, but it will not work - // for my new hybrid stores. - // for ( struct cons_pointer next = store; - // nilp( result ) && consp( next ); - // next = pointer2cell( next ).payload.cons.cdr ) { - // struct cons_space_object entry = - // pointer2cell( pointer2cell( next ).payload.cons.car ); + struct cons_space_object *cell = &pointer2cell( store ); - // debug_print( L"Internedp: checking whether `", DEBUG_BIND ); - // debug_print_object( key, DEBUG_BIND ); - // debug_print( L"` equals `", DEBUG_BIND ); - // debug_print_object( entry.payload.cons.car, DEBUG_BIND ); - // debug_print( L"`\n", DEBUG_BIND ); + switch ( cell->tag.value ) { + case CONSTV: + for ( struct cons_pointer next = store; + nilp( result ) && consp( next ); + next = c_cdr( next) ) { + if ( !nilp( next ) ) { + // struct cons_space_object entry = + // pointer2cell( c_car( next) ); - // if ( equal( key, entry.payload.cons.car ) ) { - // result = entry.payload.cons.car; - // } - if ( !nilp( c_assoc( key, store ) ) ) { - result = key; - } else if ( equal( key, privileged_symbol_nil ) ) { - result = privileged_symbol_nil; + if ( equal( key, c_car(next) ) ) { + result = key; + } + } + } + break; + case VECTORPOINTTV: + if ( hashmapp( store ) || namespacep( store ) ) { + // get the right hash bucket and recursively call interned on that. + struct vector_space_object *map = pointer_to_vso( store ); + uint32_t bucket_no = + get_hash( key ) % map->payload.hashmap.n_buckets; + + result = + interned( key, + map->payload.hashmap.buckets[bucket_no] ); + } else { + result = + throw_exception( make_cons + ( c_string_to_lisp_string + ( L"Unexpected store type: " ), + c_type( store ) ), NIL ); + } + break; + default: + result = + throw_exception( make_cons + ( c_string_to_lisp_string + ( L"Unexpected store type: " ), + c_type( store ) ), NIL ); + break; } } else { - debug_print( L"`", DEBUG_BIND ); - debug_print_object( key, DEBUG_BIND ); - debug_print( L"` is a ", DEBUG_BIND ); - debug_printf( DEBUG_BIND, L"%4.4s", - ( char * ) pointer2cell( key ).tag.bytes ); - debug_print( L", not a KEYW or SYMB", DEBUG_BIND ); + result = + throw_exception( make_cons + ( c_string_to_lisp_string + ( L"Unexpected key type: " ), c_type( key ) ), + NIL ); } return result; } +/** + * @brief Implementation of `interned?` in C: predicate wrapped around interned. + * + * @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 ) { + return nilp( interned( key, store ) ) ? NIL : TRUE; +} + /** * Implementation of assoc in C. Like interned?, the final implementation will * deal with stores which can be association lists or hashtables or hybrids of @@ -370,7 +397,7 @@ struct cons_pointer c_assoc( struct cons_pointer key, // #endif } } - } else if ( hashmapp( store ) ) { + } else if ( hashmapp( store ) || namespacep( store ) ) { result = hashmap_get( store, key ); } else if ( !nilp( store ) ) { // #ifdef DEBUG @@ -426,7 +453,7 @@ struct cons_pointer set( struct cons_pointer key, struct cons_pointer value, struct cons_pointer result = NIL; #ifdef DEBUG - bool deep = vectorpointp( store ); + bool deep = eq( store, oblist); debug_print_binding( key, value, deep, DEBUG_BIND ); if ( deep ) { @@ -480,7 +507,7 @@ intern( struct cons_pointer key, struct cons_pointer environment ) { struct cons_pointer canonical = internedp( key, environment ); if ( nilp( canonical ) ) { /* - * not currently bound + * not currently bound. TODO: should this bind to NIL? */ result = set( key, TRUE, environment ); } diff --git a/src/ops/intern.h b/src/ops/intern.h index bc22bf7..4043e66 100644 --- a/src/ops/intern.h +++ b/src/ops/intern.h @@ -49,6 +49,9 @@ struct cons_pointer make_hashmap( uint32_t n_buckets, 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 ); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 7333c3f..be4227b 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -517,8 +517,7 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, case SYMBOLTV: { - struct cons_pointer canonical = - internedp( frame->arg[0], env ); + struct cons_pointer canonical = interned( frame->arg[0], env ); if ( nilp( canonical ) ) { struct cons_pointer message = make_cons( c_string_to_lisp_string @@ -835,7 +834,35 @@ struct cons_pointer lisp_length( struct stack_frame *frame, struct cons_pointer lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - return c_assoc( frame->arg[0], frame->arg[1] ); + 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( cell->payload.exception.payload, frame_pointer ); + dec_ref( old ); + } + + return result; } struct cons_pointer c_keys( struct cons_pointer store ) { diff --git a/src/ops/lispops.h b/src/ops/lispops.h index aea8772..06407c2 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -131,6 +131,9 @@ struct cons_pointer lisp_cdr( struct stack_frame *frame, 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 );