Merge branch 'feature/8' into develop

.gitignore

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

src/arith/integer.c

@@ -12,12 +12,6 @@
 #include <math.h>
 #include <stdio.h>
 #include <stdlib.h>
-/* safe_iop, as available in the Ubuntu repository, is this one:
- * https://code.google.com/archive/p/safe-iop/wikis/README.wiki
- * which is installed as `libsafe-iop-dev`. There is an alternate
- * implementation here: https://github.com/redpig/safe-iop/
- * which shares the same version number but is not compatible. */
-#include <safe_iop.h>
 /*
  * wide characters
  */

src/init.c

@@ -26,10 +26,12 @@
 #include "intern.h"
 #include "io.h"
 #include "lispops.h"
+#include "map.h"
 #include "meta.h"
 #include "peano.h"
 #include "print.h"
 #include "repl.h"
+#include "time.h"
 
 // extern char *optarg; /* defined in unistd.h */
 
@@ -67,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 ) );
 }
 
 /**
@@ -195,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 );
@@ -212,6 +215,7 @@ int main( int argc, char *argv[] ) {
     bind_function( L"source", &lisp_source );
     bind_function( L"subtract", &lisp_subtract );
     bind_function( L"throw", &lisp_exception );
+    bind_function( L"time", &lisp_time );
     bind_function( L"type", &lisp_type );
     bind_function( L"+", &lisp_add );
     bind_function( L"*", &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>
@@ -266,16 +267,8 @@ struct cons_pointer add_meta_string( struct cons_pointer meta, wchar_t *key,
                                      char *value ) {
     value = trim( value);
     wchar_t buffer[strlen( value ) + 1];
-    /* \todo something goes wrong here: I sometimes get junk characters on the
-     * end of the string. */
     mbstowcs( buffer, value, strlen( value ) + 1 );
 
-    /* hack: get rid of 32766 as a junk character, to see whether there are
-     * others.
-    for (int i = 0; i < wcslen( buffer); i++) {
-      if (buffer[i] == (wchar_t)32766) buffer[i] = (wchar_t)0;
-    } */
-
     return make_cons( make_cons( c_string_to_lisp_keyword( key ),
                                  c_string_to_lisp_string( buffer ) ), meta );
 }
@@ -285,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 );
 }

src/io/print.c

@@ -20,8 +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.
@@ -97,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.
+    }
 }
 
 /**
@@ -122,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 );
@@ -174,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.
@@ -208,13 +252,23 @@ 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));
             break;
         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

@@ -193,6 +193,16 @@
  */
 #define SYMBOLTV    1112365395
 
+/**
+ * A time stamp.
+ */
+#define TIMETAG     "TIME"
+
+/**
+ * The string `TIME`, considered as an `unsigned int`.
+ */
+#define TIMETV      1162692948
+
 /**
  * The special cons cell at address {0,1} which is canonically different
  * from NIL.
@@ -344,13 +354,18 @@
  * (there should only be one of these so it's slightly redundant).
  * Also note that anything that is not NIL is truthy.
  */
-#define tp(conspoint) (checktag(conspoint,TRUETAG))
+#define tp(conspoint) (check_tag(conspoint,TRUETAG))
+
+/**
+ * true if `conspoint` points to a time cell, else false.
+ */
+#define timep(conspoint) (check_tag(conspoint,TIMETAG))
 
 /**
  * true if `conspoint` points to something that is truthy, i.e.
  * anything but NIL.
  */
-#define truep(conspoint) (!checktag(conspoint,NILTAG))
+#define truep(conspoint) (!check_tag(conspoint,NILTAG))
 
 /**
  * An indirect pointer to a cons cell
@@ -531,6 +546,15 @@ struct string_payload {
     struct cons_pointer cdr;
 };
 
+/**
+ * The payload of a time cell: an unsigned 128 bit value representing micro-
+ * seconds since the estimated date of the Big Bang (actually, for
+ * convenience, 14Bn years before 1st Jan 1970 (the UNIX epoch))
+ */
+struct time_payload {
+    unsigned __int128 value;
+};
+
 /**
  * payload of a vector pointer cell.
  */
@@ -616,6 +640,10 @@ struct cons_space_object {
          * if tag == STRINGTAG || tag == SYMBOLTAG
          */
         struct string_payload string;
+        /**
+         * if tag == TIMETAG
+         */
+        struct time_payload time;
         /**
          * if tag == TRUETAG; we'll treat the special cell T as just a cons
          */
@@ -639,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

@@ -269,7 +269,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;
@@ -308,6 +308,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;
@@ -416,9 +425,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 +716,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 +1288,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/time/time.c

@@ -0,0 +1,98 @@
+/*
+ * time.h
+ *
+ * Bare bones of PSSE time. See issue #16.
+ *
+ * (c) 2019 Simon Brooke <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#include <stdlib.h>
+#include <time.h>
+/*
+ * wide characters
+ */
+#include <wchar.h>
+#include <wctype.h>
+
+#include "conspage.h"
+#include "consspaceobject.h"
+#include "integer.h"
+#include "time.h"
+#define _GNU_SOURCE
+
+#define seconds_per_year 31557600L
+
+/**
+ * PSSE Lisp epoch is 14 Bn years, or 441,806,400,000,000,000 seconds, before
+ * the UNIX epoch; the value in microseconds will break the C reader.
+ */
+unsigned __int128 epoch_offset = ((__int128)(seconds_per_year * 1000000000L) *
+                                  (__int128)(14L * 1000000000L));
+
+/**
+ * Return the UNIX time value which represents this time, if it falls within
+ * the period representable in UNIX time, or zero otherwise.
+ */
+long int lisp_time_to_unix_time(struct cons_pointer t) {
+    long int result = 0;
+
+    if (timep( t)) {
+        unsigned __int128 value = pointer2cell(t).payload.time.value;
+
+        if (value > epoch_offset) { // \todo && value < UNIX time rollover
+            result = ((value - epoch_offset) / 1000000000);
+        }
+    }
+
+    return result;
+}
+
+unsigned __int128 unix_time_to_lisp_time( time_t t) {
+    unsigned __int128 result = epoch_offset + (t * 1000000000);
+
+    return result;
+}
+
+struct cons_pointer make_time( struct cons_pointer integer_or_nil) {
+    struct cons_pointer pointer = allocate_cell( TIMETAG );
+    struct cons_space_object *cell = &pointer2cell( pointer );
+
+    if (integerp(integer_or_nil)) {
+        cell->payload.time.value = pointer2cell(integer_or_nil).payload.integer.value;
+        // \todo: if integer is a bignum, deal with it.
+    } else {
+        cell->payload.time.value = unix_time_to_lisp_time( time(NULL));
+    }
+
+    return pointer;
+}
+
+/**
+ * Function; return a time representation of the first argument in the frame;
+ * further arguments are ignored.
+ *
+ * * (time integer_or_nil)
+ *
+ * @param frame my stack_frame.
+ * @param frame_pointer a pointer to my stack_frame.
+ * @param env my environment.
+ * @return a lisp time; if `integer_or_nil` is an integer, return a time which
+ * is that number of microseconds after the notional big bang; else the current
+ * time.
+ */
+struct cons_pointer lisp_time( struct stack_frame *frame, struct cons_pointer frame_pointer,
+           struct cons_pointer env ) {
+    return make_time( frame->arg[0]);
+}
+
+/**
+ * This is temporary, for bootstrapping.
+ */
+struct cons_pointer time_to_string( struct cons_pointer pointer) {
+    long int t = lisp_time_to_unix_time(pointer);
+
+    return c_string_to_lisp_string( t == 0 ?
+                                         L"Not yet implemented: cannot print times outside UNIX time\n" :
+                                         ctime(&t));
+}

src/time/time.h

@@ -0,0 +1,20 @@
+/*
+ * time.h
+ *
+ * Bare bones of PSSE time. See issue #16.
+ *
+ * (c) 2019 Simon Brooke <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#ifndef __psse_time_h
+#define __psse_time_h
+
+#define _GNU_SOURCE
+#include "consspaceobject.h"
+
+struct cons_pointer lisp_time( struct stack_frame *frame, struct cons_pointer frame_pointer,
+           struct cons_pointer env );
+struct cons_pointer time_to_string( struct cons_pointer pointer);
+
+#endif

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++ );
@@ -27,7 +27,7 @@ char *trim( char *s ) {
           i-- ) {
         s[i] = '\0';
     }
-    for ( i = 0; ( isblank( s[i] ) || iscntrl( s[i] ) ) && s[i] != '\0'; i++ );
+    for ( i = 0; s[i] != '\0' && ( isblank( s[i] ) || iscntrl( s[i] ) ); i++ );
 
     return ( char * ) &s[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/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`