#8: compiles, but most tests fail.

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/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

@@ -6,3 +6,246 @@
  * (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 "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)) {
+        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 thud far implemented only for keys and strings.\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_STACK,
+                      L"get_map_payload: all good, returning %p\n", result );
+    } else {
+        debug_print( L"get_map_payload: fail, returning NULL\n", DEBUG_STACK );
+    }
+
+    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_ALLOC );
+    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;
+        }
+    }
+
+    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) {
+    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( result );
+
+                for (int bucket = 0; bucket < BUCKETSINMAP; bucket++) {
+                    for (struct cons_pointer c = payload->buckets[bucket];
+                         !nilp(c); c = c_cdr(c)) {
+                        result = make_cons( c_car( c_car( c)), result);
+                    }
+                }
+            }
+        }
+        break;
+    }
+
+    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) {
+    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]);
+        }
+    }
+
+    return result;
+}
+
+
+struct cons_pointer assoc_in_map( struct cons_pointer map,
+                                  struct cons_pointer key) {
+    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]);
+    }
+
+    return result;
+}
+
+/**
+ * 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

@@ -30,7 +30,14 @@
 #define MAXENTRIESINASSOC 16
 
 /**
- * The vector-space payload of a map object.
+ * 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 {
     /**
@@ -39,7 +46,7 @@ struct map_payload {
      * 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 = NIL;
+    struct cons_pointer hash_function;
 
     /**
      * Obviously the number of buckets in a map is a trade off, and this may need
@@ -62,4 +69,22 @@ struct map_payload {
     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 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 map,
+                                  struct cons_pointer key);
+
+void dump_map( URL_FILE * output, struct cons_pointer map_pointer );
+
 #endif

src/ops/intern.c

@@ -24,6 +24,7 @@
 #include "debug.h"
 #include "equal.h"
 #include "lispops.h"
+#include "map.h"
 #include "print.h"
 
 /**
@@ -88,7 +89,7 @@ internedp( struct cons_pointer key, struct cons_pointer store ) {
  * of that key from the store; otherwise return NIL.
  */
 struct cons_pointer c_assoc( struct cons_pointer key,
-                             struct cons_pointer store ) {
+                            struct cons_pointer store ) {
     struct cons_pointer result = NIL;
 
     debug_print( L"c_assoc; key is `", DEBUG_BIND);
@@ -97,15 +98,19 @@ struct cons_pointer c_assoc( struct cons_pointer key,
     debug_dump_object( store, DEBUG_BIND);
     debug_println(DEBUG_BIND);
 
-    for ( struct cons_pointer next = store;
-          consp( next ); next = pointer2cell( next ).payload.cons.cdr ) {
-        struct cons_space_object entry =
-            pointer2cell( pointer2cell( next ).payload.cons.car );
+    if (consp(store)) {
+        for ( struct cons_pointer next = store;
+             consp( next ); next = pointer2cell( next ).payload.cons.cdr ) {
+            struct cons_space_object entry =
+                pointer2cell( pointer2cell( next ).payload.cons.car );
 
-        if ( equal( key, entry.payload.cons.car ) ) {
-            result = entry.payload.cons.cdr;
-            break;
+            if ( equal( key, entry.payload.cons.car ) ) {
+                result = entry.payload.cons.cdr;
+                break;
+            }
         }
+    } else if (vectorpointp( store)) {
+        result = assoc_in_map( key, store);
     }
 
     return result;
@@ -116,15 +121,23 @@ 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,
-     struct cons_pointer store ) {
+    set( struct cons_pointer key, struct cons_pointer value,
+        struct cons_pointer store ) {
+    struct cons_pointer result = NIL;
+
     debug_print( L"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 );
 
-    return make_cons( make_cons( key, value ), store );
+    if (consp(store)) {
+        result = make_cons( make_cons( key, value ), store );
+    } else if (vectorpointp( store)) {
+        result = bind_in_map( store, key, value);
+    }
+
+    return result;
 }
 
 /**

src/ops/lispops.c

@@ -716,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`.
  *

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.
  *