Compare commits
6 commits
145a0fe5a7
...
72a8bc09e0
| Author | SHA1 | Date | |
|---|---|---|---|
| 72a8bc09e0 | |||
| 3a1f64d7ff | |||
| bcb227a5f9 | |||
| a1c377bc7c | |||
| 54f6f023c6 | |||
| 72548097cf |
20 changed files with 589 additions and 291 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
|
||||
((= 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"))
|
||||
|
|
@ -15,3 +40,7 @@
|
|||
|
||||
(set! doc documentation)
|
||||
|
||||
(documentation apply)
|
||||
|
||||
;; (documentation member?)
|
||||
|
||||
|
|
|
|||
|
|
@ -296,9 +296,11 @@ struct cons_pointer add_2( struct stack_frame *frame,
|
|||
to_long_double( arg2 ) );
|
||||
break;
|
||||
default:
|
||||
result = throw_exception( c_string_to_lisp_string
|
||||
( L"Cannot add: not a number" ),
|
||||
frame_pointer );
|
||||
result =
|
||||
throw_exception( c_string_to_lisp_symbol( L"+" ),
|
||||
c_string_to_lisp_string
|
||||
( L"Cannot add: not a number" ),
|
||||
frame_pointer );
|
||||
break;
|
||||
}
|
||||
break;
|
||||
|
|
@ -319,9 +321,11 @@ struct cons_pointer add_2( struct stack_frame *frame,
|
|||
to_long_double( arg2 ) );
|
||||
break;
|
||||
default:
|
||||
result = throw_exception( c_string_to_lisp_string
|
||||
( L"Cannot add: not a number" ),
|
||||
frame_pointer );
|
||||
result =
|
||||
throw_exception( c_string_to_lisp_symbol( L"+" ),
|
||||
c_string_to_lisp_string
|
||||
( L"Cannot add: not a number" ),
|
||||
frame_pointer );
|
||||
break;
|
||||
}
|
||||
break;
|
||||
|
|
@ -332,7 +336,8 @@ struct cons_pointer add_2( struct stack_frame *frame,
|
|||
break;
|
||||
default:
|
||||
result = exceptionp( arg2 ) ? arg2 :
|
||||
throw_exception( c_string_to_lisp_string
|
||||
throw_exception( c_string_to_lisp_symbol( L"+" ),
|
||||
c_string_to_lisp_string
|
||||
( L"Cannot add: not a number" ),
|
||||
frame_pointer );
|
||||
}
|
||||
|
|
@ -428,7 +433,8 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
|
|||
break;
|
||||
default:
|
||||
result =
|
||||
throw_exception( make_cons
|
||||
throw_exception( c_string_to_lisp_symbol( L"*" ),
|
||||
make_cons
|
||||
( c_string_to_lisp_string
|
||||
( L"Cannot multiply: argument 2 is not a number: " ),
|
||||
c_type( arg2 ) ),
|
||||
|
|
@ -454,7 +460,8 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
|
|||
break;
|
||||
default:
|
||||
result =
|
||||
throw_exception( make_cons
|
||||
throw_exception( c_string_to_lisp_symbol( L"*" ),
|
||||
make_cons
|
||||
( c_string_to_lisp_string
|
||||
( L"Cannot multiply: argument 2 is not a number" ),
|
||||
c_type( arg2 ) ),
|
||||
|
|
@ -467,7 +474,8 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
|
|||
to_long_double( arg2 ) );
|
||||
break;
|
||||
default:
|
||||
result = throw_exception( make_cons( c_string_to_lisp_string
|
||||
result = throw_exception( c_string_to_lisp_symbol( L"*" ),
|
||||
make_cons( c_string_to_lisp_string
|
||||
( L"Cannot multiply: argument 1 is not a number" ),
|
||||
c_type( arg1 ) ),
|
||||
frame_pointer );
|
||||
|
|
@ -620,7 +628,8 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
|
|||
to_long_double( arg2 ) );
|
||||
break;
|
||||
default:
|
||||
result = throw_exception( c_string_to_lisp_string
|
||||
result = throw_exception( c_string_to_lisp_symbol( L"-" ),
|
||||
c_string_to_lisp_string
|
||||
( L"Cannot subtract: not a number" ),
|
||||
frame_pointer );
|
||||
break;
|
||||
|
|
@ -650,7 +659,8 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
|
|||
to_long_double( arg2 ) );
|
||||
break;
|
||||
default:
|
||||
result = throw_exception( c_string_to_lisp_string
|
||||
result = throw_exception( c_string_to_lisp_symbol( L"-" ),
|
||||
c_string_to_lisp_string
|
||||
( L"Cannot subtract: not a number" ),
|
||||
frame_pointer );
|
||||
break;
|
||||
|
|
@ -661,7 +671,8 @@ 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_string
|
||||
result = throw_exception( c_string_to_lisp_symbol( L"-" ),
|
||||
c_string_to_lisp_string
|
||||
( L"Cannot subtract: not a number" ),
|
||||
frame_pointer );
|
||||
break;
|
||||
|
|
@ -732,7 +743,8 @@ struct cons_pointer lisp_divide( struct
|
|||
to_long_double( frame->arg[1] ) );
|
||||
break;
|
||||
default:
|
||||
result = throw_exception( c_string_to_lisp_string
|
||||
result = throw_exception( c_string_to_lisp_symbol( L"/" ),
|
||||
c_string_to_lisp_string
|
||||
( L"Cannot divide: not a number" ),
|
||||
frame_pointer );
|
||||
break;
|
||||
|
|
@ -762,7 +774,8 @@ struct cons_pointer lisp_divide( struct
|
|||
to_long_double( frame->arg[1] ) );
|
||||
break;
|
||||
default:
|
||||
result = throw_exception( c_string_to_lisp_string
|
||||
result = throw_exception( c_string_to_lisp_symbol( L"/" ),
|
||||
c_string_to_lisp_string
|
||||
( L"Cannot divide: not a number" ),
|
||||
frame_pointer );
|
||||
break;
|
||||
|
|
@ -774,7 +787,8 @@ struct cons_pointer lisp_divide( struct
|
|||
to_long_double( frame->arg[1] ) );
|
||||
break;
|
||||
default:
|
||||
result = throw_exception( c_string_to_lisp_string
|
||||
result = throw_exception( c_string_to_lisp_symbol( L"/" ),
|
||||
c_string_to_lisp_string
|
||||
( L"Cannot divide: not a number" ),
|
||||
frame_pointer );
|
||||
break;
|
||||
|
|
|
|||
|
|
@ -114,7 +114,8 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer arg1,
|
|||
cell1->payload.ratio.divisor ) );
|
||||
r = make_ratio( dividend, divisor, true );
|
||||
} else {
|
||||
r = throw_exception( make_cons( c_string_to_lisp_string
|
||||
r = throw_exception( c_string_to_lisp_symbol( L"+" ),
|
||||
make_cons( c_string_to_lisp_string
|
||||
( L"Shouldn't happen: bad arg to add_ratio_ratio" ),
|
||||
make_cons( arg1,
|
||||
make_cons( arg2, NIL ) ) ),
|
||||
|
|
@ -154,7 +155,8 @@ struct cons_pointer add_integer_ratio( struct cons_pointer intarg,
|
|||
dec_ref( ratio );
|
||||
} else {
|
||||
result =
|
||||
throw_exception( make_cons( c_string_to_lisp_string
|
||||
throw_exception( c_string_to_lisp_symbol( L"+" ),
|
||||
make_cons( c_string_to_lisp_string
|
||||
( L"Shouldn't happen: bad arg to add_integer_ratio" ),
|
||||
make_cons( intarg,
|
||||
make_cons( ratarg,
|
||||
|
|
@ -234,7 +236,8 @@ struct cons_pointer multiply_ratio_ratio( struct
|
|||
release_integer( divisor );
|
||||
} else {
|
||||
result =
|
||||
throw_exception( c_string_to_lisp_string
|
||||
throw_exception( c_string_to_lisp_symbol( L"*" ),
|
||||
c_string_to_lisp_string
|
||||
( L"Shouldn't happen: bad arg to multiply_ratio_ratio" ),
|
||||
NIL );
|
||||
}
|
||||
|
|
@ -269,7 +272,8 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg,
|
|||
release_integer( one );
|
||||
} else {
|
||||
result =
|
||||
throw_exception( c_string_to_lisp_string
|
||||
throw_exception( c_string_to_lisp_symbol( L"*" ),
|
||||
c_string_to_lisp_string
|
||||
( L"Shouldn't happen: bad arg to multiply_integer_ratio" ),
|
||||
NIL );
|
||||
}
|
||||
|
|
@ -337,7 +341,8 @@ struct cons_pointer make_ratio( struct cons_pointer dividend,
|
|||
}
|
||||
} else {
|
||||
result =
|
||||
throw_exception( c_string_to_lisp_string
|
||||
throw_exception( c_string_to_lisp_symbol( L"make_ratio" ),
|
||||
c_string_to_lisp_string
|
||||
( L"Dividend and divisor of a ratio must be integers" ),
|
||||
NIL );
|
||||
}
|
||||
|
|
|
|||
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 );
|
||||
|
|
|
|||
20
src/init.c
20
src/init.c
|
|
@ -84,12 +84,18 @@ 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( ) {
|
||||
|
|
@ -287,6 +293,8 @@ 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
|
||||
|
|
@ -317,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 ),
|
||||
|
|
@ -401,10 +409,14 @@ 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.",
|
||||
|
|
|
|||
|
|
@ -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 );
|
||||
|
|
@ -348,16 +348,9 @@ 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 );
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -167,7 +167,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
|
|||
|
||||
if ( url_feof( input ) ) {
|
||||
result =
|
||||
throw_exception( c_string_to_lisp_string
|
||||
throw_exception( c_string_to_lisp_symbol( L"read" ),
|
||||
c_string_to_lisp_string
|
||||
( L"End of file while reading" ), frame_pointer );
|
||||
} else {
|
||||
switch ( c ) {
|
||||
|
|
@ -177,7 +178,8 @@ 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_string
|
||||
result = throw_exception( c_string_to_lisp_symbol( L"read" ),
|
||||
c_string_to_lisp_string
|
||||
( L"End of input while reading" ),
|
||||
frame_pointer );
|
||||
break;
|
||||
|
|
@ -266,7 +268,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
|
|||
result = read_symbol_or_key( input, SYMBOLTV, c );
|
||||
} else {
|
||||
result =
|
||||
throw_exception( make_cons( c_string_to_lisp_string
|
||||
throw_exception( c_string_to_lisp_symbol( L"read" ),
|
||||
make_cons( c_string_to_lisp_string
|
||||
( L"Unrecognised start of input character" ),
|
||||
make_string( c, NIL ) ),
|
||||
frame_pointer );
|
||||
|
|
@ -313,7 +316,8 @@ 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_string
|
||||
return throw_exception( c_string_to_lisp_symbol( L"read" ),
|
||||
c_string_to_lisp_string
|
||||
( L"Malformed number: too many periods" ),
|
||||
frame_pointer );
|
||||
} else {
|
||||
|
|
@ -324,7 +328,8 @@ struct cons_pointer read_number( struct stack_frame *frame,
|
|||
break;
|
||||
case LSLASH:
|
||||
if ( seen_period || !nilp( dividend ) ) {
|
||||
return throw_exception( c_string_to_lisp_string
|
||||
return throw_exception( c_string_to_lisp_symbol( L"read" ),
|
||||
c_string_to_lisp_string
|
||||
( L"Malformed number: dividend of rational must be integer" ),
|
||||
frame_pointer );
|
||||
} else {
|
||||
|
|
|
|||
|
|
@ -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!" );
|
||||
}
|
||||
|
|
|
|||
|
|
@ -27,6 +27,18 @@
|
|||
#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
|
||||
|
|
@ -35,11 +47,11 @@
|
|||
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 ) {
|
||||
|
|
@ -66,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 ) {
|
||||
|
|
@ -119,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.
|
||||
|
|
@ -387,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 = internedp( 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
|
||||
|
|
|
|||
|
|
@ -56,6 +56,18 @@
|
|||
*/
|
||||
#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.
|
||||
|
|
@ -710,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 );
|
||||
|
|
|
|||
|
|
@ -161,6 +161,10 @@ 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 );
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
|
@ -375,8 +377,7 @@ 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 );
|
||||
|
|
|
|||
273
src/ops/intern.c
273
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,57 +283,146 @@ 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)
|
||||
|
||||
/**
|
||||
* 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.
|
||||
* @brief `(search-store key store return-key?)` Search this `store` for this
|
||||
* a key lexically identical to this `key`.
|
||||
*
|
||||
* 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.
|
||||
* 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
|
||||
internedp( 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;
|
||||
|
||||
#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 ) ) {
|
||||
// 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 );
|
||||
struct cons_space_object *store_cell = &pointer2cell( store );
|
||||
|
||||
// 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( 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 );
|
||||
|
||||
// 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;
|
||||
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;
|
||||
}
|
||||
} else {
|
||||
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 );
|
||||
// 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"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
|
||||
|
|
@ -328,65 +433,7 @@ internedp( struct cons_pointer key, struct cons_pointer store ) {
|
|||
*/
|
||||
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_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;
|
||||
return search_store( key, store, false );
|
||||
}
|
||||
|
||||
/**
|
||||
|
|
@ -414,19 +461,23 @@ 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;
|
||||
}
|
||||
|
||||
/**
|
||||
* Return a new key/value store containing all the key/value pairs in this
|
||||
* store with this key/value pair added to the front.
|
||||
*/
|
||||
/**
|
||||
* 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.
|
||||
*/
|
||||
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 = vectorpointp( store );
|
||||
bool deep = eq( store, oblist );
|
||||
debug_print_binding( key, value, deep, DEBUG_BIND );
|
||||
|
||||
if ( deep ) {
|
||||
|
|
@ -434,9 +485,7 @@ struct cons_pointer set( struct cons_pointer key, struct cons_pointer value,
|
|||
pointer2cell( store ).payload.vectorp.tag.bytes );
|
||||
}
|
||||
#endif
|
||||
if ( nilp( value ) ) {
|
||||
result = store;
|
||||
} else if ( nilp( store ) || consp( store ) ) {
|
||||
if ( nilp( store ) || consp( store ) ) {
|
||||
result = make_cons( make_cons( key, value ), store );
|
||||
} else if ( hashmapp( store ) ) {
|
||||
result = hashmap_put( store, key, value );
|
||||
|
|
@ -452,16 +501,8 @@ 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 );
|
||||
|
|
@ -480,7 +521,7 @@ intern( struct cons_pointer key, struct cons_pointer environment ) {
|
|||
struct cons_pointer canonical = internedp( key, environment );
|
||||
if ( nilp( canonical ) ) {
|
||||
/*
|
||||
* not currently bound
|
||||
* not currently bound. TODO: this should bind to NIL?
|
||||
*/
|
||||
result = set( key, TRUE, environment );
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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,15 +49,18 @@ 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 );
|
||||
|
|
|
|||
|
|
@ -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,6 +328,56 @@ 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.
|
||||
|
|
@ -348,10 +398,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 ( fn_cell.tag.value ) {
|
||||
switch ( get_tag_value( fn_pointer ) ) {
|
||||
case EXCEPTIONTV:
|
||||
/* just pass exceptions straight back */
|
||||
result = fn_pointer;
|
||||
|
|
@ -369,10 +419,15 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
|||
struct stack_frame *next =
|
||||
get_stack_frame( next_pointer );
|
||||
|
||||
result =
|
||||
( *fn_cell.payload.function.executable ) ( next,
|
||||
next_pointer,
|
||||
env );
|
||||
result = maybe_fixup_exception_location( ( *
|
||||
( fn_cell->
|
||||
payload.
|
||||
function.
|
||||
executable ) )
|
||||
( next,
|
||||
next_pointer,
|
||||
env ),
|
||||
fn_pointer );
|
||||
dec_ref( next_pointer );
|
||||
}
|
||||
}
|
||||
|
|
@ -406,18 +461,14 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
|||
}
|
||||
break;
|
||||
|
||||
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;
|
||||
}
|
||||
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;
|
||||
|
||||
case NLAMBDATV:
|
||||
|
|
@ -441,15 +492,16 @@ 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 =
|
||||
( *fn_cell.payload.
|
||||
special.executable ) ( get_stack_frame
|
||||
( next_pointer ),
|
||||
next_pointer, env );
|
||||
result = maybe_fixup_exception_location( ( *
|
||||
( 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 );
|
||||
debug_println( DEBUG_EVAL );
|
||||
|
|
@ -465,13 +517,16 @@ 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( message, frame_pointer );
|
||||
result =
|
||||
throw_exception( c_string_to_lisp_symbol( L"apply" ),
|
||||
message, frame_pointer );
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
debug_print( L"c_apply: returning: ", DEBUG_EVAL );
|
||||
|
|
@ -508,23 +563,24 @@ 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 =
|
||||
internedp( frame->arg[0], env );
|
||||
struct cons_pointer canonical = interned( 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( message, frame_pointer );
|
||||
result =
|
||||
throw_exception( c_string_to_lisp_symbol( L"eval" ),
|
||||
message, frame_pointer );
|
||||
} else {
|
||||
result = c_assoc( canonical, env );
|
||||
inc_ref( result );
|
||||
|
|
@ -625,7 +681,8 @@ lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
|||
result = frame->arg[1];
|
||||
} else {
|
||||
result =
|
||||
throw_exception( make_cons
|
||||
throw_exception( c_string_to_lisp_symbol( L"set" ),
|
||||
make_cons
|
||||
( c_string_to_lisp_string
|
||||
( L"The first argument to `set` is not a symbol: " ),
|
||||
make_cons( frame->arg[0], NIL ) ),
|
||||
|
|
@ -664,7 +721,8 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
|||
result = val;
|
||||
} else {
|
||||
result =
|
||||
throw_exception( make_cons
|
||||
throw_exception( c_string_to_lisp_symbol( L"set!" ),
|
||||
make_cons
|
||||
( c_string_to_lisp_string
|
||||
( L"The first argument to `set!` is not a symbol: " ),
|
||||
make_cons( frame->arg[0], NIL ) ),
|
||||
|
|
@ -736,24 +794,25 @@ 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_string
|
||||
throw_exception( c_string_to_lisp_symbol( L"car" ),
|
||||
c_string_to_lisp_string
|
||||
( L"Attempt to take CAR of non sequence" ),
|
||||
frame_pointer );
|
||||
}
|
||||
|
|
@ -780,24 +839,25 @@ 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_string
|
||||
throw_exception( c_string_to_lisp_symbol( L"cdr" ),
|
||||
c_string_to_lisp_string
|
||||
( L"Attempt to take CDR of non sequence" ),
|
||||
frame_pointer );
|
||||
}
|
||||
|
|
@ -835,7 +895,35 @@ 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], frame->arg[1] );
|
||||
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;
|
||||
}
|
||||
|
||||
struct cons_pointer c_keys( struct cons_pointer store ) {
|
||||
|
|
@ -970,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 );
|
||||
}
|
||||
|
||||
|
|
@ -1188,7 +1280,8 @@ struct cons_pointer eval_cond_clause( struct cons_pointer clause,
|
|||
#endif
|
||||
}
|
||||
} else {
|
||||
result = throw_exception( c_string_to_lisp_string
|
||||
result = throw_exception( c_string_to_lisp_symbol( L"cond" ),
|
||||
c_string_to_lisp_string
|
||||
( L"Arguments to `cond` must be lists" ),
|
||||
frame_pointer );
|
||||
}
|
||||
|
|
@ -1246,18 +1339,32 @@ 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 message,
|
||||
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;
|
||||
|
||||
struct cons_space_object cell = pointer2cell( message );
|
||||
#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
|
||||
|
||||
if ( cell.tag.value == EXCEPTIONTV ) {
|
||||
struct cons_space_object *cell = &pointer2cell( message );
|
||||
|
||||
if ( cell->tag.value == EXCEPTIONTV ) {
|
||||
result = message;
|
||||
} else {
|
||||
result = make_exception( message, frame_pointer );
|
||||
result =
|
||||
make_exception( make_cons
|
||||
( make_cons( privileged_keyword_location,
|
||||
location ),
|
||||
make_cons( make_cons
|
||||
( privileged_keyword_payload,
|
||||
message ), NIL ) ), frame_pointer );
|
||||
}
|
||||
|
||||
return result;
|
||||
|
|
@ -1270,7 +1377,7 @@ throw_exception( struct cons_pointer message,
|
|||
* normally return. A function which detects a problem it cannot resolve
|
||||
* *should* return an exception.
|
||||
*
|
||||
* * (exception message frame)
|
||||
* * (exception message location)
|
||||
*
|
||||
* @param frame my stack frame.
|
||||
* @param frame_pointer a pointer to my stack_frame.
|
||||
|
|
@ -1285,9 +1392,10 @@ 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->
|
||||
previous );
|
||||
frame->arg[1],
|
||||
frame->previous );
|
||||
}
|
||||
|
||||
/**
|
||||
|
|
@ -1307,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 );
|
||||
|
|
@ -1322,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];
|
||||
|
|
@ -1332,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)))
|
||||
|
|
@ -1350,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;
|
||||
|
||||
|
|
@ -1394,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 );
|
||||
|
|
@ -1420,24 +1546,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!
|
||||
|
|
@ -1460,7 +1586,8 @@ 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_string
|
||||
throw_exception( c_string_to_lisp_symbol( L"append" ),
|
||||
c_string_to_lisp_string
|
||||
( L"Can't append: not same type" ), NIL );
|
||||
}
|
||||
break;
|
||||
|
|
@ -1470,24 +1597,25 @@ 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_string
|
||||
throw_exception( c_string_to_lisp_symbol( L"append" ),
|
||||
c_string_to_lisp_string
|
||||
( L"Can't append: not same type" ), NIL );
|
||||
}
|
||||
break;
|
||||
default:
|
||||
throw_exception( c_string_to_lisp_string
|
||||
throw_exception( c_string_to_lisp_symbol( L"append" ),
|
||||
c_string_to_lisp_string
|
||||
( L"Can't append: not a sequence" ), NIL );
|
||||
break;
|
||||
}
|
||||
|
|
@ -1599,7 +1727,8 @@ 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_string
|
||||
throw_exception( c_string_to_lisp_symbol( L"let" ),
|
||||
c_string_to_lisp_string
|
||||
( L"Let: cannot bind, not a symbol" ),
|
||||
frame_pointer );
|
||||
break;
|
||||
|
|
|
|||
|
|
@ -131,6 +131,9 @@ 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 );
|
||||
|
|
@ -193,7 +196,8 @@ 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 message,
|
||||
struct cons_pointer throw_exception( struct cons_pointer location,
|
||||
struct cons_pointer message,
|
||||
struct cons_pointer frame_pointer );
|
||||
|
||||
struct cons_pointer lisp_exception( struct stack_frame *frame,
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue