diff --git a/docs/Interning-strings.md b/docs/Interning-strings.md index af135a1..b92ded5 100644 --- a/docs/Interning-strings.md +++ b/docs/Interning-strings.md @@ -12,50 +12,58 @@ 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.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 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 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 ::users:simon:environment/froboz) + (eval .system.users.simon.environment.froboz) -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). +will return the value that **froboz** is bound to in the environment of the user of the system called **simon**. -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. +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. -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 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 this means there may be arbitrarily many paths which reference the same data item. This is intended. ## Related functions -### (intern! path) +### (intern! string) -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. +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. -### (intern! path T) +### (intern! string T) -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. +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. ### (set! string value) -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. +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. ### (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. @@ -63,16 +71,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") => (-> (environment) :foo :bar 'ban) - (string-to-path "::foo:bar/ban") => (-> (oblist) :foo :bar 'ban) + (string-to-path "foo.bar.ban") => ("foo" "bar" "ban") + (string-to-path ".foo.bar.ban") => ("" "foo" "bar" "ban") -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). +Obviously if the current user can't read the string, throws an exception. ### (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 b303856..33fd1e5 100644 --- a/lisp/documentation.lisp +++ b/lisp/documentation.lisp @@ -3,31 +3,6 @@ ;; `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 - ((= 0 (count 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")) @@ -40,7 +15,3 @@ (set! doc documentation) -(documentation apply) - -;; (documentation member?) - diff --git a/src/arith/peano.c b/src/arith/peano.c index 9a1b478..995ce0f 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -296,11 +296,9 @@ struct cons_pointer add_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = - throw_exception( c_string_to_lisp_symbol( L"+" ), - c_string_to_lisp_string - ( L"Cannot add: not a number" ), - frame_pointer ); + result = throw_exception( c_string_to_lisp_string + ( L"Cannot add: not a number" ), + frame_pointer ); break; } break; @@ -321,11 +319,9 @@ struct cons_pointer add_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = - throw_exception( c_string_to_lisp_symbol( L"+" ), - c_string_to_lisp_string - ( L"Cannot add: not a number" ), - frame_pointer ); + result = throw_exception( c_string_to_lisp_string + ( L"Cannot add: not a number" ), + frame_pointer ); break; } break; @@ -336,8 +332,7 @@ struct cons_pointer add_2( struct stack_frame *frame, break; default: result = exceptionp( arg2 ) ? arg2 : - throw_exception( c_string_to_lisp_symbol( L"+" ), - c_string_to_lisp_string + throw_exception( c_string_to_lisp_string ( L"Cannot add: not a number" ), frame_pointer ); } @@ -433,8 +428,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame, break; default: result = - throw_exception( c_string_to_lisp_symbol( L"*" ), - make_cons + throw_exception( make_cons ( c_string_to_lisp_string ( L"Cannot multiply: argument 2 is not a number: " ), c_type( arg2 ) ), @@ -460,8 +454,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame, break; default: result = - throw_exception( c_string_to_lisp_symbol( L"*" ), - make_cons + throw_exception( make_cons ( c_string_to_lisp_string ( L"Cannot multiply: argument 2 is not a number" ), c_type( arg2 ) ), @@ -474,8 +467,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = throw_exception( c_string_to_lisp_symbol( L"*" ), - make_cons( c_string_to_lisp_string + result = throw_exception( make_cons( c_string_to_lisp_string ( L"Cannot multiply: argument 1 is not a number" ), c_type( arg1 ) ), frame_pointer ); @@ -628,8 +620,7 @@ struct cons_pointer subtract_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = throw_exception( c_string_to_lisp_symbol( L"-" ), - c_string_to_lisp_string + result = throw_exception( c_string_to_lisp_string ( L"Cannot subtract: not a number" ), frame_pointer ); break; @@ -659,8 +650,7 @@ struct cons_pointer subtract_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = throw_exception( c_string_to_lisp_symbol( L"-" ), - c_string_to_lisp_string + result = throw_exception( c_string_to_lisp_string ( L"Cannot subtract: not a number" ), frame_pointer ); break; @@ -671,8 +661,7 @@ struct cons_pointer subtract_2( struct stack_frame *frame, make_real( to_long_double( arg1 ) - to_long_double( arg2 ) ); break; default: - result = throw_exception( c_string_to_lisp_symbol( L"-" ), - c_string_to_lisp_string + result = throw_exception( c_string_to_lisp_string ( L"Cannot subtract: not a number" ), frame_pointer ); break; @@ -743,8 +732,7 @@ struct cons_pointer lisp_divide( struct to_long_double( frame->arg[1] ) ); break; default: - result = throw_exception( c_string_to_lisp_symbol( L"/" ), - c_string_to_lisp_string + result = throw_exception( c_string_to_lisp_string ( L"Cannot divide: not a number" ), frame_pointer ); break; @@ -774,8 +762,7 @@ struct cons_pointer lisp_divide( struct to_long_double( frame->arg[1] ) ); break; default: - result = throw_exception( c_string_to_lisp_symbol( L"/" ), - c_string_to_lisp_string + result = throw_exception( c_string_to_lisp_string ( L"Cannot divide: not a number" ), frame_pointer ); break; @@ -787,8 +774,7 @@ struct cons_pointer lisp_divide( struct to_long_double( frame->arg[1] ) ); break; default: - result = throw_exception( c_string_to_lisp_symbol( L"/" ), - c_string_to_lisp_string + result = throw_exception( c_string_to_lisp_string ( L"Cannot divide: not a number" ), frame_pointer ); break; diff --git a/src/arith/ratio.c b/src/arith/ratio.c index 82f9138..1c20a4f 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -114,8 +114,7 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer arg1, cell1->payload.ratio.divisor ) ); r = make_ratio( dividend, divisor, true ); } else { - r = throw_exception( c_string_to_lisp_symbol( L"+" ), - make_cons( c_string_to_lisp_string + r = throw_exception( make_cons( c_string_to_lisp_string ( L"Shouldn't happen: bad arg to add_ratio_ratio" ), make_cons( arg1, make_cons( arg2, NIL ) ) ), @@ -155,8 +154,7 @@ struct cons_pointer add_integer_ratio( struct cons_pointer intarg, dec_ref( ratio ); } else { result = - throw_exception( c_string_to_lisp_symbol( L"+" ), - make_cons( c_string_to_lisp_string + throw_exception( make_cons( c_string_to_lisp_string ( L"Shouldn't happen: bad arg to add_integer_ratio" ), make_cons( intarg, make_cons( ratarg, @@ -236,8 +234,7 @@ struct cons_pointer multiply_ratio_ratio( struct release_integer( divisor ); } else { result = - throw_exception( c_string_to_lisp_symbol( L"*" ), - c_string_to_lisp_string + throw_exception( c_string_to_lisp_string ( L"Shouldn't happen: bad arg to multiply_ratio_ratio" ), NIL ); } @@ -272,8 +269,7 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg, release_integer( one ); } else { result = - throw_exception( c_string_to_lisp_symbol( L"*" ), - c_string_to_lisp_string + throw_exception( c_string_to_lisp_string ( L"Shouldn't happen: bad arg to multiply_integer_ratio" ), NIL ); } @@ -341,8 +337,7 @@ struct cons_pointer make_ratio( struct cons_pointer dividend, } } else { result = - throw_exception( c_string_to_lisp_symbol( L"make_ratio" ), - c_string_to_lisp_string + throw_exception( c_string_to_lisp_string ( L"Dividend and divisor of a ratio must be integers" ), NIL ); } diff --git a/src/debug.c b/src/debug.c index 631149d..1b895c2 100644 --- a/src/debug.c +++ b/src/debug.c @@ -32,25 +32,6 @@ */ 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 2e59932..ef3799d 100644 --- a/src/debug.h +++ b/src/debug.h @@ -81,7 +81,6 @@ 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 565065f..f1301ee 100644 --- a/src/init.c +++ b/src/init.c @@ -84,18 +84,12 @@ void maybe_bind_init_symbols( ) { if ( nilp( privileged_symbol_nil ) ) { privileged_symbol_nil = c_string_to_lisp_symbol( L"nil" ); } - // we can't make this string when we need it, because memory is then - // exhausted! if ( nilp( privileged_string_memory_exhausted ) ) { + // we can't make this string when we need it, because memory is then + // exhausted! privileged_string_memory_exhausted = c_string_to_lisp_string( L"Memory exhausted." ); } - if ( nilp( privileged_keyword_location ) ) { - privileged_keyword_location = c_string_to_lisp_keyword( L"location" ); - } - if ( nilp( privileged_keyword_payload ) ) { - privileged_keyword_payload = c_string_to_lisp_keyword( L"payload" ); - } } void free_init_symbols( ) { @@ -293,8 +287,6 @@ int main( int argc, char *argv[] ) { */ bind_symbol_value( privileged_symbol_nil, NIL, true ); bind_value( L"t", TRUE, true ); - bind_symbol_value( privileged_keyword_location, TRUE, true ); - bind_symbol_value( privileged_keyword_payload, TRUE, true ); /* * standard input, output, error and sink streams @@ -325,7 +317,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 ), @@ -409,14 +401,10 @@ int main( int argc, char *argv[] ) { bind_function( L"inspect", L"`(inspect object ouput-stream)`: Print details of this `object` to this `output-stream` or `*out*`.", &lisp_inspect ); - bind_function( L"interned?", - L"`(interned? key store)`: Return `t` if the symbol or keyword `key` is bound in this `store`, else `nil`.", - &lisp_internedp ); bind_function( L"keys", L"`(keys store)`: Return a list of all keys in this `store`.", &lisp_keys ); - bind_function( L"list", - L"`(list args...)`: Return a list of these `args`.", + bind_function( L"list", L"`(list args...): Return a list of these `args`.", &lisp_list ); bind_function( L"mapcar", L"`(mapcar function sequence)`: Apply `function` to each element of `sequence` in turn, and return a sequence of the results.", diff --git a/src/io/io.c b/src/io/io.c index 51a05cc..cf0894f 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 f5f80a5..fdd6ed4 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, false ) ); + print( output, hashmap_get( map, key ) ); if ( !nilp( c_cdr( ks ) ) ) { url_fputws( L", ", output ); @@ -348,9 +348,16 @@ lisp_println( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( writep( out_stream ) ) { output = pointer2cell( out_stream ).payload.stream.stream; + inc_ref( out_stream ); + } else { + output = file_to_url_file( stderr ); + } - println( output ); + println( output ); + if ( writep( out_stream ) ) { + dec_ref( out_stream ); + } else { free( output ); } diff --git a/src/io/read.c b/src/io/read.c index fee80b3..9ca49f0 100644 --- a/src/io/read.c +++ b/src/io/read.c @@ -167,8 +167,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, if ( url_feof( input ) ) { result = - throw_exception( c_string_to_lisp_symbol( L"read" ), - c_string_to_lisp_string + throw_exception( c_string_to_lisp_string ( L"End of file while reading" ), frame_pointer ); } else { switch ( c ) { @@ -178,8 +177,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, /* skip all characters from semi-colon to the end of the line */ break; case EOF: - result = throw_exception( c_string_to_lisp_symbol( L"read" ), - c_string_to_lisp_string + result = throw_exception( c_string_to_lisp_string ( L"End of input while reading" ), frame_pointer ); break; @@ -268,8 +266,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, result = read_symbol_or_key( input, SYMBOLTV, c ); } else { result = - throw_exception( c_string_to_lisp_symbol( L"read" ), - make_cons( c_string_to_lisp_string + throw_exception( make_cons( c_string_to_lisp_string ( L"Unrecognised start of input character" ), make_string( c, NIL ) ), frame_pointer ); @@ -316,8 +313,7 @@ struct cons_pointer read_number( struct stack_frame *frame, switch ( c ) { case LPERIOD: if ( seen_period || !nilp( dividend ) ) { - return throw_exception( c_string_to_lisp_symbol( L"read" ), - c_string_to_lisp_string + return throw_exception( c_string_to_lisp_string ( L"Malformed number: too many periods" ), frame_pointer ); } else { @@ -328,8 +324,7 @@ struct cons_pointer read_number( struct stack_frame *frame, break; case LSLASH: if ( seen_period || !nilp( dividend ) ) { - return throw_exception( c_string_to_lisp_symbol( L"read" ), - c_string_to_lisp_string + return throw_exception( c_string_to_lisp_string ( L"Malformed number: dividend of rational must be integer" ), frame_pointer ); } else { diff --git a/src/memory/conspage.c b/src/memory/conspage.c index 3d96647..d7d5cd0 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -250,9 +250,8 @@ struct cons_pointer allocate_cell( uint32_t tag ) { total_cells_allocated++; debug_printf( DEBUG_ALLOC, - L"Allocated cell of type %4.4s at %u, %u \n", - ( ( char * ) cell->tag.bytes ), result.page, - result.offset ); + L"Allocated cell of type '%4.4s' at %d, %d \n", + 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 3d8fe78..3793709 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -27,18 +27,6 @@ #include "memory/vectorspace.h" #include "ops/intern.h" -/** - * Keywords used when constructing exceptions: `:location`. Instantiated in - * `init.c`q.v. - */ -struct cons_pointer privileged_keyword_location = NIL; - -/** - * Keywords used when constructing exceptions: `:payload`. Instantiated in - * `init.c`, q.v. - */ -struct cons_pointer privileged_keyword_payload = NIL; - /** * True if the value of the tag on the cell at this `pointer` is this `value`, * or, if the tag of the cell is `VECP`, if the value of the tag of the @@ -47,11 +35,11 @@ struct cons_pointer privileged_keyword_payload = NIL; bool check_tag( struct cons_pointer pointer, uint32_t value ) { bool result = false; - struct cons_space_object *cell = &pointer2cell( pointer ); - result = cell->tag.value == value; + struct cons_space_object cell = pointer2cell( pointer ); + result = cell.tag.value == value; if ( result == false ) { - if ( cell->tag.value == VECTORPOINTTV ) { + if ( cell.tag.value == VECTORPOINTTV ) { struct vector_space_object *vec = pointer_to_vso( pointer ); if ( vec != NULL ) { @@ -78,7 +66,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 %u, offset %u to count %u", + L"\nIncremented cell of type %4.4s at page %d, offset %d to count %d", ( ( char * ) cell->tag.bytes ), pointer.page, pointer.offset, cell->count ); if ( strncmp( cell->tag.bytes, VECTORPOINTTAG, TAGLENGTH ) == 0 ) { @@ -131,19 +119,6 @@ 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. @@ -412,15 +387,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 = internedp( 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 1357f34..adde136 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -56,18 +56,6 @@ */ #define EXCEPTIONTV 1346721861 -/** - * Keywords used when constructing exceptions: `:location`. Instantiated in - * `init.c`. - */ -extern struct cons_pointer privileged_keyword_location; - -/** - * Keywords used when constructing exceptions: `:payload`. Instantiated in - * `init.c`. - */ -extern struct cons_pointer privileged_keyword_payload; - /** * An unallocated cell on the free list - should never be encountered by a Lisp * function. @@ -722,11 +710,6 @@ 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 b065661..3a83866 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/memory/stack.c b/src/memory/stack.c index 7f5d581..b6833c9 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -161,10 +161,6 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous, env ); frame->more = more; inc_ref( more ); - - for ( ; !nilp( args ); args = c_cdr( args ) ) { - frame->args++; - } } } debug_print( L"make_stack_frame: returning\n", DEBUG_STACK ); diff --git a/src/ops/equal.c b/src/ops/equal.c index b2d0fa2..b4412fb 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -272,9 +272,7 @@ 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, false ), - hashmap_get( b, key, false ) ) ) { + if ( !equal( hashmap_get( a, key ), hashmap_get( b, key ) ) ) { result = false; break; } @@ -377,7 +375,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { memset( a_buff, 0, sizeof( a_buff ) ); memset( b_buff, 0, sizeof( b_buff ) ); - for ( ; ( i < ( STRING_SHIPYARD_SIZE - 1 ) ) && !nilp( a ) + for ( ; + ( i < ( STRING_SHIPYARD_SIZE - 1 ) ) && !nilp( a ) && !nilp( b ); i++ ) { a_buff[i] = cell_a->payload.string.character; a = c_cdr( a ); diff --git a/src/ops/intern.c b/src/ops/intern.c index ae9800a..e064ac4 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, false ) ); + hashmap_put( mapp, key, hashmap_get( assoc, key ) ); } } } @@ -216,33 +216,17 @@ 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 search_store, q.v. + * closely tied in with c_assoc, q.v. */ struct cons_pointer hashmap_get( struct cons_pointer mapp, - 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 key ) { 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 = - search_store( key, map->payload.hashmap.buckets[bucket_no], - return_key ); + result = c_assoc( key, map->payload.hashmap.buckets[bucket_no] ); } -#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; } @@ -283,146 +267,57 @@ 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) + /** - * @brief `(search-store key store return-key?)` Search this `store` for this - * a key lexically identical to this `key`. + * Implementation of interned? in C. The final implementation if interned? will + * deal with stores which can be association lists or hashtables or hybrids of + * the two, but that will almost certainly be implemented in lisp. * - * 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. + * 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. */ -struct cons_pointer search_store( struct cons_pointer key, - struct cons_pointer store, - bool return_key ) { +struct cons_pointer +internedp( struct cons_pointer key, struct cons_pointer store ) { struct cons_pointer result = NIL; -#ifdef DEBUG - debug_print( L"\nsearch_store; key is `", DEBUG_BIND ); - debug_print_object( key, 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 *store_cell = &pointer2cell( store ); + // TODO: I see what I was doing here and it would be the right thing to + // do for stores which are old-fashioned assoc lists, but it will not work + // for my new hybrid stores. + // for ( struct cons_pointer next = store; + // nilp( result ) && consp( next ); + // next = pointer2cell( next ).payload.cons.cdr ) { + // struct cons_space_object entry = + // pointer2cell( pointer2cell( next ).payload.cons.car ); - switch ( get_tag_value( store ) ) { - case CONSTV: - 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 ); + // debug_print( L"Internedp: checking whether `", DEBUG_BIND ); + // debug_print_object( key, DEBUG_BIND ); + // debug_print( L"` equals `", DEBUG_BIND ); + // debug_print_object( entry.payload.cons.car, DEBUG_BIND ); + // debug_print( L"`\n", DEBUG_BIND ); - 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 HASHTV: - case NAMESPACETV: - result = hashmap_get( store, key, return_key ); - break; - default: - result = - 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; + // if ( equal( key, entry.payload.cons.car ) ) { + // result = entry.payload.cons.car; + // } + if ( !nilp( c_assoc( key, store ) ) ) { + result = key; + } else if ( equal( key, privileged_symbol_nil ) ) { + result = privileged_symbol_nil; } } else { - // failing with key type NIL here (?). Probably worth dumping the stack? - result = - 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"`", DEBUG_BIND ); + debug_print_object( key, DEBUG_BIND ); + debug_print( L"` is a ", DEBUG_BIND ); + debug_printf( DEBUG_BIND, L"%4.4s", + ( char * ) pointer2cell( key ).tag.bytes ); + debug_print( L", not a KEYW or SYMB", 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. - * - * @param key the key to search for. - * @param store the store to search in. - * @return struct cons_pointer `t` if the key was found, else `nil`. - */ -struct cons_pointer internedp( struct cons_pointer key, - struct cons_pointer store ) { - return nilp( interned( key, store ) ) ? NIL : TRUE; -} - /** * Implementation of assoc in C. Like interned?, the final implementation will * deal with stores which can be association lists or hashtables or hybrids of @@ -433,7 +328,65 @@ struct cons_pointer internedp( struct cons_pointer key, */ struct cons_pointer c_assoc( struct cons_pointer key, struct cons_pointer store ) { - return search_store( key, store, false ); + 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_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 ) ) { + 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_append + ( c_string_to_lisp_string + ( L"Store is of unknown type: " ), + c_type( store ) ), NIL ); + } + } + + return result; } /** @@ -461,23 +414,19 @@ struct cons_pointer hashmap_put( struct cons_pointer mapp, map->payload.hashmap.buckets[bucket_no] ); } - debug_print( L"hashmap_put:\n", DEBUG_BIND ); - debug_dump_object( mapp, DEBUG_BIND ); - return mapp; } -/** - * If this store is modifiable, add this key value pair to it. Otherwise, - * return a new key/value store containing all the key/value pairs in this - * store with this key/value pair added to the front. - */ + /** + * Return a new key/value store containing all the key/value pairs in this + * store with this key/value pair added to the front. + */ struct cons_pointer set( struct cons_pointer key, struct cons_pointer value, struct cons_pointer store ) { struct cons_pointer result = NIL; #ifdef DEBUG - bool deep = eq( store, oblist ); + bool deep = vectorpointp( store ); debug_print_binding( key, value, deep, DEBUG_BIND ); if ( deep ) { @@ -485,7 +434,9 @@ struct cons_pointer set( struct cons_pointer key, struct cons_pointer value, pointer2cell( store ).payload.vectorp.tag.bytes ); } #endif - if ( nilp( store ) || consp( store ) ) { + if ( nilp( value ) ) { + result = store; + } else if ( nilp( store ) || consp( store ) ) { result = make_cons( make_cons( key, value ), store ); } else if ( hashmapp( store ) ) { result = hashmap_put( store, key, value ); @@ -501,8 +452,16 @@ struct cons_pointer deep_bind( struct cons_pointer key, struct cons_pointer value ) { debug_print( L"Entering deep_bind\n", DEBUG_BIND ); + struct cons_pointer old = oblist; + oblist = set( key, value, oblist ); + // The oblist is not now an assoc list, and I don't think it will be again. + // if ( consp( oblist ) ) { + // inc_ref( oblist ); + // dec_ref( old ); + // } + debug_print( L"deep_bind returning ", DEBUG_BIND ); debug_print_object( key, DEBUG_BIND ); debug_println( DEBUG_BIND ); @@ -521,7 +480,7 @@ intern( struct cons_pointer key, struct cons_pointer environment ) { struct cons_pointer canonical = internedp( key, environment ); if ( nilp( canonical ) ) { /* - * not currently bound. TODO: this should bind to NIL? + * not currently bound */ result = set( key, TRUE, environment ); } diff --git a/src/ops/intern.h b/src/ops/intern.h index 18fc084..bc22bf7 100644 --- a/src/ops/intern.h +++ b/src/ops/intern.h @@ -20,9 +20,6 @@ #ifndef __intern_h #define __intern_h -#include - - extern struct cons_pointer privileged_symbol_nil; extern struct cons_pointer oblist; @@ -34,7 +31,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, bool return_key ); + struct cons_pointer key ); struct cons_pointer hashmap_put( struct cons_pointer mapp, struct cons_pointer key, @@ -49,18 +46,15 @@ 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 ); -struct cons_pointer interned( struct cons_pointer key, - struct cons_pointer environment ); - 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 c2b0e70..7333c3f 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -248,7 +248,7 @@ lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer, * Evaluate a lambda or nlambda expression. */ struct cons_pointer -eval_lambda( struct cons_space_object *cell, struct stack_frame *frame, +eval_lambda( struct cons_space_object cell, struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; #ifdef DEBUG @@ -257,8 +257,8 @@ eval_lambda( struct cons_space_object *cell, struct stack_frame *frame, #endif struct cons_pointer new_env = env; - struct cons_pointer names = cell->payload.lambda.args; - struct cons_pointer body = cell->payload.lambda.body; + struct cons_pointer names = cell.payload.lambda.args; + struct cons_pointer body = cell.payload.lambda.body; if ( consp( names ) ) { /* if `names` is a list, bind successive items from that list @@ -328,56 +328,6 @@ eval_lambda( struct cons_space_object *cell, struct stack_frame *frame, return result; } -/** - * if `r` is an exception, and it doesn't have a location, fix up its location from - * the name associated with this fn_pointer, if any. - */ -struct cons_pointer maybe_fixup_exception_location( struct cons_pointer r, - struct cons_pointer - fn_pointer ) { - struct cons_pointer result = r; - - if ( exceptionp( result ) - && ( functionp( fn_pointer ) || specialp( fn_pointer ) ) ) { - struct cons_space_object *fn_cell = &pointer2cell( fn_pointer ); - - struct cons_pointer payload = - pointer2cell( result ).payload.exception.payload; - /* TODO: should name_key also be a privileged keyword? */ - struct cons_pointer name_key = c_string_to_lisp_keyword( L"name" ); - - switch ( get_tag_value( payload ) ) { - case NILTV: - case CONSTV: - case HASHTV: - { - if ( nilp( c_assoc( privileged_keyword_location, - payload ) ) ) { - pointer2cell( result ).payload.exception.payload = - set( privileged_keyword_location, - c_assoc( name_key, - fn_cell->payload.function.meta ), - payload ); - } - } - break; - default: - pointer2cell( result ).payload.exception.payload = - make_cons( make_cons( privileged_keyword_location, - c_assoc( name_key, - fn_cell->payload. - function.meta ) ), - make_cons( make_cons - ( privileged_keyword_payload, - payload ), NIL ) ); - } - - dec_ref( name_key ); - } - - return result; -} - /** * Internal guts of apply. @@ -398,10 +348,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( exceptionp( fn_pointer ) ) { result = fn_pointer; } else { - struct cons_space_object *fn_cell = &pointer2cell( fn_pointer ); + struct cons_space_object fn_cell = pointer2cell( fn_pointer ); struct cons_pointer args = c_cdr( frame->arg[0] ); - switch ( get_tag_value( fn_pointer ) ) { + switch ( fn_cell.tag.value ) { case EXCEPTIONTV: /* just pass exceptions straight back */ result = fn_pointer; @@ -419,15 +369,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct stack_frame *next = get_stack_frame( next_pointer ); - result = maybe_fixup_exception_location( ( * - ( fn_cell-> - payload. - function. - executable ) ) - ( next, - next_pointer, - env ), - fn_pointer ); + result = + ( *fn_cell.payload.function.executable ) ( next, + next_pointer, + env ); dec_ref( next_pointer ); } } @@ -461,14 +406,18 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, } break; - case HASHTV: - /* \todo: if arg[0] is a CONS, treat it as a path */ - result = c_assoc( eval_form( frame, - frame_pointer, - c_car( c_cdr - ( frame->arg - [0] ) ), env ), - fn_pointer ); + case VECTORPOINTTV: + switch ( pointer_to_vso( fn_pointer )->header.tag.value ) { + case HASHTV: + /* \todo: if arg[0] is a CONS, treat it as a path */ + result = c_assoc( eval_form( frame, + frame_pointer, + c_car( c_cdr + ( frame->arg + [0] ) ), env ), + fn_pointer ); + break; + } break; case NLAMBDATV: @@ -492,16 +441,15 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, { struct cons_pointer next_pointer = make_special_frame( frame_pointer, args, env ); - // inc_ref( next_pointer ); + inc_ref( next_pointer ); if ( exceptionp( next_pointer ) ) { result = next_pointer; } else { - result = maybe_fixup_exception_location( ( * - ( fn_cell-> - payload. - special. - executable ) ) - ( get_stack_frame( next_pointer ), next_pointer, env ), fn_pointer ); + result = + ( *fn_cell.payload. + special.executable ) ( get_stack_frame + ( next_pointer ), + next_pointer, env ); debug_print( L"Special form returning: ", DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL ); debug_println( DEBUG_EVAL ); @@ -517,16 +465,13 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, memset( buffer, '\0', bs ); swprintf( buffer, bs, L"Unexpected cell with tag %d (%4.4s) in function position", - fn_cell->tag.value, &( fn_cell->tag.bytes[0] ) ); + fn_cell.tag.value, &fn_cell.tag.bytes[0] ); struct cons_pointer message = c_string_to_lisp_string( buffer ); free( buffer ); - result = - throw_exception( c_string_to_lisp_symbol( L"apply" ), - message, frame_pointer ); + result = throw_exception( message, frame_pointer ); } } - } debug_print( L"c_apply: returning: ", DEBUG_EVAL ); @@ -563,24 +508,23 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, debug_dump_object( frame_pointer, DEBUG_EVAL ); struct cons_pointer result = frame->arg[0]; - struct cons_space_object *cell = &pointer2cell( frame->arg[0] ); + struct cons_space_object cell = pointer2cell( frame->arg[0] ); - switch ( cell->tag.value ) { + switch ( cell.tag.value ) { case CONSTV: result = c_apply( frame, frame_pointer, env ); break; case SYMBOLTV: { - struct cons_pointer canonical = interned( frame->arg[0], env ); + struct cons_pointer canonical = + internedp( frame->arg[0], env ); if ( nilp( canonical ) ) { struct cons_pointer message = make_cons( c_string_to_lisp_string ( L"Attempt to take value of unbound symbol." ), frame->arg[0] ); - result = - throw_exception( c_string_to_lisp_symbol( L"eval" ), - message, frame_pointer ); + result = throw_exception( message, frame_pointer ); } else { result = c_assoc( canonical, env ); inc_ref( result ); @@ -681,8 +625,7 @@ lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, result = frame->arg[1]; } else { result = - throw_exception( c_string_to_lisp_symbol( L"set" ), - make_cons + throw_exception( make_cons ( c_string_to_lisp_string ( L"The first argument to `set` is not a symbol: " ), make_cons( frame->arg[0], NIL ) ), @@ -721,8 +664,7 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, result = val; } else { result = - throw_exception( c_string_to_lisp_symbol( L"set!" ), - make_cons + throw_exception( make_cons ( c_string_to_lisp_string ( L"The first argument to `set!` is not a symbol: " ), make_cons( frame->arg[0], NIL ) ), @@ -794,25 +736,24 @@ struct cons_pointer lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; - struct cons_space_object *cell = &pointer2cell( frame->arg[0] ); + struct cons_space_object cell = pointer2cell( frame->arg[0] ); - switch ( cell->tag.value ) { + switch ( cell.tag.value ) { case CONSTV: - result = cell->payload.cons.car; + result = cell.payload.cons.car; break; case NILTV: break; case READTV: result = - make_string( url_fgetwc( cell->payload.stream.stream ), NIL ); + make_string( url_fgetwc( cell.payload.stream.stream ), NIL ); break; case STRINGTV: - result = make_string( cell->payload.string.character, NIL ); + result = make_string( cell.payload.string.character, NIL ); break; default: result = - throw_exception( c_string_to_lisp_symbol( L"car" ), - c_string_to_lisp_string + throw_exception( c_string_to_lisp_string ( L"Attempt to take CAR of non sequence" ), frame_pointer ); } @@ -839,25 +780,24 @@ struct cons_pointer lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; - struct cons_space_object *cell = &pointer2cell( frame->arg[0] ); + struct cons_space_object cell = pointer2cell( frame->arg[0] ); - switch ( cell->tag.value ) { + switch ( cell.tag.value ) { case CONSTV: - result = cell->payload.cons.cdr; + result = cell.payload.cons.cdr; break; case NILTV: break; case READTV: - url_fgetwc( cell->payload.stream.stream ); + url_fgetwc( cell.payload.stream.stream ); result = frame->arg[0]; break; case STRINGTV: - result = cell->payload.string.cdr; + result = cell.payload.string.cdr; break; default: result = - throw_exception( c_string_to_lisp_symbol( L"cdr" ), - c_string_to_lisp_string + throw_exception( c_string_to_lisp_string ( L"Attempt to take CDR of non sequence" ), frame_pointer ); } @@ -895,35 +835,7 @@ struct cons_pointer lisp_length( struct stack_frame *frame, struct cons_pointer lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - return c_assoc( frame->arg[0], - nilp( frame->arg[1] ) ? oblist : frame->arg[1] ); -} - -/** - * @brief `(interned? key store)`: Return `t` if the symbol or keyword `key` is bound in this `store`, else `nil`. - * - * @param frame - * @param frame_pointer - * @param env - * @return struct cons_pointer - */ -struct cons_pointer -lisp_internedp( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = internedp( frame->arg[0], - nilp( frame->arg[1] ) ? oblist : - frame->arg[1] ); - - if ( exceptionp( result ) ) { - struct cons_pointer old = result; - struct cons_space_object *cell = &( pointer2cell( result ) ); - result = - throw_exception( c_string_to_lisp_symbol( L"interned?" ), - cell->payload.exception.payload, frame_pointer ); - dec_ref( old ); - } - - return result; + return c_assoc( frame->arg[0], frame->arg[1] ); } struct cons_pointer c_keys( struct cons_pointer store ) { @@ -1058,15 +970,11 @@ 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_REPL ); + debug_print( L"lisp_read: setting input stream\n", DEBUG_IO ); 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 ); } @@ -1280,8 +1188,7 @@ struct cons_pointer eval_cond_clause( struct cons_pointer clause, #endif } } else { - result = throw_exception( c_string_to_lisp_symbol( L"cond" ), - c_string_to_lisp_string + result = throw_exception( c_string_to_lisp_string ( L"Arguments to `cond` must be lists" ), frame_pointer ); } @@ -1339,32 +1246,18 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, * pointer to the frame in which the exception occurred. */ struct cons_pointer -throw_exception( struct cons_pointer location, - struct cons_pointer message, +throw_exception( 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 ); - struct cons_space_object *cell = &pointer2cell( message ); - - if ( cell->tag.value == EXCEPTIONTV ) { + if ( cell.tag.value == EXCEPTIONTV ) { result = message; } else { - result = - make_exception( make_cons - ( make_cons( privileged_keyword_location, - location ), - make_cons( make_cons - ( privileged_keyword_payload, - message ), NIL ) ), frame_pointer ); + result = make_exception( message, frame_pointer ); } return result; @@ -1377,7 +1270,7 @@ throw_exception( struct cons_pointer location, * normally return. A function which detects a problem it cannot resolve * *should* return an exception. * - * * (exception message location) + * * (exception message frame) * * @param frame my stack frame. * @param frame_pointer a pointer to my stack_frame. @@ -1392,10 +1285,9 @@ struct cons_pointer lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer message = frame->arg[0]; - return exceptionp( message ) ? message : throw_exception( message, - frame->arg[1], - frame->previous ); + frame-> + previous ); } /** @@ -1415,11 +1307,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, struct cons_pointer env ) { struct cons_pointer expr = NIL; -#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 + debug_printf( DEBUG_REPL, L"Entering new inner REPL\n" ); struct cons_pointer input = get_default_stream( true, env ); struct cons_pointer output = get_default_stream( false, env ); @@ -1434,7 +1322,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 ( writep( frame->arg[2] ) ) { + if ( readp( frame->arg[2] ) ) { new_env = set( c_string_to_lisp_symbol( L"*out*" ), frame->arg[2], new_env ); output = frame->arg[2]; @@ -1444,16 +1332,8 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, inc_ref( output ); inc_ref( prompt_name ); - /* 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 ); - } + URL_FILE *os = pointer2cell( output ).payload.stream.stream; + /* \todo this is subtly wrong. If we were evaluating * (print (eval (read))) @@ -1470,10 +1350,7 @@ 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... - * 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. */ + * H'mmmm... */ if ( !eq( oblist, old_oblist ) ) { struct cons_pointer cursor = oblist; @@ -1517,9 +1394,6 @@ 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 ); @@ -1546,24 +1420,24 @@ struct cons_pointer lisp_source( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; - struct cons_space_object *cell = &pointer2cell( frame->arg[0] ); + struct cons_space_object cell = pointer2cell( frame->arg[0] ); struct cons_pointer source_key = c_string_to_lisp_keyword( L"source" ); - switch ( cell->tag.value ) { + switch ( cell.tag.value ) { case FUNCTIONTV: - result = c_assoc( source_key, cell->payload.function.meta ); + result = c_assoc( source_key, cell.payload.function.meta ); break; case SPECIALTV: - result = c_assoc( source_key, cell->payload.special.meta ); + result = c_assoc( source_key, cell.payload.special.meta ); break; case LAMBDATV: result = make_cons( c_string_to_lisp_symbol( L"lambda" ), - make_cons( cell->payload.lambda.args, - cell->payload.lambda.body ) ); + make_cons( cell.payload.lambda.args, + cell.payload.lambda.body ) ); break; case NLAMBDATV: result = make_cons( c_string_to_lisp_symbol( L"nlambda" ), - make_cons( cell->payload.lambda.args, - cell->payload.lambda.body ) ); + make_cons( cell.payload.lambda.args, + cell.payload.lambda.body ) ); break; } // \todo suffers from premature GC, and I can't see why! @@ -1586,8 +1460,7 @@ struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) { c_append( c_cdr( l1 ), l2 ) ); } } else { - throw_exception( c_string_to_lisp_symbol( L"append" ), - c_string_to_lisp_string + throw_exception( c_string_to_lisp_string ( L"Can't append: not same type" ), NIL ); } break; @@ -1597,25 +1470,24 @@ 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 ); } } else { - throw_exception( c_string_to_lisp_symbol( L"append" ), - c_string_to_lisp_string + throw_exception( c_string_to_lisp_string ( L"Can't append: not same type" ), NIL ); } break; default: - throw_exception( c_string_to_lisp_symbol( L"append" ), - c_string_to_lisp_string + throw_exception( c_string_to_lisp_string ( L"Can't append: not a sequence" ), NIL ); break; } @@ -1727,8 +1599,7 @@ struct cons_pointer lisp_let( struct stack_frame *frame, bindings = make_cons( make_cons( symbol, val ), bindings ); } else { result = - throw_exception( c_string_to_lisp_symbol( L"let" ), - c_string_to_lisp_string + throw_exception( c_string_to_lisp_string ( L"Let: cannot bind, not a symbol" ), frame_pointer ); break; diff --git a/src/ops/lispops.h b/src/ops/lispops.h index da2428a..aea8772 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -131,9 +131,6 @@ struct cons_pointer lisp_cdr( struct stack_frame *frame, struct cons_pointer lisp_inspect( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); -struct cons_pointer lisp_internedp( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); struct cons_pointer lisp_eq( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); @@ -196,8 +193,7 @@ struct cons_pointer lisp_cond( struct stack_frame *frame, * signature of a lisp function; but it is nevertheless to be preferred to * make_exception. A real `throw_exception`, which does, will be needed. */ -struct cons_pointer throw_exception( struct cons_pointer location, - struct cons_pointer message, +struct cons_pointer throw_exception( struct cons_pointer message, struct cons_pointer frame_pointer ); struct cons_pointer lisp_exception( struct stack_frame *frame,