diff --git a/docs/Interning-strings.md b/docs/Interning-strings.md index b92ded5..af135a1 100644 --- a/docs/Interning-strings.md +++ b/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. - -### (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. +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. ### (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") => ("" "foo" "bar" "ban") + (string-to-path ":foo:bar/ban") => (-> (environment) :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. diff --git a/lisp/documentation.lisp b/lisp/documentation.lisp index 33fd1e5..7f5867b 100644 --- a/lisp/documentation.lisp +++ b/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?) + diff --git a/src/debug.c b/src/debug.c index 1b895c2..631149d 100644 --- a/src/debug.c +++ b/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`. * diff --git a/src/debug.h b/src/debug.h index ef3799d..2e59932 100644 --- a/src/debug.h +++ b/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 ); diff --git a/src/init.c b/src/init.c index 04eeeed..74b6d94 100644 --- a/src/init.c +++ b/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 ), diff --git a/src/io/io.c b/src/io/io.c index cf0894f..51a05cc 100644 --- a/src/io/io.c +++ b/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. - stream.stream ), NIL ); + ( pointer2cell( frame->arg[0] ).payload.stream. + stream ), NIL ); } return result; diff --git a/src/io/print.c b/src/io/print.c index fdd6ed4..a8f2770 100644 --- a/src/io/print.c +++ b/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 ); diff --git a/src/memory/conspage.c b/src/memory/conspage.c index d7d5cd0..3d96647 100644 --- a/src/memory/conspage.c +++ b/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", - cell->tag.bytes, result.page, result.offset ); + L"Allocated cell of type %4.4s at %u, %u \n", + ( ( char * ) cell->tag.bytes ), result.page, + result.offset ); } else { debug_printf( DEBUG_ALLOC, L"WARNING: Allocating non-free cell!" ); } diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 2848b83..3d8fe78 100644 --- a/src/memory/consspaceobject.c +++ b/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 ) { - struct cons_pointer r = interned( result, oblist ); + // if ( tag == KEYTV ) { + // struct cons_pointer r = interned( result, oblist ); - if ( nilp( r ) ) { - intern( result, oblist ); - } else { - result = r; - } - } + // if ( nilp( r ) ) { + // intern( result, oblist ); + // } else { + // result = r; + // } + // } } else { result = make_exception( c_string_to_lisp_string diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index bddd232..1357f34 100644 --- a/src/memory/consspaceobject.h +++ b/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 ); diff --git a/src/memory/dump.c b/src/memory/dump.c index 3a83866..b065661 100644 --- a/src/memory/dump.c +++ b/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 ). - payload.integer.value, - pointer2cell( cell.payload.ratio.divisor ). - payload.integer.value, cell.count ); + pointer2cell( cell.payload.ratio.dividend ).payload. + integer.value, + pointer2cell( cell.payload.ratio.divisor ).payload. + integer.value, cell.count ); break; case READTV: url_fputws( L"\t\tInput stream; metadata: ", output ); diff --git a/src/ops/equal.c b/src/ops/equal.c index ea813a9..b2d0fa2 100644 --- a/src/ops/equal.c +++ b/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; } diff --git a/src/ops/intern.c b/src/ops/intern.c index ee15485..ae9800a 100644 --- a/src/ops/intern.c +++ b/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 - * from the store (so that later when we want to retrieve a value, an eq test - * will work); otherwise return NIL. + * @brief `(search-store key store return-key?)` Search this `store` for this + * a key lexically identical to this `key`. + * + * 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 store ) { +struct cons_pointer search_store( struct cons_pointer key, + 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; - nilp( result ) && consp( next ); next = c_cdr( next ) ) { - if ( !nilp( next ) ) { - // struct cons_space_object entry = - // pointer2cell( c_car( next) ); + for ( struct cons_pointer cursor = store; + nilp( result ) && ( consp( cursor ) + || hashmapp( cursor ) ); + cursor = pointer2cell( cursor ).payload.cons.cdr ) { + switch ( get_tag_value( cursor ) ) { + case CONSTV: + struct cons_pointer entry_ptr = c_car( cursor ); - if ( equal( key, c_car( next ) ) ) { - result = key; - } + switch ( get_tag_value( entry_ptr ) ) { + 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: - if ( hashmapp( store ) || namespacep( store ) ) { - // get the right hash bucket and recursively call interned on that. - 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 ); - } + case HASHTV: + case NAMESPACETV: + result = hashmap_get( store, key, return_key ); break; default: 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 ); + throw_exception( c_string_to_lisp_symbol + ( L"search-store (store)" ), + make_cons( c_string_to_lisp_string + ( L"Unexpected store type: " ), + 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; - - 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; + return search_store( key, store, false ); } /** diff --git a/src/ops/intern.h b/src/ops/intern.h index 4043e66..18fc084 100644 --- a/src/ops/intern.h +++ b/src/ops/intern.h @@ -20,6 +20,9 @@ #ifndef __intern_h #define __intern_h +#include + + 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 ); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 98497f6..c2b0e70 100644 --- a/src/ops/lispops.c +++ b/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. - meta ) ), + fn_cell->payload. + 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-> - previous ); + frame->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 ). - payload.string.character ), - l2, + make_string_like_thing( ( pointer2cell( l1 ).payload. + string.character ), l2, pointer2cell( l1 ).tag.value ); } else { return - make_string_like_thing( ( pointer2cell( l1 ). - payload.string.character ), + make_string_like_thing( ( pointer2cell( l1 ).payload. + string.character ), c_append( c_cdr( l1 ), l2 ), pointer2cell( l1 ).tag.value ); }