#8: Buggy, but a lot of it works.

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"
@@ -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/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 pointer) {
+    if ( vectorpointp( pointer)) {
+        struct vector_space_object *vso = pointer_to_vso( pointer);
+
+        if ( mapp( vso ) ) {
+            url_fputwc( btowc( '{' ), output );
+
+            for ( struct cons_pointer ks = keys(pointer);
+                 !nilp(ks); ks = c_cdr(ks)) {
+                print( output, c_car(ks));
+                url_fputwc( btowc( ' ' ), output );
+                print( output, c_assoc( pointer, c_car(ks)));
+
+                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.
+    }
 }
 
 /**
@@ -217,6 +256,9 @@ 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>" );
             break;

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/map.c

@@ -30,7 +30,7 @@ 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 (keywordp(key) || stringp(key) || symbolp( key)) {
         if ( l > 0) {
             uint32_t buffer[l];
 
@@ -44,7 +44,7 @@ uint32_t get_hash_32(struct cons_pointer f, struct cons_pointer key) {
             result = hashword( buffer, l, 0);
         }
     } else {
-        fputws(L"Hashing is thud far implemented only for keys and strings.\n", stderr);
+        fputws(L"Hashing is thus far implemented only for keys, strings and symbols.\n", stderr);
     }
 
     return result;
@@ -220,6 +220,24 @@ struct cons_pointer assoc_in_map( struct cons_pointer map,
     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

src/memory/map.h

@@ -83,7 +83,11 @@ 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);
+                                 struct cons_pointer key);
+
+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 );
 

src/ops/intern.c

@@ -52,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 ) {
@@ -74,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;
@@ -113,6 +113,10 @@ struct cons_pointer c_assoc( struct cons_pointer key,
         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;
 }
 
@@ -125,18 +129,24 @@ struct cons_pointer
         struct cons_pointer store ) {
     struct cons_pointer result = NIL;
 
-    debug_print( L"Binding ", DEBUG_BIND );
+    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 );
 
-    if (consp(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;
 }
 
@@ -150,11 +160,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;
 }