#8: Done

I'm now of the opinion that this is done at the wrong level in the stack and needs to be redone later; but it works for now.

There's a regression in `open`, but I can't see why.

src/init.c

@@ -69,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 ) );
 }
 
 /**

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 );
 }

src/io/print.c

@@ -104,18 +104,18 @@ void print_list( URL_FILE * output, struct cons_pointer pointer ) {
 }
 
 
-void print_map( URL_FILE * output, struct cons_pointer pointer) {
+void print_map( URL_FILE * output, struct cons_pointer map) {
-    if ( vectorpointp( pointer)) {
+    if ( vectorpointp( map)) {
-        struct vector_space_object *vso = pointer_to_vso( pointer);
+        struct vector_space_object *vso = pointer_to_vso( map);
 
         if ( mapp( vso ) ) {
             url_fputwc( btowc( '{' ), output );
 
-            for ( struct cons_pointer ks = keys(pointer);
+            for ( struct cons_pointer ks = keys( map);
-                 !nilp(ks); ks = c_cdr(ks)) {
+                 !nilp( ks); ks = c_cdr( ks)) {
-                print( output, c_car(ks));
+                print( output, c_car( ks));
                 url_fputwc( btowc( ' ' ), output );
-                print( output, c_assoc( pointer, c_car(ks)));
+                print( output, c_assoc( c_car( ks), map));
 
                 if ( !nilp( c_cdr( ks))) {
                     url_fputws( L", ", output );
@@ -162,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 );
@@ -214,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.
@@ -248,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));
@@ -260,7 +266,9 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) {
             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 );
                     }
@@ -275,19 +284,38 @@ struct cons_pointer read_number( struct stack_frame *frame,
  * left parenthesis.
  */
 struct cons_pointer read_list( struct stack_frame *frame,
-                               struct cons_pointer frame_pointer,
+                              struct cons_pointer frame_pointer,
-                               URL_FILE * input, wint_t initial ) {
+                              URL_FILE * input, wint_t initial ) {
     struct cons_pointer result = NIL;
+    wint_t c;
+
     if ( initial != ')' ) {
         debug_printf( DEBUG_IO,
-                      L"read_list starting '%C' (%d)\n", initial, initial );
+                     L"read_list starting '%C' (%d)\n", initial, initial );
         struct cons_pointer car =
             read_continuation( frame, frame_pointer, input,
-                               initial );
+                              initial );
-        result =
+
-            make_cons( car,
+        /* skip whitespace */
-                       read_list( frame, frame_pointer, input,
+        for (c = url_fgetwc( input );
-                                  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,
+                          c_car( read_list( frame,
+                                           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/map.c

@@ -15,6 +15,7 @@
 #include "dump.h"
 #include "fopen.h"
 #include "intern.h"
+#include "io.h"
 #include "lookup3.h"
 #include "map.h"
 #include "print.h"
@@ -61,10 +62,10 @@ struct map_payload *get_map_payload( struct cons_pointer pointer ) {
 
     if (vectorpointp(pointer) && mapp( vso ) ) {
         result = ( struct map_payload * ) &( vso->payload );
-        debug_printf( DEBUG_STACK,
+        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_STACK );
+        debug_print( L"get_map_payload: fail, returning NULL\n", DEBUG_BIND );
     }
 
     return result;
@@ -79,7 +80,7 @@ struct map_payload *get_map_payload( struct cons_pointer pointer ) {
  * @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 );
+    debug_print( L"Entering make_empty_map\n", DEBUG_BIND );
     struct cons_pointer result =
         make_vso( MAPTAG, sizeof( struct map_payload ) );
 
@@ -94,6 +95,7 @@ struct cons_pointer make_empty_map( struct cons_pointer hash_function ) {
         }
     }
 
+    debug_print( L"Leaving make_empty_map\n", DEBUG_BIND );
     return result;
 }
 
@@ -143,6 +145,7 @@ struct cons_pointer bind_in_map( struct cons_pointer parent,
 
 
 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 );
@@ -158,18 +161,27 @@ struct cons_pointer keys( struct cons_pointer store) {
                 pointer2cell( store ).payload.vectorp.address;
 
             if ( mapp( vso ) ) {
-                struct map_payload * payload = get_map_payload( result );
+                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;
 }
@@ -187,6 +199,7 @@ struct cons_pointer keys( struct cons_pointer store) {
  */
 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)) {
@@ -202,24 +215,31 @@ struct cons_pointer merge_into_map( struct cons_pointer parent,
         }
     }
 
+    debug_print( L"Leaving merge_into_map\n", DEBUG_BIND );
+
     return result;
 }
 
 
-struct cons_pointer assoc_in_map( struct cons_pointer map,
+struct cons_pointer assoc_in_map( struct cons_pointer key,
-                                  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.
@@ -251,7 +271,7 @@ void dump_map( URL_FILE * output, struct cons_pointer map_pointer ) {
         struct map_payload *payload = get_map_payload( map_pointer );
 
         if ( payload != NULL ) {
-            url_fputws( L"Immutable map; hash function:", output );
+            url_fputws( L"Immutable map; hash function: ", output );
 
             if (nilp(payload->hash_function)) {
                 url_fputws( L"default", output);

src/memory/map.h

@@ -73,6 +73,8 @@ 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);
@@ -82,8 +84,8 @@ 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 assoc_in_map( struct cons_pointer key,
-                                 struct cons_pointer key);
+                                  struct cons_pointer map);
 
 struct cons_pointer lisp_make_map( struct stack_frame *frame,
                                   struct cons_pointer frame_pointer,

src/ops/intern.c

@@ -94,9 +94,7 @@ struct cons_pointer c_assoc( struct cons_pointer key,
 
     debug_print( L"c_assoc; key is `", DEBUG_BIND);
     debug_print_object( key, DEBUG_BIND);
-    debug_print( L"`; store is \n", DEBUG_BIND);
+    debug_print( L"`\n", DEBUG_BIND);
-    debug_dump_object( store, DEBUG_BIND);
-    debug_println(DEBUG_BIND);
 
     if (consp(store)) {
         for ( struct cons_pointer next = store;

src/ops/lispops.c

@@ -1288,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/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/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`