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.
This commit is contained in:
parent
bcb227a5f9
commit
3a1f64d7ff
15 changed files with 284 additions and 184 deletions
|
|
@ -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.
|
||||
|
||||
|
|
|
|||
|
|
@ -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?)
|
||||
|
||||
|
|
|
|||
19
src/debug.c
19
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`.
|
||||
*
|
||||
|
|
|
|||
|
|
@ -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 );
|
||||
|
|
|
|||
|
|
@ -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 ),
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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 );
|
||||
|
|
|
|||
|
|
@ -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!" );
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 );
|
||||
|
|
|
|||
|
|
@ -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 );
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
|
|
|||
227
src/ops/intern.c
227
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 );
|
||||
}
|
||||
|
||||
/**
|
||||
|
|
|
|||
|
|
@ -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 );
|
||||
|
|
|
|||
|
|
@ -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 );
|
||||
}
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue