Merge branch 'develop' into feature/time

.gitignore

@@ -36,3 +36,5 @@ utils_src/readprintwc/out
 *.bak
 
 src/io/fopen
+
+hi\.*

src/init.c

@@ -26,6 +26,7 @@
 #include "intern.h"
 #include "io.h"
 #include "lispops.h"
+#include "map.h"
 #include "meta.h"
 #include "peano.h"
 #include "print.h"
@@ -68,7 +69,7 @@ void bind_special( wchar_t *name, struct cons_pointer ( *executable )
                                          n ),
                               NIL ) );
 
-    deep_bind( n, make_special( NIL, executable ) );
+    deep_bind( n, make_special( meta, executable ) );
 }
 
 /**
@@ -196,6 +197,7 @@ int main( int argc, char *argv[] ) {
     bind_function( L"eval", &lisp_eval );
     bind_function( L"exception", &lisp_exception );
     bind_function( L"inspect", &lisp_inspect );
+    bind_function( L"make-map", &lisp_make_map);
     bind_function( L"meta", &lisp_metadata );
     bind_function( L"metadata", &lisp_metadata );
     bind_function( L"multiply", &lisp_multiply );

src/io/io.c

@@ -15,6 +15,7 @@
 #include <pwd.h>
 #include <stdlib.h>
 #include <string.h>
+#include <time.h>
 #include <sys/stat.h>
 #include <sys/types.h>
 #include <unistd.h>
@@ -277,9 +278,11 @@ struct cons_pointer add_meta_time( struct cons_pointer meta, wchar_t *key,
     /* I don't yet have a concept of a date-time object, which is a
      * bit of an oversight! */
     char datestring[256];
-    struct tm *tm = localtime( value );
 
-    strftime( datestring, sizeof( datestring ), nl_langinfo( D_T_FMT ), tm );
+    strftime( datestring,
+             sizeof( datestring ),
+             nl_langinfo( D_T_FMT ),
+             localtime( value ) );
 
     return add_meta_string( meta, key, datestring );
 }
@@ -375,13 +378,13 @@ void collect_meta( struct cons_pointer stream, char *url ) {
                 meta =
                     add_meta_integer( meta, L"size",
                                       ( intmax_t ) statbuf.st_size );
-
+/*
                 meta = add_meta_time( meta, L"modified", &statbuf.st_mtime );
+*/
             }
             break;
         case CFTYPE_CURL:
             curl_easy_setopt( s->handle.curl, CURLOPT_VERBOSE, 1L );
-            curl_easy_setopt( s->handle.curl, CURLOPT_HEADER, 1L );
             curl_easy_setopt( s->handle.curl, CURLOPT_HEADERFUNCTION,
                               write_meta_callback );
             curl_easy_setopt( s->handle.curl, CURLOPT_HEADERDATA, stream );

src/io/print.c

@@ -20,9 +20,12 @@
 #include "conspage.h"
 #include "consspaceobject.h"
 #include "integer.h"
+#include "intern.h"
+#include "map.h"
 #include "stack.h"
 #include "print.h"
 #include "time.h"
+#include "vectorspace.h"
 
 /**
  * Whether or not we colorise output.
@@ -98,7 +101,43 @@ void print_list( URL_FILE * output, struct cons_pointer pointer ) {
     } else {
         url_fputws( L")", output );
     }
+}
 
+
+void print_map( URL_FILE * output, struct cons_pointer map) {
+    if ( vectorpointp( map)) {
+        struct vector_space_object *vso = pointer_to_vso( map);
+
+        if ( mapp( vso ) ) {
+            url_fputwc( btowc( '{' ), output );
+
+            for ( struct cons_pointer ks = keys( map);
+                 !nilp( ks); ks = c_cdr( ks)) {
+                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 );
+        }
+    }
+}
+
+
+void print_vso( URL_FILE * output, struct cons_pointer pointer) {
+    struct vector_space_object *vso =
+        pointer2cell( pointer ).payload.vectorp.address;
+
+    switch ( vso->header.tag.value) {
+        case MAPTV:
+            print_map( output, pointer);
+            break;
+        // \todo: others.
+    }
 }
 
 /**
@@ -123,7 +162,9 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) {
             dump_stack_trace( output, pointer );
             break;
         case FUNCTIONTV:
-            url_fwprintf( output, L"<Function>" );
+            url_fputws( L"<Function: ", output);
+            print( output, cell.payload.function.meta);
+            url_fputwc( L'>', output);
             break;
         case INTEGERTV:{
                 struct cons_pointer s = integer_to_string( pointer, 10 );
@@ -175,7 +216,9 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) {
             print( output, cell.payload.ratio.divisor );
             break;
         case READTV:
-            url_fwprintf( output, L"<Input stream>" );
+            url_fwprintf( output, L"<Input stream: " );
+            print( output, cell.payload.stream.meta);
+            url_fputwc( L'>', output);
             break;
         case REALTV:
             /* \todo using the C heap is a bad plan because it will fragment.
@@ -209,7 +252,9 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) {
             print_string_contents( output, pointer );
             break;
         case SPECIALTV:
-            url_fwprintf( output, L"<Special form>" );
+            url_fwprintf( output, L"<Special form: " );
+            print( output, cell.payload.special.meta);
+            url_fputwc( L'>', output);
             break;
         case TIMETV:
             print_string(output, time_to_string( pointer));
@@ -217,8 +262,13 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) {
         case TRUETV:
             url_fwprintf( output, L"t" );
             break;
+        case VECTORPOINTTV:
+            print_vso( output, pointer);
+            break;
         case WRITETV:
-            url_fwprintf( output, L"<Output stream>" );
+            url_fwprintf( output, L"<Output stream: " );
+            print( output, cell.payload.stream.meta);
+            url_fputwc( L'>', output);
             break;
         default:
             fwprintf( stderr,

src/io/read.c

@@ -24,6 +24,7 @@
 #include "intern.h"
 #include "io.h"
 #include "lispops.h"
+#include "map.h"
 #include "peano.h"
 #include "print.h"
 #include "ratio.h"
@@ -44,6 +45,9 @@ struct cons_pointer read_number( struct stack_frame *frame,
 struct cons_pointer read_list( struct stack_frame *frame,
                                struct cons_pointer frame_pointer,
                                URL_FILE * input, wint_t initial );
+struct cons_pointer read_map( struct stack_frame *frame,
+                               struct cons_pointer frame_pointer,
+                               URL_FILE * input, wint_t initial );
 struct cons_pointer read_string( URL_FILE * input, wint_t initial );
 struct cons_pointer read_symbol_or_key( URL_FILE * input, char *tag,
                                         wint_t initial );
@@ -100,6 +104,10 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
                     read_list( frame, frame_pointer, input,
                                url_fgetwc( input ) );
                 break;
+            case '{':
+                result = read_map( frame, frame_pointer, input,
+                               url_fgetwc( input ) );
+                break;
             case '"':
                 result = read_string( input, url_fgetwc( input ) );
                 break;
@@ -126,9 +134,10 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
                     } else if ( iswblank( next ) ) {
                         /* dotted pair. \todo this isn't right, we
                          * really need to backtrack up a level. */
-                        result =
+                        result = read_continuation( frame, frame_pointer, input,
-                            read_continuation( frame, frame_pointer, input,
                                                url_fgetwc( input ) );
+                        debug_print( L"read_continuation: dotted pair; read cdr ",
+                                    DEBUG_IO);
                     } else {
                         read_symbol_or_key( input, SYMBOLTAG, c );
                     }
@@ -278,16 +287,35 @@ struct cons_pointer read_list( struct stack_frame *frame,
                               struct cons_pointer frame_pointer,
                               URL_FILE * input, wint_t initial ) {
     struct cons_pointer result = NIL;
+    wint_t c;
+
     if ( initial != ')' ) {
         debug_printf( DEBUG_IO,
                      L"read_list starting '%C' (%d)\n", initial, initial );
         struct cons_pointer car =
             read_continuation( frame, frame_pointer, input,
                               initial );
+
+        /* skip whitespace */
+        for (c = url_fgetwc( input );
+             iswblank( c ) || iswcntrl( c );
+             c = url_fgetwc( input ));
+
+        if ( c == L'.') {
+            /* might be a dotted pair; indeed, if we rule out numbers with
+             * initial periods, it must be a dotted pair. \todo Ought to check,
+             * howerver, that there's only one form after the period. */
             result =
                 make_cons( car,
-                       read_list( frame, frame_pointer, input,
+                          c_car( read_list( frame,
-                                  url_fgetwc( input ) ) );
+                                           frame_pointer,
+                                           input,
+                                           url_fgetwc( input ) ) ) );
+        } else {
+            result =
+                make_cons( car,
+                          read_list( frame, frame_pointer, input, c ) );
+        }
     } else {
         debug_print( L"End of list detected\n", DEBUG_IO );
     }
@@ -295,6 +323,37 @@ struct cons_pointer read_list( struct stack_frame *frame,
     return result;
 }
 
+
+struct cons_pointer read_map( struct stack_frame *frame,
+                               struct cons_pointer frame_pointer,
+                             URL_FILE * input, wint_t initial ) {
+    struct cons_pointer result = make_empty_map( NIL);
+    wint_t c = initial;
+
+    while ( c != L'}' ) {
+        struct cons_pointer key =
+            read_continuation( frame, frame_pointer, input, c );
+
+        /* skip whitespace */
+        for (c = url_fgetwc( input );
+             iswblank( c ) || iswcntrl( c );
+             c = url_fgetwc( input ));
+
+        struct cons_pointer value =
+            read_continuation( frame, frame_pointer, input, c );
+
+        /* skip commaa and whitespace at this point. */
+        for (c = url_fgetwc( input );
+             c == L',' || iswblank( c ) || iswcntrl( c );
+             c = url_fgetwc( input ));
+
+        result = merge_into_map( result, make_cons( make_cons( key, value), NIL));
+    }
+
+    return result;
+}
+
+
 /**
  * Read a string. This means either a string delimited by double quotes
  * (is_quoted == true), in which case it may contain whitespace but may

src/memory/consspaceobject.c

@@ -96,18 +96,41 @@ struct cons_pointer c_car( struct cons_pointer arg ) {
 }
 
 /**
- * Implementation of cdr in C. If arg is not a cons, does not error but returns nil.
+ * Implementation of cdr in C. If arg is not a sequence, does not error but returns nil.
  */
 struct cons_pointer c_cdr( struct cons_pointer arg ) {
     struct cons_pointer result = NIL;
 
-    if ( consp( arg ) || stringp( arg ) || symbolp( arg ) ) {
+    struct cons_space_object cell = pointer2cell( arg );
+
+    switch (cell.tag.value) {
+        case CONSTV:
         result = pointer2cell( arg ).payload.cons.cdr;
+        break;
+        case KEYTV:
+        case STRINGTV:
+        case SYMBOLTV:
+        result = pointer2cell( arg ).payload.string.cdr;
+        break;
     }
 
     return result;
 }
 
+/**
+ * Implementation of `length` in C. If arg is not a cons, does not error but returns 0.
+ */
+int c_length( struct cons_pointer arg) {
+    int result = 0;
+
+    for (struct cons_pointer c = arg; !nilp(c); c = c_cdr(c)) {
+        result ++;
+    }
+
+    return result;
+}
+
+
 /**
  * Construct a cons cell from this pair of pointers.
  */

src/memory/consspaceobject.h

@@ -667,6 +667,8 @@ struct cons_pointer c_car( struct cons_pointer arg );
 
 struct cons_pointer c_cdr( struct cons_pointer arg );
 
+int c_length( struct cons_pointer arg);
+
 struct cons_pointer make_cons( struct cons_pointer car,
                                struct cons_pointer cdr );
 

src/memory/dump.c

@@ -21,6 +21,8 @@
 #include "conspage.h"
 #include "consspaceobject.h"
 #include "debug.h"
+#include "intern.h"
+#include "map.h"
 #include "print.h"
 #include "stack.h"
 #include "vectorspace.h"
@@ -146,6 +148,9 @@ void dump_object( URL_FILE * output, struct cons_pointer pointer ) {
                     case STACKFRAMETV:
                         dump_frame( output, pointer );
                         break;
+                    case MAPTV:
+                        dump_map( output, pointer);
+                        break;
                 }
             }
             break;

src/memory/lookup3.h

@@ -0,0 +1,19 @@
+/**
+ * lookup3.h
+ *
+ * Minimal header file wrapping Bob Jenkins' lookup3.c
+ *
+ *
+ * (c) 2019 Simon Brooke <simon@journeyman.cc>
+ * Public domain.
+ */
+
+#ifndef __lookup3_h
+#define __lookup3_h
+
+uint32_t hashword(
+const uint32_t *k,
+size_t          length,
+uint32_t        initval);
+
+#endif

src/memory/map.c

@@ -0,0 +1,289 @@
+/*
+ * 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]);
+            }
+        }
+    }
+}
+

src/memory/map.h

@@ -0,0 +1,96 @@
+/*
+ * 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

src/memory/stack.h

@@ -18,12 +18,12 @@
  * Licensed under GPL version 2.0, or, at your option, any later version.
  */
 
+#ifndef __psse_stack_h
+#define __psse_stack_h
+
 #include "consspaceobject.h"
 #include "conspage.h"
 
-#ifndef __stack_h
-#define __stack_h
-
 /**
  * macros for the tag of a stack frame.
  */

src/ops/intern.c

@@ -24,6 +24,7 @@
 #include "debug.h"
 #include "equal.h"
 #include "lispops.h"
+#include "map.h"
 #include "print.h"
 
 /**
@@ -51,7 +52,7 @@ struct cons_pointer
 internedp( struct cons_pointer key, struct cons_pointer store ) {
     struct cons_pointer result = NIL;
 
-    if ( symbolp( key ) ) {
+    if ( symbolp( key ) || keywordp( key ) ) {
         for ( struct cons_pointer next = store;
               nilp( result ) && consp( next );
               next = pointer2cell( next ).payload.cons.cdr ) {
@@ -73,7 +74,7 @@ internedp( struct cons_pointer key, struct cons_pointer store ) {
         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 SYMB", DEBUG_BIND );
+        debug_print( L", not a KEYW or SYMB", DEBUG_BIND );
     }
 
     return result;
@@ -91,6 +92,11 @@ 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;
              consp( next ); next = pointer2cell( next ).payload.cons.cdr ) {
             struct cons_space_object entry =
@@ -101,6 +107,13 @@ struct cons_pointer c_assoc( struct cons_pointer key,
                 break;
             }
         }
+    } else if (vectorpointp( store)) {
+        result = assoc_in_map( key, store);
+    }
+
+    debug_print( L"c_assoc returning ", DEBUG_BIND);
+    debug_print_object( result, DEBUG_BIND);
+    debug_println( DEBUG_BIND);
 
     return result;
 }
@@ -110,15 +123,29 @@ struct cons_pointer c_assoc( struct cons_pointer key,
  * with this key/value pair added to the front.
  */
 struct cons_pointer
-set( struct cons_pointer key, struct cons_pointer value,
+    set( struct cons_pointer key, struct cons_pointer value,
         struct cons_pointer store ) {
-    debug_print( L"Binding ", DEBUG_BIND );
+    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( 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 );
 
-    return make_cons( make_cons( key, value ), store );
+    if (nilp( store) || consp(store)) {
+        result = make_cons( make_cons( key, value ), store );
+    } else if (vectorpointp( store)) {
+        result = bind_in_map( store, key, value);
+    }
+
+    debug_print( L"set returning ", DEBUG_BIND);
+    debug_print_object( result, DEBUG_BIND);
+    debug_println( DEBUG_BIND);
+
+    return result;
 }
 
 /**
@@ -131,11 +158,19 @@ 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 );
     inc_ref( oblist );
     dec_ref( old );
 
-    debug_print( L"Leaving deep_bind\n", DEBUG_BIND );
+    debug_print( L"deep_bind returning ", DEBUG_BIND );
+    debug_print_object( oblist, DEBUG_BIND );
+    debug_println( DEBUG_BIND );
 
     return oblist;
 }

src/ops/lispops.c

@@ -33,9 +33,11 @@
 #include "intern.h"
 #include "io.h"
 #include "lispops.h"
+#include "map.h"
 #include "print.h"
 #include "read.h"
 #include "stack.h"
+#include "vectorspace.h"
 
 /*
  * also to create in this section:
@@ -269,7 +271,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
  * @return the result of evaluating the function with its arguments.
  */
 struct cons_pointer
-c_apply( struct stack_frame *frame, struct cons_pointer frame_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;
@@ -288,6 +290,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
             /* just pass exceptions straight back */
             result = fn_pointer;
             break;
+
             case FUNCTIONTV:
             {
                 struct cons_pointer exep = NIL;
@@ -308,6 +311,15 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_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;
@@ -327,6 +339,20 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
                 }
             }
             break;
+
+            case VECTORPOINTTV:
+            switch ( pointer_to_vso(fn_pointer)->header.tag.value) {
+                case MAPTV:
+                /* \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;
+            }
+            break;
+
             case NLAMBDATV:
             {
                 struct cons_pointer next_pointer =
@@ -343,6 +369,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
                 }
             }
             break;
+
             case SPECIALTV:
             {
                 struct cons_pointer next_pointer =
@@ -362,6 +389,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
                 }
             }
             break;
+
             default:
             {
                 int bs = sizeof( wchar_t ) * 1024;
@@ -416,9 +444,7 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
 
     switch ( cell.tag.value ) {
         case CONSTV:
-            {
                 result = c_apply( frame, frame_pointer, env );
-            }
             break;
 
         case SYMBOLTV:
@@ -709,6 +735,22 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer 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`.
  *
@@ -1265,6 +1307,7 @@ struct cons_pointer lisp_inspect( struct stack_frame *frame,
     }
 
     dump_object( output, frame->arg[0] );
+    url_fputws( L"\n", output );
 
     if ( writep( out_stream ) ) {
         dec_ref( out_stream );

src/ops/lispops.h

@@ -85,7 +85,9 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer,
 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.
  *

src/utils.c

@@ -12,7 +12,7 @@
 #include <string.h>
 
 
-int index_of( char c, char *s ) {
+int index_of( char c, const char *s ) {
     int i;
 
     for ( i = 0; s[i] != c && s[i] != 0; i++ );

src/utils.h

@@ -10,6 +10,8 @@
 #ifndef __psse_utils_h
 #define __psse_utils_h
 
-int index_of( char c, char *s );
+int index_of( char c, const char *s );
+
 char *trim( char *s );
+
 #endif

unit-tests/eval-quote-symbol.sh

@@ -1,6 +1,6 @@
 #!/bin/bash
 
-expected='<Special form>'
+expected='<Special form: ((:primitive . t) (:name . cond))>'
 actual=`echo "(eval 'cond)" | target/psse | tail -1`
 
 if [ "${expected}" = "${actual}" ]

unit-tests/map.sh

@@ -0,0 +1,89 @@
+#!/bin/bash
+
+#####################################################################
+# Create an empty map using map notation
+expected='{}'
+actual=`echo "$expected" | target/psse | tail -1`
+
+if [ "${expected}" = "${actual}" ]
+then
+    echo "OK"
+else
+    echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
+fi
+
+#####################################################################
+# Create an empty map using make-map
+expected='{}'
+actual=`echo "(make-map)" | target/psse | tail -1`
+
+echo -n "Empty map using (make-map): "
+if [ "${expected}" = "${actual}" ]
+then
+    echo "OK"
+else
+    echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
+fi
+
+#####################################################################
+# Create a map using map notation: order of keys in output is not
+# significant at this stage, but in the long term should be sorted
+# alphanumerically
+expected='{:two 2, :one 1, :three 3}'
+actual=`echo "{:one 1 :two 2 :three 3}" | target/psse | tail -1`
+
+echo -n "Map using map notation: "
+if [ "${expected}" = "${actual}" ]
+then
+    echo "OK"
+else
+    echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
+fi
+
+#####################################################################
+# Create a map using make-map: order of keys in output is not
+# significant at this stage, but in the long term should be sorted
+# alphanumerically
+expected='{:two 2, :one 1, :three 3}'
+actual=`echo "(make-map '((:one . 1)(:two . 2)(:three . 3)))" | target/psse | tail -1`
+
+echo -n "Map using (make-map): "
+if [ "${expected}" = "${actual}" ]
+then
+    echo "OK"
+else
+    echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
+fi
+
+#####################################################################
+# Keyword in function position
+expected='2'
+actual=`echo "(:two {:one 1 :two 2 :three 3})" | target/psse | tail -1`
+
+echo -n "Keyword in function position: "
+if [ "${expected}" = "${actual}" ]
+then
+    echo "OK"
+else
+    echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
+fi
+
+
+#####################################################################
+# Map in function position
+expected='2'
+actual=`echo "({:one 1 :two 2 :three 3} :two)" | target/psse | tail -1`
+
+echo -n "Map in function position: "
+if [ "${expected}" = "${actual}" ]
+then
+    echo "OK"
+else
+    echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
+fi

unit-tests/slurp.sh

@@ -1,6 +1,6 @@
 #!/bin/bash
 
-tmp=hi$$
+tmp=hi.$$
 echo "Hello, there." > ${tmp}
 expected='"Hello, there.'
 actual=`echo "(slurp (open \"${tmp}\"))" | target/psse | tail -2 | head -1`

where-does-it-break.sh

@@ -1,29 +0,0 @@
-#!/bin/bash
-
-# Not really a unit test, but a check to see where bignum addition breaks
-
-broken=0
-i=11529215046068469750
-# we've already proven we can successfullu get up to here
-increment=1
-
-while [ $broken -eq "0" ]
-do
-  expr="(+ $i $increment)"
-  # Use sbcl as our reference implementation...
-  expected=`echo "$expr" | sbcl --noinform | grep -v '*'`
-  actual=`echo "$expr" | target/psse | tail -1 | sed 's/\,//g'`
-
-  echo -n "adding $increment to $i: "
-
-  if [ "${expected}" = "${actual}" ]
-  then
-      echo "OK"
-  else
-      echo "Fail: expected '${expected}', got '${actual}'"
-      broken=1
-      exit 1
-  fi
-
-  i=$expected
-done