simon/post-scarcity
1
0
Fork 0
Code Issues 14 Pull requests Projects Releases Packages Wiki Activity Actions

Compare commits

base: simon:72a8bc09e049b99c0514189272897fba9d985a7b
Branches Tags
simon:master
simon:develop
simon:intern-rewrite
simon:feature-2
simon:feature/all-integers-are-bignums
simon:release/0.0.6
simon:release_0.0.5
..
compare: simon:145a0fe5a747a23ab8853dff904fe83e00ad3799
Branches Tags
simon:develop
simon:master
simon:intern-rewrite
simon:feature-2
simon:feature/all-integers-are-bignums
simon:release/0.0.6
simon:release_0.0.5

No commits in common. "72a8bc09e049b99c0514189272897fba9d985a7b" and "145a0fe5a747a23ab8853dff904fe83e00ad3799" have entirely different histories.
72a8bc09e0 ... 145a0fe5a7

20 changed files with 291 additions and 589 deletions
Download patch file Download diff file Expand all files Collapse all files

44
docs/Interning-strings.md
View file

@ -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. 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: 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; 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; 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 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. Obviously this means there may be arbitrarily many paths which reference the same data item. This is intended.
## Related functions ## 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) ### (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) ### (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. 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) ### (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. 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) ### (string-to-path string)
Behaviour as follows: Behaviour as follows:
(string-to-path ":foo:bar/ban") => (-> (environment) :foo :bar 'ban) (string-to-path "foo.bar.ban") => ("foo" "bar" "ban")
(string-to-path "::foo:bar/ban") => (-> (oblist) :foo :bar 'ban) (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) ### (path-to-string list-of-strings)
Behaviour as follows: 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. Obviously if the current user can't read some element of *list-of-strings*, throws an exception.

29
lisp/documentation.lisp
View file

@ -3,31 +3,6 @@
;; `nth` (from `nth.lisp`) ;; `nth` (from `nth.lisp`)
;; `string?` (from `types.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) (set! documentation (lambda (object)
"`(documentation object)`: Return documentation for the specified `object`, if available, else `nil`." "`(documentation object)`: Return documentation for the specified `object`, if available, else `nil`."
(cond ((member? (type object) '("FUNC" "SPFM")) (cond ((member? (type object) '("FUNC" "SPFM"))
@ -40,7 +15,3 @@
(set! doc documentation) (set! doc documentation)
(documentation apply)
;; (documentation member?)

46
src/arith/peano.c
View file

@ -296,11 +296,9 @@ struct cons_pointer add_2( struct stack_frame *frame,
to_long_double( arg2 ) ); to_long_double( arg2 ) );
break; break;
default: default:
result = result = throw_exception( c_string_to_lisp_string
throw_exception( c_string_to_lisp_symbol( L"+" ), ( L"Cannot add: not a number" ),
c_string_to_lisp_string frame_pointer );
( L"Cannot add: not a number" ),
frame_pointer );
break; break;
} }
break; break;
@ -321,11 +319,9 @@ struct cons_pointer add_2( struct stack_frame *frame,
to_long_double( arg2 ) ); to_long_double( arg2 ) );
break; break;
default: default:
result = result = throw_exception( c_string_to_lisp_string
throw_exception( c_string_to_lisp_symbol( L"+" ), ( L"Cannot add: not a number" ),
c_string_to_lisp_string frame_pointer );
( L"Cannot add: not a number" ),
frame_pointer );
break; break;
} }
break; break;
@ -336,8 +332,7 @@ struct cons_pointer add_2( struct stack_frame *frame,
break; break;
default: default:
result = exceptionp( arg2 ) ? arg2 : result = exceptionp( arg2 ) ? arg2 :
throw_exception( c_string_to_lisp_symbol( L"+" ), throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Cannot add: not a number" ), ( L"Cannot add: not a number" ),
frame_pointer ); frame_pointer );
} }
@ -433,8 +428,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
break; break;
default: default:
result = result =
throw_exception( c_string_to_lisp_symbol( L"*" ), throw_exception( make_cons
make_cons
( c_string_to_lisp_string ( c_string_to_lisp_string
( L"Cannot multiply: argument 2 is not a number: " ), ( L"Cannot multiply: argument 2 is not a number: " ),
c_type( arg2 ) ), c_type( arg2 ) ),
@ -460,8 +454,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
break; break;
default: default:
result = result =
throw_exception( c_string_to_lisp_symbol( L"*" ), throw_exception( make_cons
make_cons
( c_string_to_lisp_string ( c_string_to_lisp_string
( L"Cannot multiply: argument 2 is not a number" ), ( L"Cannot multiply: argument 2 is not a number" ),
c_type( arg2 ) ), c_type( arg2 ) ),
@ -474,8 +467,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
to_long_double( arg2 ) ); to_long_double( arg2 ) );
break; break;
default: default:
result = throw_exception( c_string_to_lisp_symbol( L"*" ), result = throw_exception( make_cons( c_string_to_lisp_string
make_cons( c_string_to_lisp_string
( L"Cannot multiply: argument 1 is not a number" ), ( L"Cannot multiply: argument 1 is not a number" ),
c_type( arg1 ) ), c_type( arg1 ) ),
frame_pointer ); frame_pointer );
@ -628,8 +620,7 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
to_long_double( arg2 ) ); to_long_double( arg2 ) );
break; break;
default: default:
result = throw_exception( c_string_to_lisp_symbol( L"-" ), result = throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Cannot subtract: not a number" ), ( L"Cannot subtract: not a number" ),
frame_pointer ); frame_pointer );
break; break;
@ -659,8 +650,7 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
to_long_double( arg2 ) ); to_long_double( arg2 ) );
break; break;
default: default:
result = throw_exception( c_string_to_lisp_symbol( L"-" ), result = throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Cannot subtract: not a number" ), ( L"Cannot subtract: not a number" ),
frame_pointer ); frame_pointer );
break; break;
@ -671,8 +661,7 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
make_real( to_long_double( arg1 ) - to_long_double( arg2 ) ); make_real( to_long_double( arg1 ) - to_long_double( arg2 ) );
break; break;
default: default:
result = throw_exception( c_string_to_lisp_symbol( L"-" ), result = throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Cannot subtract: not a number" ), ( L"Cannot subtract: not a number" ),
frame_pointer ); frame_pointer );
break; break;
@ -743,8 +732,7 @@ struct cons_pointer lisp_divide( struct
to_long_double( frame->arg[1] ) ); to_long_double( frame->arg[1] ) );
break; break;
default: default:
result = throw_exception( c_string_to_lisp_symbol( L"/" ), result = throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Cannot divide: not a number" ), ( L"Cannot divide: not a number" ),
frame_pointer ); frame_pointer );
break; break;
@ -774,8 +762,7 @@ struct cons_pointer lisp_divide( struct
to_long_double( frame->arg[1] ) ); to_long_double( frame->arg[1] ) );
break; break;
default: default:
result = throw_exception( c_string_to_lisp_symbol( L"/" ), result = throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Cannot divide: not a number" ), ( L"Cannot divide: not a number" ),
frame_pointer ); frame_pointer );
break; break;
@ -787,8 +774,7 @@ struct cons_pointer lisp_divide( struct
to_long_double( frame->arg[1] ) ); to_long_double( frame->arg[1] ) );
break; break;
default: default:
result = throw_exception( c_string_to_lisp_symbol( L"/" ), result = throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Cannot divide: not a number" ), ( L"Cannot divide: not a number" ),
frame_pointer ); frame_pointer );
break; break;

15
src/arith/ratio.c
View file

@ -114,8 +114,7 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer arg1,
cell1->payload.ratio.divisor ) ); cell1->payload.ratio.divisor ) );
r = make_ratio( dividend, divisor, true ); r = make_ratio( dividend, divisor, true );
} else { } else {
r = throw_exception( c_string_to_lisp_symbol( L"+" ), r = throw_exception( make_cons( c_string_to_lisp_string
make_cons( c_string_to_lisp_string
( L"Shouldn't happen: bad arg to add_ratio_ratio" ), ( L"Shouldn't happen: bad arg to add_ratio_ratio" ),
make_cons( arg1, make_cons( arg1,
make_cons( arg2, NIL ) ) ), make_cons( arg2, NIL ) ) ),
@ -155,8 +154,7 @@ struct cons_pointer add_integer_ratio( struct cons_pointer intarg,
dec_ref( ratio ); dec_ref( ratio );
} else { } else {
result = result =
throw_exception( c_string_to_lisp_symbol( L"+" ), throw_exception( make_cons( c_string_to_lisp_string
make_cons( c_string_to_lisp_string
( L"Shouldn't happen: bad arg to add_integer_ratio" ), ( L"Shouldn't happen: bad arg to add_integer_ratio" ),
make_cons( intarg, make_cons( intarg,
make_cons( ratarg, make_cons( ratarg,
@ -236,8 +234,7 @@ struct cons_pointer multiply_ratio_ratio( struct
release_integer( divisor ); release_integer( divisor );
} else { } else {
result = result =
throw_exception( c_string_to_lisp_symbol( L"*" ), throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Shouldn't happen: bad arg to multiply_ratio_ratio" ), ( L"Shouldn't happen: bad arg to multiply_ratio_ratio" ),
NIL ); NIL );
} }
@ -272,8 +269,7 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg,
release_integer( one ); release_integer( one );
} else { } else {
result = result =
throw_exception( c_string_to_lisp_symbol( L"*" ), throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Shouldn't happen: bad arg to multiply_integer_ratio" ), ( L"Shouldn't happen: bad arg to multiply_integer_ratio" ),
NIL ); NIL );
} }
@ -341,8 +337,7 @@ struct cons_pointer make_ratio( struct cons_pointer dividend,
} }
} else { } else {
result = result =
throw_exception( c_string_to_lisp_symbol( L"make_ratio" ), throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Dividend and divisor of a ratio must be integers" ), ( L"Dividend and divisor of a ratio must be integers" ),
NIL ); NIL );
} }

19
src/debug.c
View file

@ -32,25 +32,6 @@
*/ */
int verbosity = 0; 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`. * @brief print this debug `message` to stderr, if `verbosity` matches `level`.
* *

1
src/debug.h
View file

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

20
src/init.c
View file

@ -84,18 +84,12 @@ void maybe_bind_init_symbols( ) {
if ( nilp( privileged_symbol_nil ) ) { if ( nilp( privileged_symbol_nil ) ) {
privileged_symbol_nil = c_string_to_lisp_symbol( L"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 ) ) { 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 = privileged_string_memory_exhausted =
c_string_to_lisp_string( L"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( ) { void free_init_symbols( ) {
@ -293,8 +287,6 @@ int main( int argc, char *argv[] ) {
*/ */
bind_symbol_value( privileged_symbol_nil, NIL, true ); bind_symbol_value( privileged_symbol_nil, NIL, true );
bind_value( L"t", TRUE, 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 * standard input, output, error and sink streams
@ -325,7 +317,7 @@ int main( int argc, char *argv[] ) {
( c_string_to_lisp_keyword ( c_string_to_lisp_keyword
( L"url" ), ( L"url" ),
c_string_to_lisp_string c_string_to_lisp_string
( L"system:standard output" ) ), ( L"system:standard output]" ) ),
NIL ) ), false ); NIL ) ), false );
bind_value( L"*log*", bind_value( L"*log*",
make_write_stream( file_to_url_file( stderr ), make_write_stream( file_to_url_file( stderr ),
@ -409,14 +401,10 @@ int main( int argc, char *argv[] ) {
bind_function( L"inspect", bind_function( L"inspect",
L"`(inspect object ouput-stream)`: Print details of this `object` to this `output-stream` or `*out*`.", L"`(inspect object ouput-stream)`: Print details of this `object` to this `output-stream` or `*out*`.",
&lisp_inspect ); &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", bind_function( L"keys",
L"`(keys store)`: Return a list of all keys in this `store`.", L"`(keys store)`: Return a list of all keys in this `store`.",
&lisp_keys ); &lisp_keys );
bind_function( L"list", bind_function( L"list", L"`(list args...): Return a list of these `args`.",
L"`(list args...)`: Return a list of these `args`.",
&lisp_list ); &lisp_list );
bind_function( L"mapcar", bind_function( L"mapcar",
L"`(mapcar function sequence)`: Apply `function` to each element of `sequence` in turn, and return a sequence of the results.", L"`(mapcar function sequence)`: Apply `function` to each element of `sequence` in turn, and return a sequence of the results.",

4
src/io/io.c
View file

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

11
src/io/print.c
View file

@ -101,7 +101,7 @@ void print_map( URL_FILE *output, struct cons_pointer map ) {
struct cons_pointer key = c_car( ks ); struct cons_pointer key = c_car( ks );
print( output, key ); print( output, key );
url_fputwc( btowc( ' ' ), output ); url_fputwc( btowc( ' ' ), output );
print( output, hashmap_get( map, key, false ) ); print( output, hashmap_get( map, key ) );
if ( !nilp( c_cdr( ks ) ) ) { if ( !nilp( c_cdr( ks ) ) ) {
url_fputws( L", ", output ); url_fputws( L", ", output );
@ -348,9 +348,16 @@ lisp_println( struct stack_frame *frame, struct cons_pointer frame_pointer,
if ( writep( out_stream ) ) { if ( writep( out_stream ) ) {
output = pointer2cell( out_stream ).payload.stream.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 ); free( output );
} }

15
src/io/read.c
View file

@ -167,8 +167,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
if ( url_feof( input ) ) { if ( url_feof( input ) ) {
result = result =
throw_exception( c_string_to_lisp_symbol( L"read" ), throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"End of file while reading" ), frame_pointer ); ( L"End of file while reading" ), frame_pointer );
} else { } else {
switch ( c ) { 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 */ /* skip all characters from semi-colon to the end of the line */
break; break;
case EOF: case EOF:
result = throw_exception( c_string_to_lisp_symbol( L"read" ), result = throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"End of input while reading" ), ( L"End of input while reading" ),
frame_pointer ); frame_pointer );
break; break;
@ -268,8 +266,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
result = read_symbol_or_key( input, SYMBOLTV, c ); result = read_symbol_or_key( input, SYMBOLTV, c );
} else { } else {
result = result =
throw_exception( c_string_to_lisp_symbol( L"read" ), throw_exception( make_cons( c_string_to_lisp_string
make_cons( c_string_to_lisp_string
( L"Unrecognised start of input character" ), ( L"Unrecognised start of input character" ),
make_string( c, NIL ) ), make_string( c, NIL ) ),
frame_pointer ); frame_pointer );
@ -316,8 +313,7 @@ struct cons_pointer read_number( struct stack_frame *frame,
switch ( c ) { switch ( c ) {
case LPERIOD: case LPERIOD:
if ( seen_period || !nilp( dividend ) ) { if ( seen_period || !nilp( dividend ) ) {
return throw_exception( c_string_to_lisp_symbol( L"read" ), return throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Malformed number: too many periods" ), ( L"Malformed number: too many periods" ),
frame_pointer ); frame_pointer );
} else { } else {
@ -328,8 +324,7 @@ struct cons_pointer read_number( struct stack_frame *frame,
break; break;
case LSLASH: case LSLASH:
if ( seen_period || !nilp( dividend ) ) { if ( seen_period || !nilp( dividend ) ) {
return throw_exception( c_string_to_lisp_symbol( L"read" ), return throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Malformed number: dividend of rational must be integer" ), ( L"Malformed number: dividend of rational must be integer" ),
frame_pointer ); frame_pointer );
} else { } else {

5
src/memory/conspage.c
View file

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

49
src/memory/consspaceobject.c
View file

@ -27,18 +27,6 @@
#include "memory/vectorspace.h" #include "memory/vectorspace.h"
#include "ops/intern.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`, * 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 * 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 check_tag( struct cons_pointer pointer, uint32_t value ) {
bool result = false; bool result = false;
struct cons_space_object *cell = &pointer2cell( pointer ); struct cons_space_object cell = pointer2cell( pointer );
result = cell->tag.value == value; result = cell.tag.value == value;
if ( result == false ) { if ( result == false ) {
if ( cell->tag.value == VECTORPOINTTV ) { if ( cell.tag.value == VECTORPOINTTV ) {
struct vector_space_object *vec = pointer_to_vso( pointer ); struct vector_space_object *vec = pointer_to_vso( pointer );
if ( vec != NULL ) { if ( vec != NULL ) {
@ -78,7 +66,7 @@ struct cons_pointer inc_ref( struct cons_pointer pointer ) {
cell->count++; cell->count++;
#ifdef DEBUG #ifdef DEBUG
debug_printf( DEBUG_ALLOC, 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, ( ( char * ) cell->tag.bytes ), pointer.page,
pointer.offset, cell->count ); pointer.offset, cell->count );
if ( strncmp( cell->tag.bytes, VECTORPOINTTAG, TAGLENGTH ) == 0 ) { if ( strncmp( cell->tag.bytes, VECTORPOINTTAG, TAGLENGTH ) == 0 ) {
@ -131,19 +119,6 @@ struct cons_pointer dec_ref( struct cons_pointer pointer ) {
return 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. * Get the Lisp type of the single argument.
* @param pointer a pointer to the object whose type is requested. * @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 ) { if ( tag == SYMBOLTV || tag == KEYTV ) {
result = make_string_like_thing( c, tail, tag ); result = make_string_like_thing( c, tail, tag );
// if ( tag == KEYTV ) { if ( tag == KEYTV ) {
// struct cons_pointer r = interned( result, oblist ); struct cons_pointer r = internedp( result, oblist );
// if ( nilp( r ) ) { if ( nilp( r ) ) {
// intern( result, oblist ); intern( result, oblist );
// } else { } else {
// result = r; result = r;
// } }
// } }
} else { } else {
result = result =
make_exception( c_string_to_lisp_string make_exception( c_string_to_lisp_string

17
src/memory/consspaceobject.h
View file

@ -56,18 +56,6 @@
*/ */
#define EXCEPTIONTV 1346721861 #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 * An unallocated cell on the free list - should never be encountered by a Lisp
* function. * function.
@ -722,11 +710,6 @@ struct cons_pointer inc_ref( struct cons_pointer pointer );
struct cons_pointer dec_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_type( struct cons_pointer pointer );
struct cons_pointer c_car( struct cons_pointer arg ); struct cons_pointer c_car( struct cons_pointer arg );

8
src/memory/dump.c
View file

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

4
src/memory/stack.c
View file

@ -161,10 +161,6 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
env ); env );
frame->more = more; frame->more = more;
inc_ref( more ); inc_ref( more );
for ( ; !nilp( args ); args = c_cdr( args ) ) {
frame->args++;
}
} }
} }
debug_print( L"make_stack_frame: returning\n", DEBUG_STACK ); debug_print( L"make_stack_frame: returning\n", DEBUG_STACK );

7
src/ops/equal.c
View file

@ -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 ) ) { for ( struct cons_pointer i = keys_a; !nilp( i ); i = c_cdr( i ) ) {
struct cons_pointer key = c_car( i ); struct cons_pointer key = c_car( i );
if ( !equal if ( !equal( hashmap_get( a, key ), hashmap_get( b, key ) ) ) {
( hashmap_get( a, key, false ),
hashmap_get( b, key, false ) ) ) {
result = false; result = false;
break; break;
} }
@ -377,7 +375,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
memset( a_buff, 0, sizeof( a_buff ) ); memset( a_buff, 0, sizeof( a_buff ) );
memset( b_buff, 0, sizeof( b_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++ ) { && !nilp( b ); i++ ) {
a_buff[i] = cell_a->payload.string.character; a_buff[i] = cell_a->payload.string.character;
a = c_cdr( a ); a = c_cdr( a );

273
src/ops/intern.c
View file

@ -205,7 +205,7 @@ struct cons_pointer hashmap_put_all( struct cons_pointer mapp,
for ( struct cons_pointer keys = hashmap_keys( assoc ); for ( struct cons_pointer keys = hashmap_keys( assoc );
!nilp( keys ); keys = c_cdr( keys ) ) { !nilp( keys ); keys = c_cdr( keys ) ) {
struct cons_pointer key = c_car( 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. /** Get a value from a hashmap.
* *
* Note that this is here, rather than in memory/hashmap.c, because it is * 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 hashmap_get( struct cons_pointer mapp,
struct cons_pointer key, bool return_key ) { struct cons_pointer 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; struct cons_pointer result = NIL;
if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) ) && !nilp( key ) ) { if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) ) && !nilp( key ) ) {
struct vector_space_object *map = pointer_to_vso( mapp ); struct vector_space_object *map = pointer_to_vso( mapp );
uint32_t bucket_no = get_hash( key ) % map->payload.hashmap.n_buckets; uint32_t bucket_no = get_hash( key ) % map->payload.hashmap.n_buckets;
result = result = c_assoc( key, map->payload.hashmap.buckets[bucket_no] );
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; return result;
} }
@ -283,146 +267,57 @@ struct cons_pointer clone_hashmap( struct cons_pointer ptr ) {
return result; 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 * Implementation of interned? in C. The final implementation if interned? will
* a key lexically identical to this `key`. * 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 * If this key is lexically identical to a key in this store, return the key
* `store`, else return the value associated with it. * from the store (so that later when we want to retrieve a value, an eq test
* * will work); otherwise return NIL.
* 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 search_store( struct cons_pointer key, struct cons_pointer
struct cons_pointer store, internedp( struct cons_pointer key, struct cons_pointer store ) {
bool return_key ) {
struct cons_pointer result = NIL; 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 ) ) { 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 ) ) { // debug_print( L"Internedp: checking whether `", DEBUG_BIND );
case CONSTV: // debug_print_object( key, DEBUG_BIND );
for ( struct cons_pointer cursor = store; // debug_print( L"` equals `", DEBUG_BIND );
nilp( result ) && ( consp( cursor ) // debug_print_object( entry.payload.cons.car, DEBUG_BIND );
|| hashmapp( cursor ) ); // debug_print( L"`\n", DEBUG_BIND );
cursor = pointer2cell( cursor ).payload.cons.cdr ) {
switch ( get_tag_value( cursor ) ) {
case CONSTV:
struct cons_pointer entry_ptr = c_car( cursor );
switch ( get_tag_value( entry_ptr ) ) { // if ( equal( key, entry.payload.cons.car ) ) {
case CONSTV: // result = entry.payload.cons.car;
if ( equal( key, c_car( entry_ptr ) ) ) { // }
result = if ( !nilp( c_assoc( key, store ) ) ) {
return_key ? c_car( entry_ptr ) : result = key;
c_cdr( entry_ptr ); } else if ( equal( key, privileged_symbol_nil ) ) {
} result = privileged_symbol_nil;
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 { } else {
// failing with key type NIL here (?). Probably worth dumping the stack? debug_print( L"`", DEBUG_BIND );
result = debug_print_object( key, DEBUG_BIND );
throw_exception( c_string_to_lisp_symbol( L"search-store (key)" ), debug_print( L"` is a ", DEBUG_BIND );
make_cons debug_printf( DEBUG_BIND, L"%4.4s",
( c_string_to_lisp_string ( char * ) pointer2cell( key ).tag.bytes );
( L"Unexpected key type: " ), c_type( key ) ), debug_print( L", not a KEYW or SYMB", DEBUG_BIND );
NIL );
} }
debug_print( L"search-store: returning `", DEBUG_BIND );
debug_print_object( result, DEBUG_BIND );
debug_print( L"`\n", DEBUG_BIND );
return result; 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 * Implementation of assoc in C. Like interned?, the final implementation will
* deal with stores which can be association lists or hashtables or hybrids of * 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 c_assoc( struct cons_pointer key,
struct cons_pointer store ) { 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] ); map->payload.hashmap.buckets[bucket_no] );
} }
debug_print( L"hashmap_put:\n", DEBUG_BIND );
debug_dump_object( mapp, DEBUG_BIND );
return mapp; 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
* return a new key/value store containing all the key/value pairs in this * store with this key/value pair added to the front.
* 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 set( struct cons_pointer key, struct cons_pointer value,
struct cons_pointer store ) { struct cons_pointer store ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
#ifdef DEBUG #ifdef DEBUG
bool deep = eq( store, oblist ); bool deep = vectorpointp( store );
debug_print_binding( key, value, deep, DEBUG_BIND ); debug_print_binding( key, value, deep, DEBUG_BIND );
if ( deep ) { if ( deep ) {
@ -485,7 +434,9 @@ struct cons_pointer set( struct cons_pointer key, struct cons_pointer value,
pointer2cell( store ).payload.vectorp.tag.bytes ); pointer2cell( store ).payload.vectorp.tag.bytes );
} }
#endif #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 ); result = make_cons( make_cons( key, value ), store );
} else if ( hashmapp( store ) ) { } else if ( hashmapp( store ) ) {
result = hashmap_put( store, key, value ); result = hashmap_put( store, key, value );
@ -501,8 +452,16 @@ struct cons_pointer
deep_bind( struct cons_pointer key, struct cons_pointer value ) { deep_bind( struct cons_pointer key, struct cons_pointer value ) {
debug_print( L"Entering deep_bind\n", DEBUG_BIND ); debug_print( L"Entering deep_bind\n", DEBUG_BIND );
struct cons_pointer old = oblist;
oblist = set( key, value, 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( L"deep_bind returning ", DEBUG_BIND );
debug_print_object( key, DEBUG_BIND ); debug_print_object( key, DEBUG_BIND );
debug_println( 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 ); struct cons_pointer canonical = internedp( key, environment );
if ( nilp( canonical ) ) { if ( nilp( canonical ) ) {
/* /*
* not currently bound. TODO: this should bind to NIL? * not currently bound
*/ */
result = set( key, TRUE, environment ); result = set( key, TRUE, environment );
} }

14
src/ops/intern.h
View file

@ -20,9 +20,6 @@
#ifndef __intern_h #ifndef __intern_h
#define __intern_h #define __intern_h
#include <stdbool.h>
extern struct cons_pointer privileged_symbol_nil; extern struct cons_pointer privileged_symbol_nil;
extern struct cons_pointer oblist; 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 ); void dump_map( URL_FILE * output, struct cons_pointer pointer );
struct cons_pointer hashmap_get( struct cons_pointer mapp, 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 hashmap_put( struct cons_pointer mapp,
struct cons_pointer key, 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 hash_fn,
struct cons_pointer write_acl ); 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 c_assoc( struct cons_pointer key,
struct cons_pointer store ); 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 internedp( struct cons_pointer key,
struct cons_pointer environment ); 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 hashmap_put( struct cons_pointer mapp,
struct cons_pointer key, struct cons_pointer key,
struct cons_pointer val ); struct cons_pointer val );

293
src/ops/lispops.c
View file

@ -248,7 +248,7 @@ lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer,
* Evaluate a lambda or nlambda expression. * Evaluate a lambda or nlambda expression.
*/ */
struct cons_pointer 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 frame_pointer, struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
#ifdef DEBUG #ifdef DEBUG
@ -257,8 +257,8 @@ eval_lambda( struct cons_space_object *cell, struct stack_frame *frame,
#endif #endif
struct cons_pointer new_env = env; struct cons_pointer new_env = env;
struct cons_pointer names = cell->payload.lambda.args; struct cons_pointer names = cell.payload.lambda.args;
struct cons_pointer body = cell->payload.lambda.body; struct cons_pointer body = cell.payload.lambda.body;
if ( consp( names ) ) { if ( consp( names ) ) {
/* if `names` is a list, bind successive items from that list /* 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; 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. * Internal guts of apply.
@ -398,10 +348,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
if ( exceptionp( fn_pointer ) ) { if ( exceptionp( fn_pointer ) ) {
result = fn_pointer; result = fn_pointer;
} else { } 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] ); struct cons_pointer args = c_cdr( frame->arg[0] );
switch ( get_tag_value( fn_pointer ) ) { switch ( fn_cell.tag.value ) {
case EXCEPTIONTV: case EXCEPTIONTV:
/* just pass exceptions straight back */ /* just pass exceptions straight back */
result = fn_pointer; result = fn_pointer;
@ -419,15 +369,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct stack_frame *next = struct stack_frame *next =
get_stack_frame( next_pointer ); get_stack_frame( next_pointer );
result = maybe_fixup_exception_location( ( * result =
( fn_cell-> ( *fn_cell.payload.function.executable ) ( next,
payload. next_pointer,
function. env );
executable ) )
( next,
next_pointer,
env ),
fn_pointer );
dec_ref( next_pointer ); dec_ref( next_pointer );
} }
} }
@ -461,14 +406,18 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
} }
break; break;
case HASHTV: case VECTORPOINTTV:
/* \todo: if arg[0] is a CONS, treat it as a path */ switch ( pointer_to_vso( fn_pointer )->header.tag.value ) {
result = c_assoc( eval_form( frame, case HASHTV:
frame_pointer, /* \todo: if arg[0] is a CONS, treat it as a path */
c_car( c_cdr result = c_assoc( eval_form( frame,
( frame->arg frame_pointer,
[0] ) ), env ), c_car( c_cdr
fn_pointer ); ( frame->arg
[0] ) ), env ),
fn_pointer );
break;
}
break; break;
case NLAMBDATV: case NLAMBDATV:
@ -492,16 +441,15 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
{ {
struct cons_pointer next_pointer = struct cons_pointer next_pointer =
make_special_frame( frame_pointer, args, env ); make_special_frame( frame_pointer, args, env );
// inc_ref( next_pointer ); inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) { if ( exceptionp( next_pointer ) ) {
result = next_pointer; result = next_pointer;
} else { } else {
result = maybe_fixup_exception_location( ( * result =
( fn_cell-> ( *fn_cell.payload.
payload. special.executable ) ( get_stack_frame
special. ( next_pointer ),
executable ) ) next_pointer, env );
( get_stack_frame( next_pointer ), next_pointer, env ), fn_pointer );
debug_print( L"Special form returning: ", DEBUG_EVAL ); debug_print( L"Special form returning: ", DEBUG_EVAL );
debug_print_object( result, DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL );
debug_println( 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 ); memset( buffer, '\0', bs );
swprintf( buffer, bs, swprintf( buffer, bs,
L"Unexpected cell with tag %d (%4.4s) in function position", 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 = struct cons_pointer message =
c_string_to_lisp_string( buffer ); c_string_to_lisp_string( buffer );
free( buffer ); free( buffer );
result = result = throw_exception( message, frame_pointer );
throw_exception( c_string_to_lisp_symbol( L"apply" ),
message, frame_pointer );
} }
} }
} }
debug_print( L"c_apply: returning: ", DEBUG_EVAL ); 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 ); debug_dump_object( frame_pointer, DEBUG_EVAL );
struct cons_pointer result = frame->arg[0]; 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: case CONSTV:
result = c_apply( frame, frame_pointer, env ); result = c_apply( frame, frame_pointer, env );
break; break;
case SYMBOLTV: case SYMBOLTV:
{ {
struct cons_pointer canonical = interned( frame->arg[0], env ); struct cons_pointer canonical =
internedp( frame->arg[0], env );
if ( nilp( canonical ) ) { if ( nilp( canonical ) ) {
struct cons_pointer message = struct cons_pointer message =
make_cons( c_string_to_lisp_string make_cons( c_string_to_lisp_string
( L"Attempt to take value of unbound symbol." ), ( L"Attempt to take value of unbound symbol." ),
frame->arg[0] ); frame->arg[0] );
result = result = throw_exception( message, frame_pointer );
throw_exception( c_string_to_lisp_symbol( L"eval" ),
message, frame_pointer );
} else { } else {
result = c_assoc( canonical, env ); result = c_assoc( canonical, env );
inc_ref( result ); inc_ref( result );
@ -681,8 +625,7 @@ lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer,
result = frame->arg[1]; result = frame->arg[1];
} else { } else {
result = result =
throw_exception( c_string_to_lisp_symbol( L"set" ), throw_exception( make_cons
make_cons
( c_string_to_lisp_string ( c_string_to_lisp_string
( L"The first argument to `set` is not a symbol: " ), ( L"The first argument to `set` is not a symbol: " ),
make_cons( frame->arg[0], NIL ) ), make_cons( frame->arg[0], NIL ) ),
@ -721,8 +664,7 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer,
result = val; result = val;
} else { } else {
result = result =
throw_exception( c_string_to_lisp_symbol( L"set!" ), throw_exception( make_cons
make_cons
( c_string_to_lisp_string ( c_string_to_lisp_string
( L"The first argument to `set!` is not a symbol: " ), ( L"The first argument to `set!` is not a symbol: " ),
make_cons( frame->arg[0], NIL ) ), make_cons( frame->arg[0], NIL ) ),
@ -794,25 +736,24 @@ struct cons_pointer
lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
struct cons_pointer result = NIL; 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: case CONSTV:
result = cell->payload.cons.car; result = cell.payload.cons.car;
break; break;
case NILTV: case NILTV:
break; break;
case READTV: case READTV:
result = result =
make_string( url_fgetwc( cell->payload.stream.stream ), NIL ); make_string( url_fgetwc( cell.payload.stream.stream ), NIL );
break; break;
case STRINGTV: case STRINGTV:
result = make_string( cell->payload.string.character, NIL ); result = make_string( cell.payload.string.character, NIL );
break; break;
default: default:
result = result =
throw_exception( c_string_to_lisp_symbol( L"car" ), throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Attempt to take CAR of non sequence" ), ( L"Attempt to take CAR of non sequence" ),
frame_pointer ); frame_pointer );
} }
@ -839,25 +780,24 @@ struct cons_pointer
lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
struct cons_pointer result = NIL; 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: case CONSTV:
result = cell->payload.cons.cdr; result = cell.payload.cons.cdr;
break; break;
case NILTV: case NILTV:
break; break;
case READTV: case READTV:
url_fgetwc( cell->payload.stream.stream ); url_fgetwc( cell.payload.stream.stream );
result = frame->arg[0]; result = frame->arg[0];
break; break;
case STRINGTV: case STRINGTV:
result = cell->payload.string.cdr; result = cell.payload.string.cdr;
break; break;
default: default:
result = result =
throw_exception( c_string_to_lisp_symbol( L"cdr" ), throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Attempt to take CDR of non sequence" ), ( L"Attempt to take CDR of non sequence" ),
frame_pointer ); frame_pointer );
} }
@ -895,35 +835,7 @@ struct cons_pointer lisp_length( struct stack_frame *frame,
struct cons_pointer struct cons_pointer
lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer, lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
return c_assoc( frame->arg[0], return c_assoc( frame->arg[0], frame->arg[1] );
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 ) { 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 ); frame->arg[0] : get_default_stream( true, env );
if ( readp( in_stream ) ) { if ( readp( in_stream ) ) {
debug_print( L"lisp_read: setting input stream\n", debug_print( L"lisp_read: setting input stream\n", DEBUG_IO );
DEBUG_IO | DEBUG_REPL );
debug_dump_object( in_stream, DEBUG_IO ); debug_dump_object( in_stream, DEBUG_IO );
input = pointer2cell( in_stream ).payload.stream.stream; input = pointer2cell( in_stream ).payload.stream.stream;
inc_ref( in_stream ); inc_ref( in_stream );
} else { } 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 ); input = file_to_url_file( stdin );
} }
@ -1280,8 +1188,7 @@ struct cons_pointer eval_cond_clause( struct cons_pointer clause,
#endif #endif
} }
} else { } else {
result = throw_exception( c_string_to_lisp_symbol( L"cond" ), result = throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Arguments to `cond` must be lists" ), ( L"Arguments to `cond` must be lists" ),
frame_pointer ); 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. * pointer to the frame in which the exception occurred.
*/ */
struct cons_pointer struct cons_pointer
throw_exception( struct cons_pointer location, throw_exception( struct cons_pointer message,
struct cons_pointer message,
struct cons_pointer frame_pointer ) { struct cons_pointer frame_pointer ) {
debug_print( L"\nERROR: ", DEBUG_EVAL );
debug_dump_object( message, DEBUG_EVAL );
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
#ifdef DEBUG struct cons_space_object cell = pointer2cell( message );
debug_print( L"\nERROR: `", 511 );
debug_print_object( message, 511 );
debug_print( L"` at `", 511 );
debug_print_object( location, 511 );
debug_print( L"`\n", 511 );
debug_print_object( location, 511 );
#endif
struct cons_space_object *cell = &pointer2cell( message ); if ( cell.tag.value == EXCEPTIONTV ) {
if ( cell->tag.value == EXCEPTIONTV ) {
result = message; result = message;
} else { } else {
result = result = make_exception( message, frame_pointer );
make_exception( make_cons
( make_cons( privileged_keyword_location,
location ),
make_cons( make_cons
( privileged_keyword_payload,
message ), NIL ) ), frame_pointer );
} }
return result; return result;
@ -1377,7 +1270,7 @@ throw_exception( struct cons_pointer location,
* normally return. A function which detects a problem it cannot resolve * normally return. A function which detects a problem it cannot resolve
* *should* return an exception. * *should* return an exception.
* *
* * (exception message location) * * (exception message frame)
* *
* @param frame my stack frame. * @param frame my stack frame.
* @param frame_pointer a pointer to 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, lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
struct cons_pointer message = frame->arg[0]; struct cons_pointer message = frame->arg[0];
return exceptionp( message ) ? message : throw_exception( message, return exceptionp( message ) ? message : throw_exception( message,
frame->arg[1], frame->
frame->previous ); previous );
} }
/** /**
@ -1415,11 +1307,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
struct cons_pointer env ) { struct cons_pointer env ) {
struct cons_pointer expr = NIL; struct cons_pointer expr = NIL;
#ifdef DEBUG debug_printf( DEBUG_REPL, L"Entering new inner REPL\n" );
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 input = get_default_stream( true, env );
struct cons_pointer output = get_default_stream( false, 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 ); set( c_string_to_lisp_symbol( L"*in*" ), frame->arg[1], new_env );
input = frame->arg[1]; input = frame->arg[1];
} }
if ( writep( frame->arg[2] ) ) { if ( readp( frame->arg[2] ) ) {
new_env = new_env =
set( c_string_to_lisp_symbol( L"*out*" ), frame->arg[2], new_env ); set( c_string_to_lisp_symbol( L"*out*" ), frame->arg[2], new_env );
output = frame->arg[2]; output = frame->arg[2];
@ -1444,16 +1332,8 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
inc_ref( output ); inc_ref( output );
inc_ref( prompt_name ); inc_ref( prompt_name );
/* output should NEVER BE nil; but during development it has happened. URL_FILE *os = pointer2cell( output ).payload.stream.stream;
* 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 /* \todo this is subtly wrong. If we were evaluating
* (print (eval (read))) * (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 * \todo the whole process of resolving symbol values needs to be revisited
* when we get onto namespaces. */ * when we get onto namespaces. */
/* OK, there's something even more subtle here if the root namespace is a map. /* 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 ) ) { if ( !eq( oblist, old_oblist ) ) {
struct cons_pointer cursor = oblist; struct cons_pointer cursor = oblist;
@ -1517,9 +1394,6 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
dec_ref( expr ); dec_ref( expr );
} }
if ( nilp( output ) ) {
free( os );
}
dec_ref( input ); dec_ref( input );
dec_ref( output ); dec_ref( output );
dec_ref( prompt_name ); 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 frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
struct cons_pointer result = NIL; 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" ); struct cons_pointer source_key = c_string_to_lisp_keyword( L"source" );
switch ( cell->tag.value ) { switch ( cell.tag.value ) {
case FUNCTIONTV: case FUNCTIONTV:
result = c_assoc( source_key, cell->payload.function.meta ); result = c_assoc( source_key, cell.payload.function.meta );
break; break;
case SPECIALTV: case SPECIALTV:
result = c_assoc( source_key, cell->payload.special.meta ); result = c_assoc( source_key, cell.payload.special.meta );
break; break;
case LAMBDATV: case LAMBDATV:
result = make_cons( c_string_to_lisp_symbol( L"lambda" ), result = make_cons( c_string_to_lisp_symbol( L"lambda" ),
make_cons( cell->payload.lambda.args, make_cons( cell.payload.lambda.args,
cell->payload.lambda.body ) ); cell.payload.lambda.body ) );
break; break;
case NLAMBDATV: case NLAMBDATV:
result = make_cons( c_string_to_lisp_symbol( L"nlambda" ), result = make_cons( c_string_to_lisp_symbol( L"nlambda" ),
make_cons( cell->payload.lambda.args, make_cons( cell.payload.lambda.args,
cell->payload.lambda.body ) ); cell.payload.lambda.body ) );
break; break;
} }
// \todo suffers from premature GC, and I can't see why! // \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 ) ); c_append( c_cdr( l1 ), l2 ) );
} }
} else { } else {
throw_exception( c_string_to_lisp_symbol( L"append" ), throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Can't append: not same type" ), NIL ); ( L"Can't append: not same type" ), NIL );
} }
break; 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 ( pointer2cell( l1 ).tag.value == pointer2cell( l2 ).tag.value ) {
if ( nilp( c_cdr( l1 ) ) ) { if ( nilp( c_cdr( l1 ) ) ) {
return return
make_string_like_thing( ( pointer2cell( l1 ).payload. make_string_like_thing( ( pointer2cell( l1 ).
string.character ), l2, payload.string.character ),
l2,
pointer2cell( l1 ).tag.value ); pointer2cell( l1 ).tag.value );
} else { } else {
return return
make_string_like_thing( ( pointer2cell( l1 ).payload. make_string_like_thing( ( pointer2cell( l1 ).
string.character ), payload.string.character ),
c_append( c_cdr( l1 ), l2 ), c_append( c_cdr( l1 ), l2 ),
pointer2cell( l1 ).tag.value ); pointer2cell( l1 ).tag.value );
} }
} else { } else {
throw_exception( c_string_to_lisp_symbol( L"append" ), throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Can't append: not same type" ), NIL ); ( L"Can't append: not same type" ), NIL );
} }
break; break;
default: default:
throw_exception( c_string_to_lisp_symbol( L"append" ), throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Can't append: not a sequence" ), NIL ); ( L"Can't append: not a sequence" ), NIL );
break; break;
} }
@ -1727,8 +1599,7 @@ struct cons_pointer lisp_let( struct stack_frame *frame,
bindings = make_cons( make_cons( symbol, val ), bindings ); bindings = make_cons( make_cons( symbol, val ), bindings );
} else { } else {
result = result =
throw_exception( c_string_to_lisp_symbol( L"let" ), throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Let: cannot bind, not a symbol" ), ( L"Let: cannot bind, not a symbol" ),
frame_pointer ); frame_pointer );
break; break;

6
src/ops/lispops.h
View file

@ -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 lisp_inspect( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ); 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 lisp_eq( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ); 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 * signature of a lisp function; but it is nevertheless to be preferred to
* make_exception. A real `throw_exception`, which does, will be needed. * make_exception. A real `throw_exception`, which does, will be needed.
*/ */
struct cons_pointer throw_exception( struct cons_pointer location, struct cons_pointer throw_exception( struct cons_pointer message,
struct cons_pointer message,
struct cons_pointer frame_pointer ); struct cons_pointer frame_pointer );
struct cons_pointer lisp_exception( struct stack_frame *frame, struct cons_pointer lisp_exception( struct stack_frame *frame,