Rewriting intern. This is badly broken, but I think on the road to better.
This commit is contained in:
parent
145a0fe5a7
commit
72548097cf
7 changed files with 103 additions and 41 deletions
|
|
@ -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 );
|
||||
|
|
|
|||
|
|
@ -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 );
|
||||
|
|
|
|||
|
|
@ -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 );
|
||||
|
|
|
|||
|
|
@ -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 *cell = &pointer2cell( store );
|
||||
|
||||
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( pointer2cell( next ).payload.cons.car );
|
||||
// pointer2cell( c_car( next) );
|
||||
|
||||
// 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 );
|
||||
|
||||
// if ( equal( key, entry.payload.cons.car ) ) {
|
||||
// result = entry.payload.cons.car;
|
||||
// }
|
||||
if ( !nilp( c_assoc( key, store ) ) ) {
|
||||
if ( equal( key, c_car(next) ) ) {
|
||||
result = key;
|
||||
} else if ( equal( key, privileged_symbol_nil ) ) {
|
||||
result = privileged_symbol_nil;
|
||||
}
|
||||
}
|
||||
}
|
||||
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 );
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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 );
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ) {
|
||||
|
|
|
|||
|
|
@ -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 );
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue