Well, I'm back to the same failed unit tests as the develop branch

and I *feel* that the intern code is better. But it's not without
problems and I don't think I can release at this. But it may be
ready to merge back.

docs/Interning-strings.md

@@ -12,58 +12,50 @@ causes an unbound variable exception to be thrown, while
 
 returns the value **"froboz"**. This begs the question of whether there's any difference between **"froboz"** and **'froboz**, and the answer is that at this point I don't know.
 
-There will be a concept of a root [namespace](Namespace.html), in which other namespaces may be bound recursively to form a directed graph. Because at least some namespaces are mutable, the graph is not necessarily acyclic. There will be a concept of a current namespace, that is to say the namespace in which the user is currently working. 
+There will be a concept of a root [namespace](Namespace.md), in which other namespaces may be bound recursively to form a directed graph. Because at least some namespaces are mutable, the graph is not necessarily acyclic. There will be a concept of a current namespace, that is to say the namespace in which the user is currently working. 
 
 There must be some notation to say distinguish a request for the value of a name in the root namespace and the value of a name in the current namespace. For now I'm proposing that:
 
-    (eval froboz)
+    (eval 'froboz)
 
 will return the value that **froboz** is bound to in the current namespace;
 
-    (eval .froboz)
+    (eval ::/froboz)
 
 will return the value that **froboz** is bound to in the root namespace;
 
-    (eval foobar.froboz)
+    (eval 'foobar/froboz)
 
 will return the value that **froboz** is bound to in a namespace which is the value of the name **foobar** in the current namespace; and that
 
-    (eval .system.users.simon.environment.froboz)
+    (eval ::users:simon:environment/froboz)
 
-will return the value that **froboz** is bound to in the environment of the user of the system called **simon**.
+will return the value that **froboz** is bound to in the environment of the user of the system called **simon** (if that is readable by you).
 
-The exact path separator syntax may change, but the principal that when interning a symbol it is broken down into a path of tokens, and that the value of each token is sought in a namespace bound to the previous token, is likely to remain.
+The [exact path separator syntax](Paths.md) may change, but the principal that when interning a symbol it is broken down into a path of tokens, and that the value of each token is sought in a namespace bound to the previous token, is likely to remain.
 
-Obviously if **froboz** is interned in one namespace it is not necessarily interned in another, and vice versa. There's a potentially nasty problem here that two lexically identical strings might be bound in different namespaces, so that there is not one canonical interned **froboz**; if this turns out to cause problems in practice there will need to be a separate canonical [hashtable](Hashtable.html) of individual path elements.
+Obviously if **froboz** is interned in one namespace it is not necessarily interned in another, and vice versa. There's a potentially nasty problem here that two lexically identical strings might be bound in different namespaces, so that there is not one canonical interned **froboz**; if this turns out to cause problems in practice there will need to be a separate canonical [hashtable](Hashtable.md) of individual path elements.
 
 Obviously this means there may be arbitrarily many paths which reference the same data item. This is intended.
 
 ## Related functions
 
-### (intern! string)
+### (intern! path)
 
-Binds *string*, considered as a path, to **NIL**. If some namespace along the path doesn't exist, throws an exception. Obviously if the current user is not entitled to write to the terminal namespace, also throws an exception.
+Binds *path* to **NIL**. If some namespace along the path doesn't exist, throws an exception. Obviously if the current user is not entitled to write to the terminal namespace, also throws an exception.
 
-### (intern! string T)
+### (intern! path T)
 
-Binds *string*, considered as a path, to **NIL**. If some namespace along the path doesn't exist, create it as the current user with both read and write [access control](Access-control.html) lists taken from the current binding of **friends** in the current environment. Obviously if the current user is not entitled to write to the last pre-existing namespace, throws an exception.
+Binds *path* to **NIL**. If some namespace along the path doesn't exist, create it as the current user with both read and write [access control](Access-control.html) lists taken from the current binding of **:friends** in the current environment. Obviously if the current user is not entitled to write to the last pre-existing namespace, throws an exception.
-
-### (intern! string T write-access-list)
-
-Binds *string*, considered as a path, to **NIL**. If some namespace along the path doesn't exist, create it as the current user with the read [access control](https://www.journeyman.cc/blog/posts-output/2006-02-20-postscarcity-software/) list taken from the current binding of **friends** in the current environment, and the write access control list taken from the value of *write-access-list*. Obviously if the current user is not entitled to write to the last pre-existing namespace, throws an exception.
 
 ### (set! string value)
 
-Binds *string*, considered as a path, to *value*. If some namespace along the path doesn't exist, throws an exception. Obviously if the current user is not entitled to write to the terminal namespace, also throws an exception.
+Binds *path* to *value*. If some namespace along the path doesn't exist, throws an exception. Obviously if the current user is not entitled to write to the terminal namespace, also throws an exception.
 
 ### (set! string value T)
 
 Binds *string*, considered as a path, to *value*. If some namespace along the path doesn't exist, create it as the current user with both read and write [access control](Access-control.html) lists taken from the current binding of **friends** in the current environment. Obviously if the current user is not entitled to write to the last pre-existing namespace, throws an exception.
 
-### (set! string value T write-access-list)
-
-Binds *string*, considered as a path, to *value*. If some namespace along the path doesn't exist, create it as the current user with the read [access control](Access-control.html) list taken from the current binding of **friends** in the current environment, and the write access control list taken from the value of *write-access-list*. Obviously if the current user is not entitled to write to the last pre-existing namespace, throws an exception.
-
 ### (put! string token value)
 
 Considers *string* as the path to some namespace, and binds *token* in that namespace to *value*. *Token* should not contain any path separator syntax. If the namespace doesn't exist or if the current user is not entitled to write to the namespace, throws an exception.
@@ -71,16 +63,16 @@ Considers *string* as the path to some namespace, and binds *token* in that name
 ### (string-to-path string)
 
 Behaviour as follows:
-    (string-to-path "foo.bar.ban") => ("foo" "bar" "ban")
+    (string-to-path ":foo:bar/ban") => (-> (environment) :foo :bar 'ban)
-    (string-to-path ".foo.bar.ban") => ("" "foo" "bar" "ban")
+    (string-to-path "::foo:bar/ban") => (-> (oblist) :foo :bar 'ban)
 
-Obviously if the current user can't read the string, throws an exception.
+Obviously if the current user can't read the string, throws an exception. `(oblist)` is currently (version 0.0.6) a function which returns the current value of the root namespace; `(environment)` is a proposed function which returns the current value of the environment of current user (with possibly `(environmnt user-name)` returning the value of the environment of the user indicated by `user-name`, if that is readable by you). The symbol `->` represents a threading macro [similar to Clojure's](https://clojuredocs.org/clojure.core/-%3E).
 
 ### (path-to-string list-of-strings)
 
 Behaviour as follows:
-    (path-to-string '("foo" "bar" "ban")) => "foo.bar.ban"
+    (path-to-string '(:foo :bar 'ban)) => ":foo:bar/ban"
-    (path-to-string '("" "foo" "bar" "ban")) => ".foo.bar.ban"
+    (path-to-string '("" :foo :bar 'ban)) => "::foo:bar/ban"
 
 Obviously if the current user can't read some element of *list-of-strings*, throws an exception.
 

lisp/documentation.lisp

@@ -3,6 +3,31 @@
 ;; `nth` (from `nth.lisp`)
 ;; `string?` (from `types.lisp`)
 
+(set! nil? (lambda 
+          (o) 
+          "`(nil? object)`: Return `t` if object is `nil`, else `t`."
+          (= o nil)))
+
+(set! member? (lambda
+            (item collection)
+            "`(member item collection)`: Return `t` if this `item` is a member of this `collection`, else `nil`."
+            ;; (print (list "In member? item is " item "; collection is " collection))
+            ;; (println)
+            (cond
+              ((= nil collection) nil)
+              ((= item (car collection)) t)
+              (t (member? item (cdr collection))))))
+
+;; (member? (type member?) '("LMDA" "NLMD"))
+
+(set! nth (lambda (n l) 
+    "Return the `n`th member of this list `l`, or `nil` if none."
+    (cond ((= nil l) nil)
+        ((= n 1) (car l))
+        (t (nth (- n 1) (cdr l))))))
+
+(set! string? (lambda (o) "True if `o` is a string." (= (type o) "STRG") ) )
+
 (set! documentation (lambda (object)
     "`(documentation object)`:  Return documentation for the specified `object`, if available, else `nil`."
    (cond ((member? (type object) '("FUNC" "SPFM"))
@@ -15,3 +40,7 @@
 
 (set! doc documentation)
 
+(documentation apply)
+
+;; (documentation member?)
+

src/debug.c

@@ -32,6 +32,25 @@
  */
 int verbosity = 0;
 
+/**
+ * When debugging, we want to see exceptions as they happen, because they may
+ * not make their way back down the stack to whatever is expected to handle
+ * them.
+ */
+void debug_print_exception( struct cons_pointer ex_ptr ) {
+#ifdef DEBUG
+    if ( ( verbosity != 0 ) && exceptionp( ex_ptr ) ) {
+        fwide( stderr, 1 );
+        fputws( L"EXCEPTION: ", stderr );
+
+        URL_FILE *ustderr = file_to_url_file( stderr );
+        fwide( stderr, 1 );
+        print( ustderr, ex_ptr );
+        free( ustderr );
+    }
+#endif
+}
+
 /**
  * @brief print this debug `message` to stderr, if `verbosity` matches `level`.
  *

src/debug.h

@@ -81,6 +81,7 @@
 
 extern int verbosity;
 
+void debug_print_exception( struct cons_pointer ex_ptr );
 void debug_print( wchar_t *message, int level );
 void debug_print_128bit( __int128_t n, int level );
 void debug_println( int level );

src/init.c

@@ -325,7 +325,7 @@ int main( int argc, char *argv[] ) {
                                                   ( c_string_to_lisp_keyword
                                                     ( L"url" ),
                                                     c_string_to_lisp_string
-                                                    ( L"system:standard output]" ) ),
+                                                    ( L"system:standard output" ) ),
                                                   NIL ) ), false );
     bind_value( L"*log*",
                 make_write_stream( file_to_url_file( stderr ),

src/io/io.c

@@ -508,8 +508,8 @@ lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer,
     if ( readp( frame->arg[0] ) ) {
         result =
             make_string( url_fgetwc
-                         ( pointer2cell( frame->arg[0] ).payload.
+                         ( pointer2cell( frame->arg[0] ).payload.stream.
-                           stream.stream ), NIL );
+                           stream ), NIL );
     }
 
     return result;

src/io/print.c

@@ -101,7 +101,7 @@ void print_map( URL_FILE *output, struct cons_pointer map ) {
             struct cons_pointer key = c_car( ks );
             print( output, key );
             url_fputwc( btowc( ' ' ), output );
-            print( output, hashmap_get( map, key ) );
+            print( output, hashmap_get( map, key, false ) );
 
             if ( !nilp( c_cdr( ks ) ) ) {
                 url_fputws( L", ", output );

src/memory/conspage.c

@@ -250,8 +250,9 @@ struct cons_pointer allocate_cell( uint32_t tag ) {
             total_cells_allocated++;
 
             debug_printf( DEBUG_ALLOC,
-                          L"Allocated cell of type '%4.4s' at %d, %d \n",
+                          L"Allocated cell of type %4.4s at %u, %u \n",
-                          cell->tag.bytes, result.page, result.offset );
+                          ( ( char * ) cell->tag.bytes ), result.page,
+                          result.offset );
         } else {
             debug_printf( DEBUG_ALLOC, L"WARNING: Allocating non-free cell!" );
         }

src/memory/consspaceobject.c

@@ -78,7 +78,7 @@ struct cons_pointer inc_ref( struct cons_pointer pointer ) {
         cell->count++;
 #ifdef DEBUG
         debug_printf( DEBUG_ALLOC,
-                      L"\nIncremented cell of type %4.4s at page %d, offset %d to count %d",
+                      L"\nIncremented cell of type %4.4s at page %u, offset %u to count %u",
                       ( ( char * ) cell->tag.bytes ), pointer.page,
                       pointer.offset, cell->count );
         if ( strncmp( cell->tag.bytes, VECTORPOINTTAG, TAGLENGTH ) == 0 ) {
@@ -131,6 +131,19 @@ struct cons_pointer dec_ref( struct cons_pointer pointer ) {
     return pointer;
 }
 
+/**
+ * given a cons_pointer as argument, return the tag.
+ */
+uint32_t get_tag_value( struct cons_pointer pointer ) {
+    uint32_t result = pointer2cell( pointer ).tag.value;
+
+    if ( result == VECTORPOINTTV ) {
+        result = pointer_to_vso( pointer )->header.tag.value;
+    }
+
+    return result;
+}
+
 /**
  * Get the Lisp type of the single argument.
  * @param pointer a pointer to the object whose type is requested.
@@ -399,15 +412,15 @@ struct cons_pointer make_symbol_or_key( wint_t c, struct cons_pointer tail,
     if ( tag == SYMBOLTV || tag == KEYTV ) {
         result = make_string_like_thing( c, tail, tag );
 
-        if ( tag == KEYTV ) {
+        // if ( tag == KEYTV ) {
-            struct cons_pointer r = interned( result, oblist );
+        //     struct cons_pointer r = interned( result, oblist );
 
-            if ( nilp( r ) ) {
+        //     if ( nilp( r ) ) {
-                intern( result, oblist );
+        //         intern( result, oblist );
-            } else {
+        //     } else {
-                result = r;
+        //         result = r;
-            }
+        //     }
-        }
+        // }
     } else {
         result =
             make_exception( c_string_to_lisp_string

src/memory/consspaceobject.h

@@ -308,11 +308,6 @@ extern struct cons_pointer privileged_keyword_payload;
  */
 #define pointer2cell(pointer) ((conspages[pointer.page]->cell[pointer.offset]))
 
-/**
- * given a cons_pointer as argument, return the tag.
- */
-#define get_tag_value(conspoint) ((pointer2cell(conspoint)).tag.value)
-
 /**
  * true if `conspoint` points to the special cell NIL, else false
  * (there should only be one of these so it's slightly redundant).
@@ -727,6 +722,11 @@ struct cons_pointer inc_ref( struct cons_pointer pointer );
 
 struct cons_pointer dec_ref( struct cons_pointer pointer );
 
+/**
+ * given a cons_pointer as argument, return the tag.
+ */
+uint32_t get_tag_value( struct cons_pointer pointer );
+
 struct cons_pointer c_type( struct cons_pointer pointer );
 
 struct cons_pointer c_car( struct cons_pointer arg );

src/memory/dump.c

@@ -114,10 +114,10 @@ void dump_object( URL_FILE *output, struct cons_pointer pointer ) {
         case RATIOTV:
             url_fwprintf( output,
                           L"\t\tRational cell: value %ld/%ld, count %u\n",
-                          pointer2cell( cell.payload.ratio.dividend ).
+                          pointer2cell( cell.payload.ratio.dividend ).payload.
-                          payload.integer.value,
+                          integer.value,
-                          pointer2cell( cell.payload.ratio.divisor ).
+                          pointer2cell( cell.payload.ratio.divisor ).payload.
-                          payload.integer.value, cell.count );
+                          integer.value, cell.count );
             break;
         case READTV:
             url_fputws( L"\t\tInput stream; metadata: ", output );

src/ops/equal.c

@@ -272,7 +272,9 @@ bool equal_map_map( struct cons_pointer a, struct cons_pointer b ) {
 
         for ( struct cons_pointer i = keys_a; !nilp( i ); i = c_cdr( i ) ) {
             struct cons_pointer key = c_car( i );
-            if ( !equal( hashmap_get( a, key ), hashmap_get( b, key ) ) ) {
+            if ( !equal
+                 ( hashmap_get( a, key, false ),
+                   hashmap_get( b, key, false ) ) ) {
                 result = false;
                 break;
             }

src/ops/intern.c

@@ -205,7 +205,7 @@ struct cons_pointer hashmap_put_all( struct cons_pointer mapp,
             for ( struct cons_pointer keys = hashmap_keys( assoc );
                   !nilp( keys ); keys = c_cdr( keys ) ) {
                 struct cons_pointer key = c_car( keys );
-                hashmap_put( mapp, key, hashmap_get( assoc, key ) );
+                hashmap_put( mapp, key, hashmap_get( assoc, key, false ) );
             }
         }
     }
@@ -216,17 +216,33 @@ struct cons_pointer hashmap_put_all( struct cons_pointer mapp,
 /** Get a value from a hashmap. 
   *
   * Note that this is here, rather than in memory/hashmap.c, because it is 
-  * closely tied in with c_assoc, q.v.
+  * closely tied in with search_store, q.v.
   */
 struct cons_pointer hashmap_get( struct cons_pointer mapp,
-                                 struct cons_pointer key ) {
+                                 struct cons_pointer key, bool return_key ) {
+#ifdef DEBUG
+    debug_print( L"\nhashmap_get: key is `", DEBUG_BIND );
+    debug_print_object( key, DEBUG_BIND );
+    debug_print( L"`; store of type `", DEBUG_BIND );
+    debug_print_object( c_type( mapp ), DEBUG_BIND );
+    debug_printf( DEBUG_BIND, L"`; returning `%s`.\n",
+                  return_key ? "key" : "value" );
+#endif
+
     struct cons_pointer result = NIL;
     if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) ) && !nilp( key ) ) {
         struct vector_space_object *map = pointer_to_vso( mapp );
         uint32_t bucket_no = get_hash( key ) % map->payload.hashmap.n_buckets;
 
-        result = c_assoc( key, map->payload.hashmap.buckets[bucket_no] );
+        result =
+            search_store( key, map->payload.hashmap.buckets[bucket_no],
+                          return_key );
     }
+#ifdef DEBUG
+    debug_print( L"\nhashmap_get returning: `", DEBUG_BIND );
+    debug_print_object( result, DEBUG_BIND );
+    debug_print( L"`\n", DEBUG_BIND );
+#endif
 
     return result;
 }
@@ -267,82 +283,134 @@ struct cons_pointer clone_hashmap( struct cons_pointer ptr ) {
     return result;
 }
 
-// (keys set let quote read equal *out* *log* oblist cons source cond close meta mapcar negative? open subtract eval nλ *in* *sink* cdr set! reverse slurp try assoc eq add list time car t *prompt* absolute append apply divide exception get-hash hashmap inspect metadata multiply print put! put-all! read-char repl throw type + * - / = lambda λ nlambda progn)
-
 /**
- * If this key is lexically identical to a key in this store, return the key
+ * @brief `(search-store key store return-key?)` Search this `store` for this
- * from the store (so that later when we want to retrieve a value, an eq test
+ * a key lexically identical to this `key`. 
- * will work); otherwise return NIL.
+ *
+ * If found, then, if `return-key?` is non-nil, return the copy found in the 
+ * `store`, else return the value associated with it.
+ *
+ * At this stage the following structures are legal stores:
+ * 1. an association list comprising (key . value) dotted pairs;
+ * 2. a hashmap;
+ * 3. a namespace (which for these purposes is identical to a hashmap);
+ * 4. a hybrid list comprising both (key . value) pairs and hashmaps as first
+ *    level items;
+ * 5. such a hybrid list, but where the last CDR pointer is to a hashmap
+ *    rather than to a cons sell or to `nil`.
+ *
+ * This is over-complex and type 5 should be disallowed, but it will do for 
+ * now.
  */
-struct cons_pointer interned( struct cons_pointer key,
+struct cons_pointer search_store( struct cons_pointer key,
-                              struct cons_pointer store ) {
+                                  struct cons_pointer store,
+                                  bool return_key ) {
     struct cons_pointer result = NIL;
 
-    debug_print( L"interned: Checking for interned value of `", DEBUG_BIND );
+#ifdef DEBUG
+    debug_print( L"\nsearch_store; key is `", DEBUG_BIND );
     debug_print_object( key, DEBUG_BIND );
-    debug_print( L"`\n", DEBUG_BIND );
+    debug_print( L"`; store of type `", DEBUG_BIND );
+    debug_print_object( c_type( store ), DEBUG_BIND );
+    debug_printf( DEBUG_BIND, L"`; returning `%s`.\n",
+                  return_key ? "key" : "value" );
+#endif
 
     if ( symbolp( key ) || keywordp( key ) ) {
-        struct cons_space_object *cell = &pointer2cell( store );
+        struct cons_space_object *store_cell = &pointer2cell( store );
 
-        switch ( cell->tag.value ) {
+        switch ( get_tag_value( store ) ) {
             case CONSTV:
-                for ( struct cons_pointer next = store;
+                for ( struct cons_pointer cursor = store;
-                      nilp( result ) && consp( next ); next = c_cdr( next ) ) {
+                      nilp( result ) && ( consp( cursor )
-                    if ( !nilp( next ) ) {
+                                          || hashmapp( cursor ) );
-                        // struct cons_space_object entry =
+                      cursor = pointer2cell( cursor ).payload.cons.cdr ) {
-                        //     pointer2cell( c_car( next) );
+                    switch ( get_tag_value( cursor ) ) {
+                        case CONSTV:
+                            struct cons_pointer entry_ptr = c_car( cursor );
 
-                        if ( equal( key, c_car( next ) ) ) {
+                            switch ( get_tag_value( entry_ptr ) ) {
-                            result = key;
+                                case CONSTV:
-                        }
+                                    if ( equal( key, c_car( entry_ptr ) ) ) {
+                                        result =
+                                            return_key ? c_car( entry_ptr ) :
+                                            c_cdr( entry_ptr );
+                                    }
+                                    break;
+                                case HASHTV:
+                                case NAMESPACETV:
+                                    // TODO: I think this should be impossible, and we should maybe
+                                    // throw an exception.
+                                    result =
+                                        hashmap_get( entry_ptr, key,
+                                                     return_key );
+                                    break;
+                                default:
+                                    result =
+                                        throw_exception
+                                        ( c_string_to_lisp_symbol
+                                          ( L"search-store (entry)" ),
+                                          make_cons( c_string_to_lisp_string
+                                                     ( L"Unexpected store type: " ),
+                                                     c_type( c_car
+                                                             ( entry_ptr ) ) ),
+                                          NIL );
+
+                            }
+                            break;
+                        case HASHTV:
+                        case NAMESPACETV:
+                            debug_print
+                                ( L"\n\tHashmap as top-level value in list",
+                                  DEBUG_BIND );
+                            result = hashmap_get( cursor, key, return_key );
+                            break;
+                        default:
+                            result =
+                                throw_exception( c_string_to_lisp_symbol
+                                                 ( L"search-store (cursor)" ),
+                                                 make_cons
+                                                 ( c_string_to_lisp_string
+                                                   ( L"Unexpected store type: " ),
+                                                   c_type( cursor ) ), NIL );
                     }
                 }
                 break;
-            case VECTORPOINTTV:
+            case HASHTV:
-                if ( hashmapp( store ) || namespacep( store ) ) {
+            case NAMESPACETV:
-                    // get the right hash bucket and recursively call interned on that.
+                result = hashmap_get( store, key, return_key );
-                    struct vector_space_object *map = pointer_to_vso( store );
-                    uint32_t bucket_no =
-                        get_hash( key ) % map->payload.hashmap.n_buckets;
-
-                    result =
-                        interned( key,
-                                  map->payload.hashmap.buckets[bucket_no] );
-                } else {
-                    result =
-                        throw_exception( c_string_to_lisp_symbol
-                                         ( L"interned?" ),
-                                         make_cons( c_string_to_lisp_string
-                                                    ( L"Unexpected store type: " ),
-                                                    c_type( store ) ), NIL );
-                }
                 break;
             default:
                 result =
-                    throw_exception( c_string_to_lisp_symbol( L"interned?" ),
+                    throw_exception( c_string_to_lisp_symbol
-                                     make_cons
+                                     ( L"search-store (store)" ),
-                                     ( c_string_to_lisp_string
+                                     make_cons( c_string_to_lisp_string
-                                       ( L"Unexpected store type: " ),
+                                                ( L"Unexpected store type: " ),
-                                       c_type( store ) ), NIL );
+                                                c_type( store ) ), NIL );
                 break;
         }
     } else {
+        // failing with key type NIL here (?). Probably worth dumping the stack?
         result =
-            throw_exception( c_string_to_lisp_symbol( L"interned?" ),
+            throw_exception( c_string_to_lisp_symbol( L"search-store (key)" ),
                              make_cons
                              ( c_string_to_lisp_string
                                ( L"Unexpected key type: " ), c_type( key ) ),
                              NIL );
     }
 
-    debug_print( L"interned: returning `", DEBUG_BIND );
+    debug_print( L"search-store: returning `", DEBUG_BIND );
     debug_print_object( result, DEBUG_BIND );
     debug_print( L"`\n", DEBUG_BIND );
 
     return result;
 }
 
+struct cons_pointer interned( struct cons_pointer key,
+                              struct cons_pointer store ) {
+    return search_store( key, store, true );
+}
+
 /**
  * @brief Implementation of `interned?` in C: predicate wrapped around interned.
  * 
@@ -365,68 +433,7 @@ struct cons_pointer internedp( struct cons_pointer key,
  */
 struct cons_pointer c_assoc( struct cons_pointer key,
                              struct cons_pointer store ) {
-    struct cons_pointer result = NIL;
+    return search_store( key, store, false );
-
-    if ( !nilp( key ) ) {
-        if ( consp( store ) ) {
-            for ( struct cons_pointer next = store;
-                  nilp( result ) && ( consp( next ) || hashmapp( next ) );
-                  next = pointer2cell( next ).payload.cons.cdr ) {
-                if ( consp( next ) ) {
-// #ifdef DEBUG
-//                     debug_print( L"\nc_assoc; key is `", DEBUG_BIND );
-//                     debug_print_object( key, DEBUG_BIND );
-//                     debug_print( L"`\n", DEBUG_BIND );
-// #endif
-
-                    struct cons_pointer entry_ptr = c_car( next );
-                    struct cons_space_object entry = pointer2cell( entry_ptr );
-
-                    switch ( entry.tag.value ) {
-                        case CONSTV:
-                            if ( equal( key, entry.payload.cons.car ) ) {
-                                result = entry.payload.cons.cdr;
-                            }
-                            break;
-                        case VECTORPOINTTV:
-                            result = hashmap_get( entry_ptr, key );
-                            break;
-                        default:
-                            throw_exception( c_string_to_lisp_symbol
-                                             ( L"assoc" ),
-                                             c_append( c_string_to_lisp_string
-                                                       ( L"Store entry is of unknown type: " ),
-                                                       c_type( entry_ptr ) ),
-                                             NIL );
-                    }
-
-// #ifdef DEBUG
-//                     debug_print( L"c_assoc `", DEBUG_BIND );
-//                     debug_print_object( key, DEBUG_BIND );
-//                     debug_print( L"` returning: ", DEBUG_BIND );
-//                     debug_print_object( result, DEBUG_BIND );
-//                     debug_println( DEBUG_BIND );
-// #endif
-                }
-            }
-        } else if ( hashmapp( store ) || namespacep( store ) ) {
-            result = hashmap_get( store, key );
-        } else if ( !nilp( store ) ) {
-// #ifdef DEBUG        
-//             debug_print( L"c_assoc; store is of unknown type `", DEBUG_BIND );
-//             debug_printf( DEBUG_BIND, L"%4.4s", (char *)pointer2cell(key).tag.bytes);
-//             debug_print( L"`\n", DEBUG_BIND );
-// #endif
-            result =
-                throw_exception( c_string_to_lisp_symbol( L"assoc" ),
-                                 c_append
-                                 ( c_string_to_lisp_string
-                                   ( L"Store is of unknown type: " ),
-                                   c_type( store ) ), NIL );
-        }
-    }
-
-    return result;
 }
 
 /**

src/ops/intern.h

@@ -20,6 +20,9 @@
 #ifndef __intern_h
 #define __intern_h
 
+#include <stdbool.h>
+
+
 extern struct cons_pointer privileged_symbol_nil;
 
 extern struct cons_pointer oblist;
@@ -31,7 +34,7 @@ void free_hashmap( struct cons_pointer ptr );
 void dump_map( URL_FILE * output, struct cons_pointer pointer );
 
 struct cons_pointer hashmap_get( struct cons_pointer mapp,
-                                 struct cons_pointer key );
+                                 struct cons_pointer key, bool return_key );
 
 struct cons_pointer hashmap_put( struct cons_pointer mapp,
                                  struct cons_pointer key,
@@ -46,6 +49,9 @@ struct cons_pointer make_hashmap( uint32_t n_buckets,
                                   struct cons_pointer hash_fn,
                                   struct cons_pointer write_acl );
 
+struct cons_pointer search_store( struct cons_pointer key,
+                                  struct cons_pointer store, bool return_key );
+
 struct cons_pointer c_assoc( struct cons_pointer key,
                              struct cons_pointer store );
 
@@ -55,9 +61,6 @@ struct cons_pointer interned( struct cons_pointer key,
 struct cons_pointer internedp( struct cons_pointer key,
                                struct cons_pointer environment );
 
-struct cons_pointer hashmap_get( struct cons_pointer mapp,
-                                 struct cons_pointer key );
-
 struct cons_pointer hashmap_put( struct cons_pointer mapp,
                                  struct cons_pointer key,
                                  struct cons_pointer val );

src/ops/lispops.c

@@ -365,8 +365,8 @@ struct cons_pointer maybe_fixup_exception_location( struct cons_pointer r,
                 pointer2cell( result ).payload.exception.payload =
                     make_cons( make_cons( privileged_keyword_location,
                                           c_assoc( name_key,
-                                                   fn_cell->payload.function.
+                                                   fn_cell->payload.
-                                                   meta ) ),
+                                                   function.meta ) ),
                                make_cons( make_cons
                                           ( privileged_keyword_payload,
                                             payload ), NIL ) );
@@ -420,7 +420,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
                             get_stack_frame( next_pointer );
 
                         result = maybe_fixup_exception_location( ( *
-                                                                   ( fn_cell->payload.function.executable ) )
+                                                                   ( fn_cell->
+                                                                     payload.
+                                                                     function.
+                                                                     executable ) )
                                                                  ( next,
                                                                    next_pointer,
                                                                    env ),
@@ -494,7 +497,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
                         result = next_pointer;
                     } else {
                         result = maybe_fixup_exception_location( ( *
-                                                                   ( fn_cell->payload.special.executable ) )
+                                                                   ( fn_cell->
+                                                                     payload.
+                                                                     special.
+                                                                     executable ) )
                                                                  ( get_stack_frame( next_pointer ), next_pointer, env ), fn_pointer );
                         debug_print( L"Special form returning: ", DEBUG_EVAL );
                         debug_print_object( result, DEBUG_EVAL );
@@ -1052,11 +1058,15 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer,
         frame->arg[0] : get_default_stream( true, env );
 
     if ( readp( in_stream ) ) {
-        debug_print( L"lisp_read: setting input stream\n", DEBUG_IO );
+        debug_print( L"lisp_read: setting input stream\n",
+                     DEBUG_IO | DEBUG_REPL );
         debug_dump_object( in_stream, DEBUG_IO );
         input = pointer2cell( in_stream ).payload.stream.stream;
         inc_ref( in_stream );
     } else {
+        /* should not happen, but has done. */
+        debug_print( L"WARNING: invalid input stream; defaulting!\n",
+                     DEBUG_IO | DEBUG_REPL );
         input = file_to_url_file( stdin );
     }
 
@@ -1332,10 +1342,17 @@ struct cons_pointer
 throw_exception( struct cons_pointer location,
                  struct cons_pointer message,
                  struct cons_pointer frame_pointer ) {
-    debug_print( L"\nERROR: ", DEBUG_EVAL );
-    debug_dump_object( message, DEBUG_EVAL );
     struct cons_pointer result = NIL;
 
+#ifdef DEBUG
+    debug_print( L"\nERROR: `", 511 );
+    debug_print_object( message, 511 );
+    debug_print( L"` at `", 511 );
+    debug_print_object( location, 511 );
+    debug_print( L"`\n", 511 );
+    debug_print_object( location, 511 );
+#endif
+
     struct cons_space_object *cell = &pointer2cell( message );
 
     if ( cell->tag.value == EXCEPTIONTV ) {
@@ -1378,8 +1395,7 @@ lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer,
 
     return exceptionp( message ) ? message : throw_exception( message,
                                                               frame->arg[1],
-                                                              frame->
+                                                              frame->previous );
-                                                              previous );
 }
 
 /**
@@ -1399,7 +1415,11 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
                                struct cons_pointer env ) {
     struct cons_pointer expr = NIL;
 
-    debug_printf( DEBUG_REPL, L"Entering new inner REPL\n" );
+#ifdef DEBUG
+    debug_print( L"Entering new inner REPL\n\tenv is `", DEBUG_REPL );
+    debug_print_object( env, DEBUG_REPL );
+    debug_print( L"`\n", DEBUG_REPL );
+#endif
 
     struct cons_pointer input = get_default_stream( true, env );
     struct cons_pointer output = get_default_stream( false, env );
@@ -1414,7 +1434,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
             set( c_string_to_lisp_symbol( L"*in*" ), frame->arg[1], new_env );
         input = frame->arg[1];
     }
-    if ( readp( frame->arg[2] ) ) {
+    if ( writep( frame->arg[2] ) ) {
         new_env =
             set( c_string_to_lisp_symbol( L"*out*" ), frame->arg[2], new_env );
         output = frame->arg[2];
@@ -1424,8 +1444,16 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
     inc_ref( output );
     inc_ref( prompt_name );
 
-    URL_FILE *os = pointer2cell( output ).payload.stream.stream;
+    /* output should NEVER BE nil; but during development it has happened.
-
+     * To allow debugging under such circumstances, we need an emergency 
+     * default. */
+    URL_FILE *os =
+        !writep( output ) ? file_to_url_file( stdout ) :
+        pointer2cell( output ).payload.stream.stream;
+    if ( !writep( output ) ) {
+        debug_print( L"WARNING: invalid output; defaulting!\n",
+                     DEBUG_IO | DEBUG_REPL );
+    }
 
     /* \todo this is subtly wrong. If we were evaluating
      *   (print (eval (read)))
@@ -1442,7 +1470,10 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
          * \todo the whole process of resolving symbol values needs to be revisited
          * when we get onto namespaces. */
         /* OK, there's something even more subtle here if the root namespace is a map.
-         * H'mmmm... */
+         * H'mmmm... 
+         * I think that now the oblist is a hashmap masquerading as a namespace,
+         * we should no longer have to do this. TODO: test, and if so, delete this
+         * statement. */
         if ( !eq( oblist, old_oblist ) ) {
             struct cons_pointer cursor = oblist;
 
@@ -1486,6 +1517,9 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
         dec_ref( expr );
     }
 
+    if ( nilp( output ) ) {
+        free( os );
+    }
     dec_ref( input );
     dec_ref( output );
     dec_ref( prompt_name );
@@ -1563,14 +1597,13 @@ struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) {
             if ( pointer2cell( l1 ).tag.value == pointer2cell( l2 ).tag.value ) {
                 if ( nilp( c_cdr( l1 ) ) ) {
                     return
-                        make_string_like_thing( ( pointer2cell( l1 ).
+                        make_string_like_thing( ( pointer2cell( l1 ).payload.
-                                                  payload.string.character ),
+                                                  string.character ), l2,
-                                                l2,
                                                 pointer2cell( l1 ).tag.value );
                 } else {
                     return
-                        make_string_like_thing( ( pointer2cell( l1 ).
+                        make_string_like_thing( ( pointer2cell( l1 ).payload.
-                                                  payload.string.character ),
+                                                  string.character ),
                                                 c_append( c_cdr( l1 ), l2 ),
                                                 pointer2cell( l1 ).tag.value );
                 }