215 lines
7.7 KiB
C
215 lines
7.7 KiB
C
/*
|
|
* intern.c
|
|
*
|
|
* For now this implements an oblist and shallow binding; local environments can
|
|
* be consed onto the front of the oblist. Later, this won't do; bindings will happen
|
|
* in namespaces, which will probably be implemented as hash tables.
|
|
*
|
|
* Doctrine is that cons cells are immutable, and life is a lot more simple if they are;
|
|
* so when a symbol is rebound in the master oblist, what in fact we do is construct
|
|
* a new oblist without the previous binding but with the new binding. Anything which,
|
|
* prior to this action, held a pointer to the old oblist (as all current threads'
|
|
* environments must do) continues to hold a pointer to the old oblist, and consequently
|
|
* doesn't see the change. This is probably good but does mean you cannot use bindings
|
|
* on the oblist to signal between threads.
|
|
*
|
|
* (c) 2017 Simon Brooke <simon@journeyman.cc>
|
|
* Licensed under GPL version 2.0, or, at your option, any later version.
|
|
*/
|
|
|
|
#include <stdbool.h>
|
|
|
|
#include "memory/conspage.h"
|
|
#include "memory/consspaceobject.h"
|
|
#include "debug.h"
|
|
#include "ops/equal.h"
|
|
#include "memory/hashmap.h"
|
|
#include "ops/lispops.h"
|
|
// #include "print.h"
|
|
|
|
/**
|
|
* 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;
|
|
|
|
/**
|
|
* 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 result = NIL;
|
|
|
|
if ( symbolp( key ) || keywordp( key ) ) {
|
|
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 );
|
|
|
|
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;
|
|
}
|
|
}
|
|
} else {
|
|
debug_print( L"`", DEBUG_BIND );
|
|
debug_print_object( key, DEBUG_BIND );
|
|
debug_print( L"` is a ", DEBUG_BIND );
|
|
debug_print_object( c_type( key ), DEBUG_BIND );
|
|
debug_print( L", not a KEYW or SYMB", DEBUG_BIND );
|
|
}
|
|
|
|
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 ) {
|
|
struct cons_pointer result = NIL;
|
|
|
|
debug_print( L"c_assoc; key is `", DEBUG_BIND );
|
|
debug_print_object( key, DEBUG_BIND );
|
|
debug_print( L"`\n", DEBUG_BIND );
|
|
|
|
if ( consp( store ) ) {
|
|
for ( struct cons_pointer next = store;
|
|
nilp( result ) && ( consp( next ) || hashmapp( next ) );
|
|
next = pointer2cell( next ).payload.cons.cdr ) {
|
|
if ( consp( next ) ) {
|
|
struct cons_pointer entry_ptr = c_car( next );
|
|
struct cons_space_object entry = pointer2cell( entry_ptr );
|
|
|
|
switch ( entry.tag.value ) {
|
|
case CONSTV:
|
|
if ( equal( key, entry.payload.cons.car ) ) {
|
|
result = entry.payload.cons.cdr;
|
|
}
|
|
break;
|
|
case VECTORPOINTTV:
|
|
result = hashmap_get( entry_ptr, key );
|
|
break;
|
|
default:
|
|
throw_exception( c_string_to_lisp_string
|
|
( L"Store entry is of unknown type" ),
|
|
NIL );
|
|
}
|
|
}
|
|
}
|
|
} else if ( hashmapp( store ) ) {
|
|
result = hashmap_get( store, key );
|
|
} else if ( !nilp( store ) ) {
|
|
result =
|
|
throw_exception( c_string_to_lisp_string
|
|
( L"Store is of unknown type" ), NIL );
|
|
}
|
|
|
|
debug_print( L"c_assoc returning ", DEBUG_BIND );
|
|
debug_print_object( result, DEBUG_BIND );
|
|
debug_println( DEBUG_BIND );
|
|
|
|
return result;
|
|
}
|
|
|
|
/**
|
|
* 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;
|
|
|
|
debug_print( L"set: binding `", DEBUG_BIND );
|
|
debug_print_object( key, DEBUG_BIND );
|
|
debug_print( L"` to `", DEBUG_BIND );
|
|
debug_print_object( value, DEBUG_BIND );
|
|
debug_print( L"` in store ", DEBUG_BIND );
|
|
debug_dump_object( store, DEBUG_BIND );
|
|
debug_println( DEBUG_BIND );
|
|
|
|
if ( nilp( store ) || consp( store ) ) {
|
|
result = make_cons( make_cons( key, value ), store );
|
|
} else if ( hashmapp( store ) ) {
|
|
result = hashmap_put( store, key, value );
|
|
}
|
|
|
|
debug_print( L"set returning ", DEBUG_BIND );
|
|
debug_print_object( result, DEBUG_BIND );
|
|
debug_println( DEBUG_BIND );
|
|
|
|
return result;
|
|
}
|
|
|
|
/**
|
|
* Binds this key to this value in the global oblist, but doesn't affect the
|
|
* current environment. May not be useful except in bootstrapping (and even
|
|
* there it may not be especially useful).
|
|
*/
|
|
struct cons_pointer
|
|
deep_bind( struct cons_pointer key, struct cons_pointer value ) {
|
|
debug_print( L"Entering deep_bind\n", DEBUG_BIND );
|
|
struct cons_pointer old = oblist;
|
|
|
|
debug_print( L"deep_bind: binding `", DEBUG_BIND );
|
|
debug_print_object( key, DEBUG_BIND );
|
|
debug_print( L"` to ", DEBUG_BIND );
|
|
debug_print_object( value, DEBUG_BIND );
|
|
debug_println( DEBUG_BIND );
|
|
|
|
oblist = set( key, value, oblist );
|
|
|
|
if ( consp( oblist ) ) {
|
|
inc_ref( oblist );
|
|
dec_ref( old );
|
|
}
|
|
|
|
debug_print( L"deep_bind returning ", DEBUG_BIND );
|
|
debug_print_object( oblist, DEBUG_BIND );
|
|
debug_println( DEBUG_BIND );
|
|
|
|
return oblist;
|
|
}
|
|
|
|
/**
|
|
* 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 NIL.
|
|
*/
|
|
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
|
|
*/
|
|
result = set( key, NIL, environment );
|
|
}
|
|
|
|
return result;
|
|
}
|