simon/post-scarcity
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

Hashmaps sort-of work but there are still bugs and one test is failing that wasn't.

Browse source
This commit is contained in:
Simon Brooke 2021-08-16 18:55:02 +01:00
parent bfd7304da1
commit 4fc9545be8
No known key found for this signature in database
GPG key ID: A7A4F18D1D4DF987
12 changed files with 206 additions and 487 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
src/init.c
View file

@ -23,10 +23,10 @@
#include "conspage.h" #include "conspage.h"
#include "consspaceobject.h" #include "consspaceobject.h"
#include "debug.h" #include "debug.h"
#include "hashmap.h"
#include "intern.h" #include "intern.h"
#include "io.h" #include "io.h"
#include "lispops.h" #include "lispops.h"
#include "map.h"
#include "meta.h" #include "meta.h"
#include "peano.h" #include "peano.h"
#include "print.h" #include "print.h"
@ -225,8 +225,10 @@ int main( int argc, char *argv[] ) {
bind_function( L"equal", &lisp_equal ); bind_function( L"equal", &lisp_equal );
bind_function( L"eval", &lisp_eval ); bind_function( L"eval", &lisp_eval );
bind_function( L"exception", &lisp_exception ); bind_function( L"exception", &lisp_exception );
bind_function( L"gethash", &lisp_get_hash);
bind_function(L"hashmap", lisp_make_hashmap);
bind_function( L"inspect", &lisp_inspect ); bind_function( L"inspect", &lisp_inspect );
bind_function( L"make-map", &lisp_make_map); bind_function( L"keys", &lisp_keys);
bind_function( L"meta", &lisp_metadata ); bind_function( L"meta", &lisp_metadata );
bind_function( L"metadata", &lisp_metadata ); bind_function( L"metadata", &lisp_metadata );
bind_function( L"multiply", &lisp_multiply ); bind_function( L"multiply", &lisp_multiply );
@ -235,6 +237,8 @@ int main( int argc, char *argv[] ) {
bind_function( L"open", &lisp_open ); bind_function( L"open", &lisp_open );
bind_function( L"print", &lisp_print ); bind_function( L"print", &lisp_print );
bind_function( L"progn", &lisp_progn ); bind_function( L"progn", &lisp_progn );
bind_function( L"put", lisp_hashmap_put);
bind_function( L"put-all", &lisp_hashmap_put_all);
bind_function( L"read", &lisp_read ); bind_function( L"read", &lisp_read );
bind_function( L"read-char", &lisp_read_char ); bind_function( L"read-char", &lisp_read_char );
bind_function( L"repl", &lisp_repl ); bind_function( L"repl", &lisp_repl );

46
src/io/print.c
View file

@ -19,9 +19,9 @@
#include "conspage.h" #include "conspage.h"
#include "consspaceobject.h" #include "consspaceobject.h"
#include "hashmap.h"
#include "integer.h" #include "integer.h"
#include "intern.h" #include "intern.h"
#include "map.h"
#include "stack.h" #include "stack.h"
#include "print.h" #include "print.h"
#include "psse_time.h" #include "psse_time.h"
@ -88,40 +88,38 @@ void print_list( URL_FILE * output, struct cons_pointer pointer ) {
url_fputws( L")", output ); url_fputws( L")", output );
} }
void print_map( URL_FILE *output, struct cons_pointer map ) {
if ( hashmapp( map ) ) {
struct vector_space_object *vso = pointer_to_vso( map );
void print_map( URL_FILE * output, struct cons_pointer map) { url_fputwc( btowc( '{' ), output );
if ( vectorpointp( map)) {
struct vector_space_object *vso = pointer_to_vso( map);
if ( mapp( vso ) ) { for ( struct cons_pointer ks = hashmap_keys( map ); !nilp( ks );
url_fputwc( btowc( '{' ), output ); ks = c_cdr( ks ) ) {
struct cons_pointer key = c_car( ks);
print( output, key );
url_fputwc( btowc( ' ' ), output );
print( output, hashmap_get( map, key ) );
for ( struct cons_pointer ks = keys( map); if ( !nilp( c_cdr( ks ) ) ) {
!nilp( ks); ks = c_cdr( ks)) { url_fputws( L", ", output );
print( output, c_car( ks)); }
url_fputwc( btowc( ' ' ), output );
print( output, c_assoc( c_car( ks), map));
if ( !nilp( c_cdr( ks))) {
url_fputws( L", ", output );
}
}
url_fputwc( btowc( '}' ), output );
}
} }
url_fputwc( btowc( '}' ), output );
}
} }
void print_vso( URL_FILE * output, struct cons_pointer pointer) { void print_vso( URL_FILE * output, struct cons_pointer pointer) {
struct vector_space_object *vso = struct vector_space_object *vso = pointer_to_vso(pointer);
pointer2cell( pointer ).payload.vectorp.address;
switch ( vso->header.tag.value) { switch ( vso->header.tag.value) {
case MAPTV: case HASHTV:
print_map( output, pointer); print_map( output, pointer);
break; break;
// \todo: others. // \todo: others.
default:
fwprintf( stderr, L"Unrecognised vector-space type '%d'\n",
vso->header.tag.value );
} }
} }

48
src/io/read.c
View file

@ -20,11 +20,11 @@
#include "consspaceobject.h" #include "consspaceobject.h"
#include "debug.h" #include "debug.h"
#include "dump.h" #include "dump.h"
#include "hashmap.h"
#include "integer.h" #include "integer.h"
#include "intern.h" #include "intern.h"
#include "io.h" #include "io.h"
#include "lispops.h" #include "lispops.h"
#include "map.h"
#include "peano.h" #include "peano.h"
#include "print.h" #include "print.h"
#include "ratio.h" #include "ratio.h"
@ -323,37 +323,39 @@ struct cons_pointer read_list( struct stack_frame *frame,
return result; return result;
} }
struct cons_pointer read_map( struct stack_frame *frame, struct cons_pointer read_map( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
URL_FILE * input, wint_t initial ) { URL_FILE *input, wint_t initial ) {
struct cons_pointer result = make_empty_map( NIL); // set write ACL to true whilst creating to prevent GC churn
wint_t c = initial; struct cons_pointer result = make_hashmap( DFLT_HASHMAP_BUCKETS, NIL, TRUE );
wint_t c = initial;
while ( c != L'}' ) { while ( c != L'}' ) {
struct cons_pointer key = struct cons_pointer key =
read_continuation( frame, frame_pointer, input, c ); read_continuation( frame, frame_pointer, input, c );
/* skip whitespace */ /* skip whitespace */
for (c = url_fgetwc( input ); for ( c = url_fgetwc( input ); iswblank( c ) || iswcntrl( c );
iswblank( c ) || iswcntrl( c ); c = url_fgetwc( input ) )
c = url_fgetwc( input )); ;
struct cons_pointer value = struct cons_pointer value =
read_continuation( frame, frame_pointer, input, c ); read_continuation( frame, frame_pointer, input, c );
/* skip commaa and whitespace at this point. */ /* skip commaa and whitespace at this point. */
for (c = url_fgetwc( input ); for ( c = url_fgetwc( input ); c == L',' || iswblank( c ) || iswcntrl( c );
c == L',' || iswblank( c ) || iswcntrl( c ); c = url_fgetwc( input ) )
c = url_fgetwc( input )); ;
result = merge_into_map( result, make_cons( make_cons( key, value), NIL)); result = hashmap_put( result, key, value );
} }
return result; // default write ACL for maps should be NIL.
pointer_to_vso( result )->payload.hashmap.write_acl = NIL;
return result;
} }
/** /**
* Read a string. This means either a string delimited by double quotes * Read a string. This means either a string delimited by double quotes
* (is_quoted == true), in which case it may contain whitespace but may * (is_quoted == true), in which case it may contain whitespace but may

8
src/memory/dump.c
View file

@ -21,8 +21,8 @@
#include "conspage.h" #include "conspage.h"
#include "consspaceobject.h" #include "consspaceobject.h"
#include "debug.h" #include "debug.h"
#include "hashmap.h"
#include "intern.h" #include "intern.h"
#include "map.h"
#include "print.h" #include "print.h"
#include "stack.h" #include "stack.h"
#include "vectorspace.h" #include "vectorspace.h"
@ -141,14 +141,12 @@ void dump_object( URL_FILE * output, struct cons_pointer pointer ) {
L"\t\tVector space object of type %4.4s (%d), payload size %d bytes\n", L"\t\tVector space object of type %4.4s (%d), payload size %d bytes\n",
&vso->header.tag.bytes, vso->header.tag.value, &vso->header.tag.bytes, vso->header.tag.value,
vso->header.size ); vso->header.size );
if ( stackframep( vso ) ) {
dump_frame( output, pointer );
}
switch ( vso->header.tag.value ) { switch ( vso->header.tag.value ) {
case STACKFRAMETV: case STACKFRAMETV:
dump_frame( output, pointer ); dump_frame( output, pointer );
break; break;
case MAPTV: case HASHTV:
dump_map( output, pointer); dump_map( output, pointer);
break; break;
} }

70
src/memory/hashmap.c
View file

@ -11,6 +11,8 @@
#include "arith/peano.h" #include "arith/peano.h"
#include "authorise.h" #include "authorise.h"
#include "debug.h" #include "debug.h"
#include "intern.h"
#include "memory/conspage.h"
#include "memory/consspaceobject.h" #include "memory/consspaceobject.h"
#include "memory/hashmap.h" #include "memory/hashmap.h"
#include "memory/vectorspace.h" #include "memory/vectorspace.h"
@ -81,10 +83,12 @@ void free_hashmap( struct cons_pointer pointer ) {
dec_ref( payload.write_acl ); dec_ref( payload.write_acl );
for ( int i = 0; i < payload.n_buckets; i++ ) { for ( int i = 0; i < payload.n_buckets; i++ ) {
debug_printf( DEBUG_ALLOC, if ( !nilp( payload.buckets[i] ) ) {
L"Decrementing buckets[%d] of hashmap at 0x%lx\n", i, debug_printf( DEBUG_ALLOC,
cell->payload.vectorp.address ); L"Decrementing bucket [%d] of hashmap at 0x%lx\n", i,
dec_ref( payload.buckets[i] ); cell->payload.vectorp.address );
dec_ref( payload.buckets[i] );
}
} }
} else { } else {
debug_printf( DEBUG_ALLOC, L"Non-hashmap passed to `free_hashmap`\n" ); debug_printf( DEBUG_ALLOC, L"Non-hashmap passed to `free_hashmap`\n" );
@ -137,7 +141,7 @@ struct cons_pointer make_hashmap( uint32_t n_buckets,
struct cons_pointer lisp_make_hashmap( struct stack_frame *frame, struct cons_pointer lisp_make_hashmap( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
uint32_t n = 32; uint32_t n = DFLT_HASHMAP_BUCKETS;
struct cons_pointer hash_fn = NIL; struct cons_pointer hash_fn = NIL;
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
@ -185,6 +189,8 @@ struct cons_pointer lisp_make_hashmap( struct stack_frame *frame,
return result; return result;
} }
/** /**
* If this `ptr` is a pointer to a hashmap, return a new identical hashmap; * If this `ptr` is a pointer to a hashmap, return a new identical hashmap;
* else return `NIL`. TODO: should return an exception if ptr is not a * else return `NIL`. TODO: should return an exception if ptr is not a
@ -243,6 +249,19 @@ struct cons_pointer hashmap_put( struct cons_pointer mapp,
return mapp; return mapp;
} }
struct cons_pointer hashmap_get( struct cons_pointer mapp,
struct cons_pointer key ) {
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 = c_assoc( key, map->payload.hashmap.buckets[bucket_no] );
}
return result;
}
/** /**
* Expects `frame->arg[1]` to be a hashmap or namespace; `frame->arg[2]` to be * Expects `frame->arg[1]` to be a hashmap or namespace; `frame->arg[2]` to be
* a string-like-thing (perhaps necessarily a keyword); frame->arg[3] to be * a string-like-thing (perhaps necessarily a keyword); frame->arg[3] to be
@ -294,3 +313,44 @@ struct cons_pointer lisp_hashmap_put_all( struct stack_frame *frame,
return hashmap_put_all( frame->arg[0], frame->arg[1] ); return hashmap_put_all( frame->arg[0], frame->arg[1] );
} }
/**
* 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;
}
struct cons_pointer lisp_hashmap_keys( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return hashmap_keys( frame->arg[0] );
}
void dump_map( URL_FILE *output, struct cons_pointer pointer ) {
struct hashmap_payload *payload = &pointer_to_vso( pointer )->payload.hashmap;
url_fwprintf( output, L"Hashmap with %d buckets:\n", payload->n_buckets );
url_fwprintf( output, L"\tHash function: " );
print( output, payload->hash_fn );
url_fwprintf( output, L"\n\tWrite ACL: " );
print( output, payload->write_acl );
url_fwprintf( output, L"\n\tBuckets:" );
for ( int i = 0; i < payload->n_buckets; i++ ) {
url_fwprintf( output, L"\n\t\t[%d]: ", i );
print( output, payload->buckets[i] );
}
url_fwprintf( output, L"\n" );
}

17
src/memory/hashmap.h
View file

@ -15,14 +15,27 @@
#include "memory/consspaceobject.h" #include "memory/consspaceobject.h"
#include "memory/vectorspace.h" #include "memory/vectorspace.h"
#define DFLT_HASHMAP_BUCKETS 32
uint32_t get_hash( struct cons_pointer ptr ); uint32_t get_hash( struct cons_pointer ptr );
void free_hashmap( 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 );
struct cons_pointer hashmap_put( struct cons_pointer mapp,
struct cons_pointer key,
struct cons_pointer val );
struct cons_pointer lisp_get_hash( struct stack_frame *frame, struct cons_pointer lisp_get_hash( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer hashmap_keys( struct cons_pointer map );
struct cons_pointer lisp_hashmap_put( struct stack_frame *frame, struct cons_pointer lisp_hashmap_put( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
@ -35,4 +48,8 @@ struct cons_pointer lisp_make_hashmap( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer make_hashmap( uint32_t n_buckets,
struct cons_pointer hash_fn,
struct cons_pointer write_acl );
#endif #endif

289
src/memory/map.c
View file

@ -1,289 +0,0 @@
/*
* map.c
*
* An immutable hashmap in vector space.
*
* (c) 2019 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdlib.h>
#include "consspaceobject.h"
#include "conspage.h"
#include "debug.h"
#include "dump.h"
#include "fopen.h"
#include "intern.h"
#include "io.h"
#include "lookup3.h"
#include "map.h"
#include "print.h"
#include "vectorspace.h"
/* \todo: a lot of this will be inherited by namespaces, regularities and
* homogeneities. Exactly how I don't yet know. */
/**
* Get a hash value for this key.
*/
uint32_t get_hash_32(struct cons_pointer f, struct cons_pointer key) {
uint32_t result = 0;
int l = c_length(key);
if (keywordp(key) || stringp(key) || symbolp( key)) {
if ( l > 0) {
uint32_t buffer[l];
if (!nilp(f)) {
fputws(L"Custom hashing functions are not yet implemented.\n", stderr);
}
for (int i = 0; i < l; i++) {
buffer[i] = (uint32_t)pointer2cell(key).payload.string.character;
}
result = hashword( buffer, l, 0);
}
} else {
fputws(L"Hashing is thus far implemented only for keys, strings and symbols.\n", stderr);
}
return result;
}
/**
* get the actual map object from this `pointer`, or NULL if
* `pointer` is not a map pointer.
*/
struct map_payload *get_map_payload( struct cons_pointer pointer ) {
struct map_payload *result = NULL;
struct vector_space_object *vso =
pointer2cell( pointer ).payload.vectorp.address;
if (vectorpointp(pointer) && mapp( vso ) ) {
result = ( struct map_payload * ) &( vso->payload );
debug_printf( DEBUG_BIND,
L"get_map_payload: all good, returning %p\n", result );
} else {
debug_print( L"get_map_payload: fail, returning NULL\n", DEBUG_BIND );
}
return result;
}
/**
* Make an empty immutable map, and return it.
*
* @param hash_function a pointer to a function of one argument, which
* returns an integer; or (more usually) `nil`.
* @return the new map, or NULL if memory is exhausted.
*/
struct cons_pointer make_empty_map( struct cons_pointer hash_function ) {
debug_print( L"Entering make_empty_map\n", DEBUG_BIND );
struct cons_pointer result =
make_vso( MAPTAG, sizeof( struct map_payload ) );
if ( !nilp( result ) ) {
struct map_payload *payload = get_map_payload( result );
payload->hash_function = functionp( hash_function) ? hash_function : NIL;
inc_ref(hash_function);
for ( int i = 0; i < BUCKETSINMAP; i++) {
payload->buckets[i] = NIL;
}
}
debug_print( L"Leaving make_empty_map\n", DEBUG_BIND );
return result;
}
struct cons_pointer make_duplicate_map( struct cons_pointer parent) {
struct cons_pointer result = NIL;
struct map_payload * parent_payload = get_map_payload(parent);
if (parent_payload != NULL) {
result =
make_vso( MAPTAG, sizeof( struct map_payload ) );
if ( !nilp( result ) ) {
struct map_payload *payload = get_map_payload( result );
payload->hash_function = parent_payload->hash_function;
inc_ref(payload->hash_function);
for ( int i = 0; i < BUCKETSINMAP; i++) {
payload->buckets[i] = parent_payload->buckets[i];
inc_ref(payload->buckets[i]);
}
}
}
return result;
}
struct cons_pointer bind_in_map( struct cons_pointer parent,
struct cons_pointer key,
struct cons_pointer value) {
struct cons_pointer result = make_duplicate_map(parent);
if ( !nilp( result)) {
struct map_payload * payload = get_map_payload( result );
int bucket = get_hash_32(payload->hash_function, key) % BUCKETSINMAP;
payload->buckets[bucket] = make_cons(
make_cons(key, value), payload->buckets[bucket]);
inc_ref(payload->buckets[bucket]);
}
return result;
}
struct cons_pointer keys( struct cons_pointer store) {
debug_print( L"Entering keys\n", DEBUG_BIND );
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( store );
switch (pointer2cell( store ).tag.value) {
case CONSTV:
for (struct cons_pointer c = store; !nilp(c); c = c_cdr(c)) {
result = make_cons( c_car( c_car( c)), result);
}
break;
case VECTORPOINTTV: {
struct vector_space_object *vso =
pointer2cell( store ).payload.vectorp.address;
if ( mapp( vso ) ) {
struct map_payload * payload = get_map_payload( store );
for (int bucket = 0; bucket < BUCKETSINMAP; bucket++) {
for (struct cons_pointer c = payload->buckets[bucket];
!nilp(c); c = c_cdr(c)) {
debug_print( L"keys: c is ", DEBUG_BIND);
debug_print_object( c, DEBUG_BIND);
result = make_cons( c_car( c_car( c)), result);
debug_print( L"; result is ", DEBUG_BIND);
debug_print_object( result, DEBUG_BIND);
debug_println( DEBUG_BIND);
}
}
}
}
break;
}
debug_print( L"keys returning ", DEBUG_BIND );
debug_print_object( result, DEBUG_BIND );
debug_println( DEBUG_BIND);
return result;
}
/**
* Return a new map which represents the merger of `to_merge` into
* `parent`. `parent` must be a map, but `to_merge` may be a map or
* an assoc list.
*
* @param parent a map;
* @param to_merge an association from which key/value pairs will be merged.
* @result a new map, containing all key/value pairs from `to_merge`
* together with those key/value pairs from `parent` whose keys did not
* collide.
*/
struct cons_pointer merge_into_map( struct cons_pointer parent,
struct cons_pointer to_merge) {
debug_print( L"Entering merge_into_map\n", DEBUG_BIND );
struct cons_pointer result = make_duplicate_map(parent);
if (!nilp(result)) {
struct map_payload *payload = get_map_payload( result );
for (struct cons_pointer c = keys(to_merge);
!nilp(c); c = c_cdr(c)) {
struct cons_pointer key = c_car( c);
int bucket = get_hash_32(payload->hash_function, key) % BUCKETSINMAP;
payload->buckets[bucket] = make_cons(
make_cons( key, c_assoc( key, to_merge)),
payload->buckets[bucket]);
}
}
debug_print( L"Leaving merge_into_map\n", DEBUG_BIND );
return result;
}
struct cons_pointer assoc_in_map( struct cons_pointer key,
struct cons_pointer map) {
debug_print( L"Entering assoc_in_map\n", DEBUG_BIND );
struct cons_pointer result = NIL;
struct map_payload *payload = get_map_payload( map );
if (payload != NULL) {
int bucket = get_hash_32(payload->hash_function, key) % BUCKETSINMAP;
result = c_assoc(key, payload->buckets[bucket]);
}
debug_print( L"assoc_in_map returning ", DEBUG_BIND );
debug_print_object( result, DEBUG_BIND);
debug_println( DEBUG_BIND);
return result;
}
/**
* Function: create a map initialised with key/value pairs from my
* first argument.
*
* * (make-map)
* * (make-map store)
*
* @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 a new containing all the key/value pairs from store.
*/
struct cons_pointer
lisp_make_map( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return merge_into_map( make_empty_map( NIL), frame->arg[0]);
}
/**
* Dump a map to this stream for debugging
* @param output the stream
* @param map_pointer the pointer to the frame
*/
void dump_map( URL_FILE * output, struct cons_pointer map_pointer ) {
struct vector_space_object *vso =
pointer2cell( map_pointer ).payload.vectorp.address;
if (vectorpointp(map_pointer) && mapp( vso ) ) {
struct map_payload *payload = get_map_payload( map_pointer );
if ( payload != NULL ) {
url_fputws( L"Immutable map; hash function: ", output );
if (nilp(payload->hash_function)) {
url_fputws( L"default", output);
} else {
dump_object( output, payload->hash_function);
}
for (int i = 0; i < BUCKETSINMAP; i++) {
url_fwprintf(output, L"\n\tBucket %d: ", i);
print( output, payload->buckets[i]);
}
}
}
}

96
src/memory/map.h
View file

@ -1,96 +0,0 @@
/*
* map.h
*
* An immutable hashmap in vector space.
*
* (c) 2019 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __psse_map_h
#define __psse_map_h
#include "consspaceobject.h"
#include "conspage.h"
/**
* macros for the tag of a mutable map.
*/
#define MAPTAG "IMAP"
#define MAPTV 1346456905
/**
* Number of buckets in a single tier map.
*/
#define BUCKETSINMAP 256
/**
* Maximum number of entries in an association-list bucket.
*/
#define MAXENTRIESINASSOC 16
/**
* true if this vector_space_object is a map, else false.
*/
#define mapp( vso) (((struct vector_space_object *)vso)->header.tag.value == MAPTV)
/**
* The vector-space payload of a map object. Essentially a vector of
* `BUCKETSINMAP` + 1 `cons_pointer`s, but the first one is considered
* special.
*/
struct map_payload {
/**
* There is a default hash function, which is used if `hash_function` is
* `nil` (which it normally should be); and keywords will probably carry
* their own hash values. But it will be possible to override the hash
* function by putting a function of one argument returning an integer
* here. */
struct cons_pointer hash_function;
/**
* Obviously the number of buckets in a map is a trade off, and this may need
* tuning - or it may even be necessary to have different sized base maps. The
* idea here is that the value of a bucket is
*
* 1. `nil`; or
* 2. an association list; or
* 3. a map.
*
* All buckets are initially `nil`. Adding a value to a `nil` bucket returns
* a map with a new bucket in the form of an assoc list. Subsequent additions
* cons new key/value pairs onto the assoc list, until there are
* `MAXENTRIESINASSOC` pairs, at which point if a further value is added to
* the same bucket the bucket returned will be in the form of a second level
* map. My plan is that buckets the first level map will be indexed on the
* first sixteen bits of the hash value, those in the second on the second
* sixteen, and, potentially, so on.
*/
struct cons_pointer buckets[BUCKETSINMAP];
};
uint32_t get_hash_32(struct cons_pointer f, struct cons_pointer key);
struct map_payload *get_map_payload( struct cons_pointer pointer );
struct cons_pointer make_empty_map( struct cons_pointer hash_function );
struct cons_pointer bind_in_map( struct cons_pointer parent,
struct cons_pointer key,
struct cons_pointer value);
struct cons_pointer keys( struct cons_pointer store);
struct cons_pointer merge_into_map( struct cons_pointer parent,
struct cons_pointer to_merge);
struct cons_pointer assoc_in_map( struct cons_pointer key,
struct cons_pointer map);
struct cons_pointer lisp_make_map( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
void dump_map( URL_FILE * output, struct cons_pointer map_pointer );
#endif

8
src/memory/vectorspace.h
View file

@ -27,15 +27,17 @@
* part of the implementation structure of a namespace. * part of the implementation structure of a namespace.
*/ */
#define HASHTAG "HASH" #define HASHTAG "HASH"
#define HASHTV 0 #define HASHTV 1213415752
#define hashmapp(conspoint)((check_tag(conspoint,HASHTAG))) #define hashmapp(conspoint)((check_tag(conspoint,HASHTAG)))
/* /*
* a namespace (i.e. a binding of names to values, implemented as a hashmap) * a namespace (i.e. a binding of names to values, implemented as a hashmap)
* TODO: but note that a namespace is now essentially a hashmap with a write ACL
* whose name is interned.
*/ */
#define NAMESPACETAG "NMSP" #define NAMESPACETAG "NMSP"
#define NAMESPACETV 0 #define NAMESPACETV 1347636558
#define namespacep(conspoint)(check_tag(conspoint,NAMESPACETAG)) #define namespacep(conspoint)(check_tag(conspoint,NAMESPACETAG))
@ -43,7 +45,7 @@
* a vector of cons pointers. * a vector of cons pointers.
*/ */
#define VECTORTAG "VECT" #define VECTORTAG "VECT"
#define VECTORTV 0 #define VECTORTV 1413694806
#define vectorp(conspoint)(check_tag(conspoint,VECTORTAG)) #define vectorp(conspoint)(check_tag(conspoint,VECTORTAG))

8
src/ops/intern.c
View file

@ -25,7 +25,6 @@
#include "equal.h" #include "equal.h"
#include "hashmap.h" #include "hashmap.h"
#include "lispops.h" #include "lispops.h"
#include "map.h"
#include "print.h" #include "print.h"
/** /**
@ -109,7 +108,7 @@ struct cons_pointer c_assoc( struct cons_pointer key,
} }
} }
} else if (hashmapp( store)) { } else if (hashmapp( store)) {
result = assoc_in_map( key, store); result = hashmap_get( store, key);
} else { } else {
result = throw_exception(c_string_to_lisp_string(L"Store is of unknown type"), NIL); result = throw_exception(c_string_to_lisp_string(L"Store is of unknown type"), NIL);
} }
@ -140,8 +139,8 @@ struct cons_pointer
if (nilp( store) || consp(store)) { if (nilp( store) || consp(store)) {
result = make_cons( make_cons( key, value ), store ); result = make_cons( make_cons( key, value ), store );
} else if (vectorpointp( store)) { } else if (hashmapp( store)) {
result = bind_in_map( store, key, value); result = hashmap_put( store, key, value);
} }
debug_print( L"set returning ", DEBUG_BIND); debug_print( L"set returning ", DEBUG_BIND);
@ -196,3 +195,4 @@ intern( struct cons_pointer key, struct cons_pointer environment ) {
return result; return result;
} }

23
src/ops/lispops.c
View file

@ -33,7 +33,6 @@
#include "intern.h" #include "intern.h"
#include "io.h" #include "io.h"
#include "lispops.h" #include "lispops.h"
#include "map.h"
#include "print.h" #include "print.h"
#include "read.h" #include "read.h"
#include "stack.h" #include "stack.h"
@ -378,7 +377,7 @@ struct cons_pointer
case VECTORPOINTTV: case VECTORPOINTTV:
switch ( pointer_to_vso(fn_pointer)->header.tag.value) { switch ( pointer_to_vso(fn_pointer)->header.tag.value) {
case MAPTV: case HASHTV:
/* \todo: if arg[0] is a CONS, treat it as a path */ /* \todo: if arg[0] is a CONS, treat it as a path */
result = c_assoc( eval_form(frame, result = c_assoc( eval_form(frame,
frame_pointer, frame_pointer,
@ -803,6 +802,26 @@ lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer,
return c_assoc( frame->arg[0], frame->arg[1] ); return c_assoc( frame->arg[0], frame->arg[1] );
} }
struct cons_pointer c_keys(struct cons_pointer store) {
struct cons_pointer result = NIL;
if ( hashmapp( store ) ) {
result = hashmap_keys( store );
} else if ( consp( store ) ) {
for ( struct cons_pointer c = store; !nilp( c ); c = c_cdr( c ) ) {
result = make_cons( c_car( c ), result );
}
}
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. * Function; are these two objects the same object? Shallow, cheap equality.
* *

72
src/ops/lispops.h
View file

@ -26,12 +26,14 @@
* utilities * utilities
*/ */
struct cons_pointer c_keys( struct cons_pointer store );
struct cons_pointer c_reverse( struct cons_pointer arg ); struct cons_pointer c_reverse( struct cons_pointer arg );
struct cons_pointer struct cons_pointer c_progn( struct stack_frame *frame,
c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer expressions, struct cons_pointer env ); struct cons_pointer expressions,
struct cons_pointer env );
/** /**
* Useful building block; evaluate this single form in the context of this * Useful building block; evaluate this single form in the context of this
@ -56,7 +58,6 @@ struct cons_pointer eval_forms( struct stack_frame *frame,
struct cons_pointer list, struct cons_pointer list,
struct cons_pointer env ); struct cons_pointer env );
/* /*
* special forms * special forms
*/ */
@ -67,17 +68,21 @@ struct cons_pointer lisp_apply( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer struct cons_pointer lisp_keys( struct stack_frame *frame,
lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer struct cons_pointer lisp_oblist( struct stack_frame *frame,
lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer struct cons_pointer lisp_set( struct stack_frame *frame,
lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ); 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. * Construct an interpretable function.
@ -90,17 +95,17 @@ struct cons_pointer lisp_lambda( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_length( struct stack_frame *frame, struct cons_pointer lisp_length( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
/** /**
* Construct an interpretable special form. * Construct an interpretable special form.
* *
* @param frame the stack frame in which the expression is to be interpreted; * @param frame the stack frame in which the expression is to be interpreted;
* @param env the environment in which it is to be intepreted. * @param env the environment in which it is to be intepreted.
*/ */
struct cons_pointer struct cons_pointer lisp_nlambda( struct stack_frame *frame,
lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_quote( struct stack_frame *frame, struct cons_pointer lisp_quote( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
@ -146,10 +151,9 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame,
* @param env My environment (ignored). * @param env My environment (ignored).
* @return As a Lisp string, the tag of the object which is the argument. * @return As a Lisp string, the tag of the object which is the argument.
*/ */
struct cons_pointer struct cons_pointer lisp_type( struct stack_frame *frame,
lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
/** /**
* Function; evaluate the forms which are listed in my single argument * Function; evaluate the forms which are listed in my single argument
@ -161,9 +165,9 @@ lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer,
* @return the value of the last form on the sequence which is my single * @return the value of the last form on the sequence which is my single
* argument. * argument.
*/ */
struct cons_pointer struct cons_pointer lisp_progn( struct stack_frame *frame,
lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
/** /**
* Special form: conditional. Each arg is expected to be a list; if the first * Special form: conditional. Each arg is expected to be a list; if the first
@ -174,22 +178,22 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer,
* @param env My environment (ignored). * @param env My environment (ignored).
* @return the value of the last form of the first successful clause. * @return the value of the last form of the first successful clause.
*/ */
struct cons_pointer struct cons_pointer lisp_cond( struct stack_frame *frame,
lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
/** /**
* Throw an exception. * Throw an exception.
* `throw_exception` is a misnomer, because it doesn't obey the calling signature of a * `throw_exception` is a misnomer, because it doesn't obey the calling
* lisp function; but it is nevertheless to be preferred to make_exception. A * signature of a lisp function; but it is nevertheless to be preferred to
* real `throw_exception`, which does, will be needed. * make_exception. A real `throw_exception`, which does, will be needed.
*/ */
struct cons_pointer throw_exception( struct cons_pointer message, struct cons_pointer throw_exception( struct cons_pointer message,
struct cons_pointer frame_pointer ); struct cons_pointer frame_pointer );
struct cons_pointer struct cons_pointer lisp_exception( struct stack_frame *frame,
lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_source( struct stack_frame *frame, struct cons_pointer lisp_source( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,