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

Very, very nearly ready for 0.0.6. Too tired to press the burron tonight.

Browse source
This commit is contained in:
Simon Brooke 2026-02-27 02:43:21 +00:00
parent b720211b7b
commit 1900bca706
29 changed files with 567 additions and 800 deletions
Download patch file Download diff file Expand all files Collapse all files

4
src/arith/integer.c
View file

@ -257,9 +257,9 @@ struct cons_pointer add_integers( struct cons_pointer a,
debug_print_128bit( rv, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
if ( carry == 0 && rv >= 0 && rv < SMALL_INT_LIMIT ) {
if ( carry == 0 && rv >= 0 && rv < SMALL_INT_LIMIT ) {
result =
acquire_integer( ( int64_t ) ( rv & MAX_INTEGER ), NIL );
acquire_integer( ( int64_t ) ( rv & MAX_INTEGER ), NIL );
break;
} else {
struct cons_pointer new = make_integer( 0, NIL );

26
src/arith/peano.c
View file

@ -69,7 +69,7 @@ bool zerop( struct cons_pointer arg ) {
// bool result = false;
// struct cons_space_object * cell_1 = & pointer2cell( arg_1 );
// struct cons_space_object * cell_2 = & pointer2cell( arg_2 );
// if (cell_1->tag.value == cell_2->tag.value) {
// switch ( cell_1->tag.value ) {
@ -90,7 +90,7 @@ bool zerop( struct cons_pointer arg ) {
// }
// return result;
// }
/**
@ -126,17 +126,18 @@ struct cons_pointer absolute( struct cons_pointer arg ) {
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( arg );
if ( numberp( arg)) {
if ( numberp( arg ) ) {
if ( is_negative( arg ) ) {
switch ( cell.tag.value ) {
case INTEGERTV:
result =
make_integer( llabs( cell.payload.integer.value ),
cell.payload.integer.more );
cell.payload.integer.more );
break;
case RATIOTV:
result = make_ratio( absolute( cell.payload.ratio.dividend ),
cell.payload.ratio.divisor, false );
result =
make_ratio( absolute( cell.payload.ratio.dividend ),
cell.payload.ratio.divisor, false );
break;
case REALTV:
result = make_real( 0 - cell.payload.real.value );
@ -606,7 +607,8 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
case RATIOTV:{
struct cons_pointer tmp = make_ratio( arg1,
make_integer( 1,
NIL ), false );
NIL ),
false );
inc_ref( tmp );
result = subtract_ratio_ratio( tmp, arg2 );
dec_ref( tmp );
@ -632,7 +634,8 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
case INTEGERTV:{
struct cons_pointer tmp = make_ratio( arg2,
make_integer( 1,
NIL ), false );
NIL ),
false );
inc_ref( tmp );
result = subtract_ratio_ratio( arg1, tmp );
dec_ref( tmp );
@ -711,8 +714,7 @@ struct cons_pointer lisp_divide( struct
break;
case INTEGERTV:{
result =
make_ratio( frame->arg[0],
frame->arg[1], true);
make_ratio( frame->arg[0], frame->arg[1], true );
}
break;
case RATIOTV:{
@ -744,8 +746,8 @@ struct cons_pointer lisp_divide( struct
case INTEGERTV:{
struct cons_pointer one = make_integer( 1, NIL );
struct cons_pointer ratio =
make_ratio( frame->arg[1], one, false);
result = divide_ratio_ratio( frame->arg[0], ratio );
make_ratio( frame->arg[1], one, false );
result = divide_ratio_ratio( frame->arg[0], ratio );
dec_ref( ratio );
dec_ref( one );
}

28
src/arith/ratio.c
View file

@ -72,7 +72,8 @@ struct cons_pointer simplify_ratio( struct cons_pointer pointer ) {
ddrv, drrv, ddrv / gcd, drrv / gcd );
result =
make_ratio( acquire_integer( ddrv / gcd, NIL ),
acquire_integer( drrv / gcd, NIL ), false);
acquire_integer( drrv / gcd, NIL ),
false );
}
}
}
@ -182,8 +183,8 @@ struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1,
// TODO: this now has to work if `arg1` is an integer
struct cons_pointer i =
make_ratio( pointer2cell( arg2 ).payload.ratio.divisor,
pointer2cell( arg2 ).payload.ratio.dividend, false ), result =
multiply_ratio_ratio( arg1, i );
pointer2cell( arg2 ).payload.ratio.dividend, false ),
result = multiply_ratio_ratio( arg1, i );
dec_ref( i );
@ -228,7 +229,7 @@ struct cons_pointer multiply_ratio_ratio( struct
struct cons_pointer dividend = acquire_integer( ddrv, NIL );
struct cons_pointer divisor = acquire_integer( drrv, NIL );
result = make_ratio( dividend, divisor, true );
release_integer( dividend );
release_integer( divisor );
} else {
@ -310,13 +311,12 @@ struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1,
* @exception if either `dividend` or `divisor` is not an integer.
*/
struct cons_pointer make_ratio( struct cons_pointer dividend,
struct cons_pointer divisor,
bool simplify ) {
debug_print( L"make_ratio: dividend = ", DEBUG_ALLOC);
debug_print_object( dividend, DEBUG_ALLOC);
debug_print( L"; divisor = ", DEBUG_ALLOC);
debug_print_object( divisor, DEBUG_ALLOC);
debug_printf( DEBUG_ALLOC, L"; simplify = %d\n", simplify);
struct cons_pointer divisor, bool simplify ) {
debug_print( L"make_ratio: dividend = ", DEBUG_ALLOC );
debug_print_object( dividend, DEBUG_ALLOC );
debug_print( L"; divisor = ", DEBUG_ALLOC );
debug_print_object( divisor, DEBUG_ALLOC );
debug_printf( DEBUG_ALLOC, L"; simplify = %d\n", simplify );
struct cons_pointer result;
if ( integerp( dividend ) && integerp( divisor ) ) {
@ -327,7 +327,7 @@ struct cons_pointer make_ratio( struct cons_pointer dividend,
cell->payload.ratio.dividend = dividend;
cell->payload.ratio.divisor = divisor;
if ( simplify) {
if ( simplify ) {
result = simplify_ratio( unsimplified );
if ( !eq( result, unsimplified ) ) {
dec_ref( unsimplified );
@ -341,9 +341,9 @@ struct cons_pointer make_ratio( struct cons_pointer dividend,
( L"Dividend and divisor of a ratio must be integers" ),
NIL );
}
debug_print( L" => ", DEBUG_ALLOC);
debug_print( L" => ", DEBUG_ALLOC );
debug_print_object( result, DEBUG_ALLOC );
debug_println( DEBUG_ALLOC);
debug_println( DEBUG_ALLOC );
return result;
}

3
src/arith/ratio.h
View file

@ -32,8 +32,7 @@ struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1,
struct cons_pointer arg2 );
struct cons_pointer make_ratio( struct cons_pointer dividend,
struct cons_pointer divisor,
bool simplify );
struct cons_pointer divisor, bool simplify );
bool equal_ratio_ratio( struct cons_pointer a, struct cons_pointer b );

17
src/debug.c
View file

@ -147,15 +147,16 @@ void debug_dump_object( struct cons_pointer pointer, int level ) {
/**
* Standardise printing of binding trace messages.
*/
void debug_print_binding( struct cons_pointer key, struct cons_pointer val, bool deep, int level) {
void debug_print_binding( struct cons_pointer key, struct cons_pointer val,
bool deep, int level ) {
#ifdef DEBUG
// wchar_t * depth = (deep ? L"Deep" : L"Shallow");
debug_print( (deep ? L"Deep" : L"Shallow"), level);
debug_print( L" binding `", level);
debug_print_object( key, level);
debug_print( L"` to `", level);
debug_print_object( val, level);
debug_print( L"`\n", level);
debug_print( ( deep ? L"Deep" : L"Shallow" ), level );
debug_print( L" binding `", level );
debug_print_object( key, level );
debug_print( L"` to `", level );
debug_print_object( val, level );
debug_print( L"`\n", level );
#endif
}
}

3
src/debug.h
View file

@ -87,6 +87,7 @@ void debug_println( int level );
void debug_printf( int level, wchar_t *format, ... );
void debug_print_object( struct cons_pointer pointer, int level );
void debug_dump_object( struct cons_pointer pointer, int level );
void debug_print_binding( struct cons_pointer key, struct cons_pointer val, bool deep, int level);
void debug_print_binding( struct cons_pointer key, struct cons_pointer val,
bool deep, int level );
#endif

280
src/init.c
View file

@ -71,8 +71,9 @@ struct cons_pointer init_name_symbol = NIL;
struct cons_pointer init_primitive_symbol = NIL;
void maybe_bind_init_symbols( ) {
if ( nilp( init_documentation_symbol)) {
init_documentation_symbol = c_string_to_lisp_keyword( L"documentation");
if ( nilp( init_documentation_symbol ) ) {
init_documentation_symbol =
c_string_to_lisp_keyword( L"documentation" );
}
if ( nilp( init_name_symbol ) ) {
init_name_symbol = c_string_to_lisp_keyword( L"name" );
@ -83,15 +84,16 @@ void maybe_bind_init_symbols( ) {
if ( nilp( privileged_symbol_nil ) ) {
privileged_symbol_nil = c_string_to_lisp_symbol( L"nil" );
}
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 = c_string_to_lisp_string( L"Memory exhausted." );
privileged_string_memory_exhausted =
c_string_to_lisp_string( L"Memory exhausted." );
}
}
void free_init_symbols( ) {
dec_ref( init_documentation_symbol);
dec_ref( init_documentation_symbol );
dec_ref( init_name_symbol );
dec_ref( init_primitive_symbol );
}
@ -110,12 +112,14 @@ struct cons_pointer bind_function( wchar_t *name,
struct cons_pointer,
struct cons_pointer ) ) {
struct cons_pointer n = c_string_to_lisp_symbol( name );
struct cons_pointer d = c_string_to_lisp_string( doc);
struct cons_pointer d = c_string_to_lisp_string( doc );
struct cons_pointer meta =
make_cons( make_cons( init_primitive_symbol, TRUE ),
make_cons( make_cons( init_name_symbol, n ),
make_cons( make_cons( init_documentation_symbol, d), NIL) ) );
make_cons( make_cons
( init_documentation_symbol, d ),
NIL ) ) );
struct cons_pointer r =
check_exception( deep_bind( n, make_function( meta, executable ) ),
@ -132,20 +136,26 @@ struct cons_pointer bind_function( wchar_t *name,
* this `name` in the `oblist`.
*/
struct cons_pointer bind_special( wchar_t *name,
wchar_t *doc,
struct cons_pointer ( *executable )
( struct stack_frame *, struct cons_pointer,
struct cons_pointer ) ) {
struct cons_pointer n = c_string_to_lisp_symbol( name );
struct cons_pointer d = c_string_to_lisp_string( doc );
struct cons_pointer meta =
make_cons( make_cons( init_primitive_symbol, TRUE ),
make_cons( make_cons( init_name_symbol, n ), NIL ) );
make_cons( make_cons( init_name_symbol, n ),
make_cons( make_cons
( init_documentation_symbol, d ),
NIL ) ) );
struct cons_pointer r =
check_exception( deep_bind( n, make_special( meta, executable ) ),
"bind_special" );
dec_ref( n );
dec_ref( d );
return r;
}
@ -334,96 +344,179 @@ int main( int argc, char *argv[] ) {
/*
* primitive function operations
*/
/* TODO: docstrings should be moved to a header file, or even to an at-run-time resolution system.
* HTTP from an address at journeyman? */
bind_function( L"absolute",
L"`(absolute arg)`: If `arg` is a number, return the absolute value of that number, else `nil`.",
&lisp_absolute );
bind_function( L"add",
L"`(+ args...)`: If `args` are all numbers, return the sum of those numbers.",
&lisp_add );
bind_function( L"and",
L"`(and args...)`: Return a logical `and` of all the arguments and return `t` only if all are truthy, else `nil`.",
&lisp_and);
bind_function( L"append", L"`(append args...)`: If args are all collections, return the concatenation of those collections.",
&lisp_append );
bind_function( L"apply",
L"`(apply f args)`: If `f` is usable as a function, and `args` is a collection, apply `f` to `args` and return the value.",
&lisp_apply );
bind_function( L"assoc",
L"`(assoc key store)`: Return the value associated with this `key` in this `store`.",
&lisp_assoc );
bind_function( L"car",
L"`(car arg)`: If `arg` is a sequence, return the item which is the head of that sequence.",
&lisp_car );
bind_function( L"cdr",
L"`(cdr arg)`: If `arg` is a sequence, return the remainder of that sequence with the first item removed.",
&lisp_cdr );
bind_function( L"close", L"`(close stream)`: If `stream` is a stream, close that stream.", &lisp_close );
bind_function( L"cons", L"`(cons a b)`: Return a cons cell whose `car` is `a` and whose `cdr` is `b`.", &lisp_cons );
bind_function( L"count", L"`(count s)`: Return the number of items in the sequence `s`.", &lisp_count);
bind_function( L"divide",
L"`(/ a b)`: If `a` and `b` are both numbers, return the numeric result of dividing `a` by `b`.",
&lisp_divide );
bind_function( L"eq?", L"`(eq? args...)`: Return `t` if all args are the exact same object, else `nil`.", &lisp_eq );
bind_function( L"equal?", L"`(equal? args...)`: Return `t` if all args have logically equivalent value, else `nil`.", &lisp_equal );
/* TODO: docstrings should be moved to a header file, or even to an at-run-time resolution system.
* HTTP from an address at journeyman? */
bind_function( L"absolute",
L"`(absolute arg)`: If `arg` is a number, return the absolute value of that number, else `nil`.",
&lisp_absolute );
bind_function( L"add",
L"`(+ args...)`: If `args` are all numbers, return the sum of those numbers.",
&lisp_add );
bind_function( L"and",
L"`(and args...)`: Return a logical `and` of all the arguments and return `t` only if all are truthy, else `nil`.",
&lisp_and );
bind_function( L"append",
L"`(append args...)`: If args are all collections, return the concatenation of those collections.",
&lisp_append );
bind_function( L"apply",
L"`(apply f args)`: If `f` is usable as a function, and `args` is a collection, apply `f` to `args` and return the value.",
&lisp_apply );
bind_function( L"assoc",
L"`(assoc key store)`: Return the value associated with this `key` in this `store`.",
&lisp_assoc );
bind_function( L"car",
L"`(car arg)`: If `arg` is a sequence, return the item which is the head of that sequence.",
&lisp_car );
bind_function( L"cdr",
L"`(cdr arg)`: If `arg` is a sequence, return the remainder of that sequence with the first item removed.",
&lisp_cdr );
bind_function( L"close",
L"`(close stream)`: If `stream` is a stream, close that stream.",
&lisp_close );
bind_function( L"cons",
L"`(cons a b)`: Return a cons cell whose `car` is `a` and whose `cdr` is `b`.",
&lisp_cons );
bind_function( L"count",
L"`(count s)`: Return the number of items in the sequence `s`.",
&lisp_count );
bind_function( L"divide",
L"`(/ a b)`: If `a` and `b` are both numbers, return the numeric result of dividing `a` by `b`.",
&lisp_divide );
bind_function( L"eq?",
L"`(eq? args...)`: Return `t` if all args are the exact same object, else `nil`.",
&lisp_eq );
bind_function( L"equal?",
L"`(equal? args...)`: Return `t` if all args have logically equivalent value, else `nil`.",
&lisp_equal );
bind_function( L"eval", L"", &lisp_eval );
bind_function( L"exception", L"`(exception message)`: Return (throw) an exception with this `message`.", &lisp_exception );
bind_function( L"get-hash", L"`(get-hash arg)`: returns the natural number hash value of `arg`.", &lisp_get_hash );
bind_function( L"hashmap",
L"`(hashmap n-buckets hashfn store acl)`: Return a new hashmap, with `n-buckets` buckets and this `hashfn`, containing the content of this `store`.",
lisp_make_hashmap );
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"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`.", &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.", &lisp_mapcar );
bind_function( L"meta", L"`(meta symbol)`: If the binding of `symbol` has metadata, return that metadata, else `nil`.", &lisp_metadata );
bind_function( L"metadata", L"`(metadata symbol)`: If the binding of `symbol` has metadata, return that metadata, else `nil`.", &lisp_metadata );
bind_function( L"multiply", L"`(* args...)` Multiply these `args`, all of which should be numbers.", &lisp_multiply );
bind_function( L"negative?", L"`(negative? n)`: Return `t` if `n` is a negative number, else `nil`.", &lisp_is_negative );
bind_function( L"not",
L"`(not arg)`: Return`t` only if `arg` is `nil`, else `nil`.",
&lisp_not);
bind_function( L"oblist", L"`(oblist)`: Return the current symbol bindings, as a map.", &lisp_oblist );
bind_function( L"open", L"`(open url write?)`: Open a stream to this `url`. If `write?` is present and is non-nil, open it for writing, else reading.", &lisp_open );
bind_function( L"or",
L"`(or args...)`: Return a logical `or` of all the arguments and return `t` if any is truthy, else `nil`.",
&lisp_or);
bind_function( L"print", L"`(print object stream)`: Print `object` to `stream`, if specified, else to `*out*`.", &lisp_print );
bind_function( L"exception",
L"`(exception message)`: Return (throw) an exception with this `message`.",
&lisp_exception );
bind_function( L"get-hash",
L"`(get-hash arg)`: returns the natural number hash value of `arg`.",
&lisp_get_hash );
bind_function( L"hashmap",
L"`(hashmap n-buckets hashfn store acl)`: Return a new hashmap, with `n-buckets` buckets and this `hashfn`, containing the content of this `store`.",
lisp_make_hashmap );
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"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`.",
&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.",
&lisp_mapcar );
bind_function( L"meta",
L"`(meta symbol)`: If the binding of `symbol` has metadata, return that metadata, else `nil`.",
&lisp_metadata );
bind_function( L"metadata",
L"`(metadata symbol)`: If the binding of `symbol` has metadata, return that metadata, else `nil`.",
&lisp_metadata );
bind_function( L"multiply",
L"`(* args...)` Multiply these `args`, all of which should be numbers.",
&lisp_multiply );
bind_function( L"negative?",
L"`(negative? n)`: Return `t` if `n` is a negative number, else `nil`.",
&lisp_is_negative );
bind_function( L"not",
L"`(not arg)`: Return`t` only if `arg` is `nil`, else `nil`.",
&lisp_not );
bind_function( L"oblist",
L"`(oblist)`: Return the current symbol bindings, as a map.",
&lisp_oblist );
bind_function( L"open",
L"`(open url write?)`: Open a stream to this `url`. If `write?` is present and is non-nil, open it for writing, else reading.",
&lisp_open );
bind_function( L"or",
L"`(or args...)`: Return a logical `or` of all the arguments and return `t` if any is truthy, else `nil`.",
&lisp_or );
bind_function( L"print",
L"`(print object stream)`: Print `object` to `stream`, if specified, else to `*out*`.",
&lisp_print );
bind_function( L"println",
L"`(println stream)`: Print a new line character to `stream`, if specified, else to `*out*`.",
&lisp_print );
bind_function( L"put!", L"", lisp_hashmap_put );
bind_function( L"put-all!", L"", &lisp_hashmap_put_all );
bind_function( L"ratio->real", L"`(ratio->real r)`: If `r` is a rational number, return the real number equivalent.", &lisp_ratio_to_real );
bind_function( L"read", L"", &lisp_read );
bind_function( L"read-char", L"", &lisp_read_char );
bind_function( L"repl", L"", &lisp_repl );
bind_function( L"reverse", L"", &lisp_reverse );
bind_function( L"put-all!",
L"`(put-all! dest source)`: If `dest` is a namespace and is writable, copies all key-value pairs from `source` into `dest`.",
&lisp_hashmap_put_all );
bind_function( L"ratio->real",
L"`(ratio->real r)`: If `r` is a rational number, return the real number equivalent.",
&lisp_ratio_to_real );
bind_function( L"read",
L"`(read stream)`: read one complete lisp form and return it. If `stream` is specified and is a read stream, then read from that stream, else the stream which is the value of `*in*` in the environment.",
&lisp_read );
bind_function( L"read-char",
L"`(read-char stream)`: Return the next character. If `stream` is specified and is a read stream, then read from that stream, else the stream which is the value of `*in*` in the environment.",
&lisp_read_char );
bind_function( L"repl",
L"`(repl prompt input output)`: Starts a new read-eval-print-loop. All arguments are optional.",
&lisp_repl );
bind_function( L"reverse",
L"`(reverse sequence)` Returns a sequence of the top level elements of this `sequence`, which may be a list or a string, in the reverse order.",
&lisp_reverse );
bind_function( L"set", L"", &lisp_set );
bind_function( L"slurp", L"", &lisp_slurp );
bind_function( L"source", L"", &lisp_source );
bind_function( L"subtract", L"", &lisp_subtract );
bind_function( L"slurp",
L"`(slurp read-stream)` Read all the characters from `read-stream` to the end of stream, and return them as a string.",
&lisp_slurp );
bind_function( L"source",
L"`(source object)`: If `object` is an interpreted function or interpreted special form, returns the source code; else nil.",
&lisp_source );
bind_function( L"subtract",
L"`(- a b)`: Subtracts `b` from `a` and returns the result. Expects both arguments to be numbers.",
&lisp_subtract );
bind_function( L"throw", L"", &lisp_exception );
bind_function( L"time", L"", &lisp_time );
bind_function( L"type", L"", &lisp_type );
bind_function( L"+", L"`(+ args...)`: If `args` are all numbers, return the sum of those numbers.", &lisp_add );
bind_function( L"*", L"", &lisp_multiply );
bind_function( L"-", L"", &lisp_subtract );
bind_function( L"/", L"", &lisp_divide );
bind_function( L"=", L"`(equal? args...)`: Return `t` if all args have logically equivalent value, else `nil`.", &lisp_equal );
bind_function( L"time",
L"`(time arg)`: Return a time object. If an `arg` is supplied, it should be an integer which will be interpreted as a number of microseconds since the big bang, which is assumed to have happened 441,806,400,000,000,000 seconds before the UNIX epoch.",
&lisp_time );
bind_function( L"type",
L"`(type object)`: returns the type of the specified `object`. Currently (0.0.6) the type is returned as a four character string; this may change.",
&lisp_type );
bind_function( L"+",
L"`(+ args...)`: If `args` are all numbers, return the sum of those numbers.",
&lisp_add );
bind_function( L"*",
L"`(* args...)` Multiply these `args`, all of which should be numbers.",
&lisp_multiply );
bind_function( L"-",
L"`(- a b)`: Subtracts `b` from `a` and returns the result. Expects both arguments to be numbers.",
&lisp_subtract );
bind_function( L"/",
L"`(/ a b)`: If `a` and `b` are both numbers, return the numeric result of dividing `a` by `b`.",
&lisp_divide );
bind_function( L"=",
L"`(equal? args...)`: Return `t` if all args have logically equivalent value, else `nil`.",
&lisp_equal );
/*
* primitive special forms
*/
bind_special( L"cond", &lisp_cond );
bind_special( L"lambda", &lisp_lambda );
bind_special( L"\u03bb", &lisp_lambda ); // λ
bind_special( L"let", &lisp_let );
bind_special( L"nlambda", &lisp_nlambda );
bind_special( L"n\u03bb", &lisp_nlambda );
bind_special( L"progn", &lisp_progn );
bind_special( L"quote", &lisp_quote );
bind_special( L"set!", &lisp_set_shriek );
bind_special( L"try", &lisp_try );
bind_special( L"cond",
L"`(cond clauses...)`: Conditional evaluation, `clauses` is a sequence of lists of forms such that if evaluating the first form in any clause returns non-`nil`, the subsequent forms in that clause will be evaluated and the value of the last returned; but any subsequent clauses will not be evaluated.",
&lisp_cond );
bind_special( L"lambda",
L"`(lambda arg-list forms...)`: Construct an interpretable λ funtion.",
&lisp_lambda );
bind_special( L"\u03bb", L"", &lisp_lambda ); // λ
bind_special( L"let",
L"`(let bindings forms)`: Bind these `bindings`, which should be specified as an association list, into the local environment and evaluate these forms sequentially in that context, returning the value of the last.",
&lisp_let );
bind_special( L"nlambda",
L"`(nlamda arg-list forms...)`: Construct an interpretable special form. When the form is interpreted, arguments specified in the `arg-list` will not be evaluated.",
&lisp_nlambda );
bind_special( L"n\u03bb", L"`(nlamda arg-list forms...)`: Construct an interpretable special form. When the form is interpreted, arguments specified in the `arg-list` will not be evaluated.", &lisp_nlambda ); // nλ
bind_special( L"progn",
L"`(progn forms...)` Evaluate `forms` sequentially, and return the value of the last.",
&lisp_progn );
bind_special( L"quote",
L"`(quote form)`: Returns `form`, unevaluated. More idiomatically expressed `'form`, where the quote mark is a reader macro which is expanded to `(quote form)`.",
&lisp_quote );
bind_special( L"set!",
L"`(set! symbol value namespace)`: Binds `symbol` in `namespace` to the value of `value`, altering the namespace in so doing, and returns `value`. If `namespace` is not specified, it defaults to the default namespace.",
&lisp_set_shriek );
bind_special( L"try", L"", &lisp_try );
debug_print( L"Initialised oblist\n", DEBUG_BOOTSTRAP );
debug_dump_object( oblist, DEBUG_BOOTSTRAP );
@ -432,8 +525,9 @@ int main( int argc, char *argv[] ) {
debug_dump_object( oblist, DEBUG_BOOTSTRAP );
debug_print( L"Freeing oblist\n", DEBUG_BOOTSTRAP );
while ( (pointer2cell(oblist)).count > 0) {
fprintf( stderr, "Dangling refs on oblist: %d\n", (pointer2cell(oblist)).count );
while ( ( pointer2cell( oblist ) ).count > 0 ) {
fprintf( stderr, "Dangling refs on oblist: %d\n",
( pointer2cell( oblist ) ).count );
dec_ref( oblist );
}

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] ) ) {
result =
make_string( url_fgetwc
( pointer2cell( frame->arg[0] ).payload.stream.
stream ), NIL );
( pointer2cell( frame->arg[0] ).payload.
stream.stream ), NIL );
}
return result;

97
src/io/print.c
View file

@ -17,15 +17,17 @@
#include <wchar.h>
#include <wctype.h>
#include "arith/integer.h"
#include "debug.h"
#include "io/io.h"
#include "io/print.h"
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
#include "memory/hashmap.h"
#include "arith/integer.h"
#include "ops/intern.h"
#include "memory/stack.h"
#include "io/print.h"
#include "time/psse_time.h"
#include "memory/vectorspace.h"
#include "ops/intern.h"
#include "time/psse_time.h"
/**
* print all the characters in the symbol or string indicated by `pointer`
@ -117,7 +119,7 @@ void print_vso( URL_FILE *output, struct cons_pointer pointer ) {
print_map( output, pointer );
break;
case STACKFRAMETV:
dump_stack_trace( output, pointer);
dump_stack_trace( output, pointer );
break;
// \todo: others.
default:
@ -251,7 +253,7 @@ struct cons_pointer print( URL_FILE *output, struct cons_pointer pointer ) {
url_fwprintf( output, L"<Time: " );
print_string( output, time_to_string( pointer ) );
url_fputws( L"; ", output );
print_128bit( output, pointer2cell( pointer ).payload.time.value );
print_128bit( output, cell.payload.time.value );
url_fputwc( L'>', output );
break;
case TRUETV:
@ -269,12 +271,95 @@ struct cons_pointer print( URL_FILE *output, struct cons_pointer pointer ) {
fwprintf( stderr,
L"Error: Unrecognised tag value %d (%4.4s)\n",
cell.tag.value, &cell.tag.bytes[0] );
// dump_object( stderr, pointer);
break;
}
return pointer;
}
/**
* Function; print one complete lisp expression and return NIL. If write-stream is specified and
* is a write stream, then print to that stream, else the stream which is the value of
* `*out*` in the environment.
*
* * (print expr)
* * (print expr write-stream)
*
* @param frame my stack_frame.
* @param frame_pointer a pointer to my stack_frame.
* @param env my environment (from which the stream may be extracted).
* @return NIL.
*/
struct cons_pointer
lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
debug_print( L"Entering print\n", DEBUG_IO );
struct cons_pointer result = NIL;
URL_FILE *output;
struct cons_pointer out_stream = writep( frame->arg[1] ) ?
frame->arg[1] : get_default_stream( false, env );
if ( writep( out_stream ) ) {
debug_print( L"lisp_print: setting output stream\n", DEBUG_IO );
debug_dump_object( out_stream, DEBUG_IO );
output = pointer2cell( out_stream ).payload.stream.stream;
inc_ref( out_stream );
} else {
output = file_to_url_file( stderr );
}
debug_print( L"lisp_print: about to print\n", DEBUG_IO );
debug_dump_object( frame->arg[0], DEBUG_IO );
result = print( output, frame->arg[0] );
debug_print( L"lisp_print returning\n", DEBUG_IO );
debug_dump_object( result, DEBUG_IO );
if ( writep( out_stream ) ) {
dec_ref( out_stream );
} else {
free( output );
}
return result;
}
void println( URL_FILE *output ) {
url_fputws( L"\n", output );
}
/**
* @brief `(prinln out-stream)`: Print a new line character to `out-stream`, if
* it is specified and is an output stream, else to `*out*`.
*
* @param frame
* @param frame_pointer
* @param env
* @return `nil`
*/
struct cons_pointer
lisp_println( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
URL_FILE *output;
struct cons_pointer out_stream = writep( frame->arg[1] ) ?
frame->arg[1] : get_default_stream( false, env );
if ( writep( out_stream ) ) {
output = pointer2cell( out_stream ).payload.stream.stream;
inc_ref( out_stream );
} else {
output = file_to_url_file( stderr );
}
println( output );
if ( writep( out_stream ) ) {
dec_ref( out_stream );
} else {
free( output );
}
return NIL;
}

8
src/io/print.h
View file

@ -19,4 +19,12 @@
struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer );
void println( URL_FILE * output );
struct cons_pointer lisp_print( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_println( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
#endif

2
src/io/read.c
View file

@ -370,7 +370,7 @@ struct cons_pointer read_number( struct stack_frame *frame,
( to_long_double
( base ),
places_of_decimals ),
NIL ), true);
NIL ), true );
inc_ref( div );
result = make_real( to_long_double( div ) );

8
src/memory/conspage.c
View file

@ -132,11 +132,11 @@ void dump_pages( URL_FILE *output ) {
url_fwprintf( output, L"\nDUMPING PAGE %d\n", i );
for ( int j = 0; j < CONSPAGESIZE; j++ ) {
struct cons_pointer pointer = ( struct cons_pointer ) { i, j};
if (!freep( pointer)) {
struct cons_pointer pointer = ( struct cons_pointer ) { i, j };
if ( !freep( pointer ) ) {
dump_object( output, ( struct cons_pointer ) {
i, j
} );
i, j
} );
}
}
}

35
src/memory/consspaceobject.c
View file

@ -65,11 +65,16 @@ struct cons_pointer inc_ref( struct cons_pointer pointer ) {
if ( cell->count < MAXREFERENCE ) {
cell->count++;
#ifdef DEBUG
debug_printf( DEBUG_ALLOC, L"\nIncremented cell of type %4.4s at page %d, offset %d to count %d", ((char *)cell->tag.bytes), pointer.page, pointer.offset, cell->count);
if ( strncmp( cell->tag.bytes, VECTORPOINTTAG, TAGLENGTH) == 0) {
debug_printf( DEBUG_ALLOC, L"; pointer to vector object of type %4.4s.\n", ((char *)(cell->payload.vectorp.tag.bytes)));
debug_printf( DEBUG_ALLOC,
L"\nIncremented cell of type %4.4s at page %d, offset %d to count %d",
( ( char * ) cell->tag.bytes ), pointer.page,
pointer.offset, cell->count );
if ( strncmp( cell->tag.bytes, VECTORPOINTTAG, TAGLENGTH ) == 0 ) {
debug_printf( DEBUG_ALLOC,
L"; pointer to vector object of type %4.4s.\n",
( ( char * ) ( cell->payload.vectorp.tag.bytes ) ) );
} else {
debug_println( DEBUG_ALLOC);
debug_println( DEBUG_ALLOC );
}
#endif
}
@ -91,11 +96,17 @@ struct cons_pointer dec_ref( struct cons_pointer pointer ) {
if ( cell->count > 0 && cell->count != UINT32_MAX ) {
cell->count--;
#ifdef DEBUG
debug_printf( DEBUG_ALLOC, L"\nDecremented cell of type %4.4s at page %d, offset %d to count %d", ((char *)cell->tag.bytes), pointer.page, pointer.offset, cell->count);
if ( strncmp( (char *)cell->tag.bytes, VECTORPOINTTAG, TAGLENGTH) == 0) {
debug_printf( DEBUG_ALLOC, L"; pointer to vector object of type %4.4s.\n", ((char *)(cell->payload.vectorp.tag.bytes)));
debug_printf( DEBUG_ALLOC,
L"\nDecremented cell of type %4.4s at page %d, offset %d to count %d",
( ( char * ) cell->tag.bytes ), pointer.page,
pointer.offset, cell->count );
if ( strncmp( ( char * ) cell->tag.bytes, VECTORPOINTTAG, TAGLENGTH )
== 0 ) {
debug_printf( DEBUG_ALLOC,
L"; pointer to vector object of type %4.4s.\n",
( ( char * ) ( cell->payload.vectorp.tag.bytes ) ) );
} else {
debug_println( DEBUG_ALLOC);
debug_println( DEBUG_ALLOC );
}
#endif
@ -119,8 +130,8 @@ struct cons_pointer c_type( struct cons_pointer pointer ) {
* strings made with NIL termination. The question is which should be
* fixed, and actually that's probably strings read by `read`. However,
* for now, it was easier to add a null character here. */
struct cons_pointer result = make_string( (wchar_t) 0, NIL);
struct cons_space_object * cell = &pointer2cell( pointer );
struct cons_pointer result = make_string( ( wchar_t ) 0, NIL );
struct cons_space_object *cell = &pointer2cell( pointer );
if ( cell->tag.value == VECTORPOINTTV ) {
struct vector_space_object *vec = pointer_to_vso( pointer );
@ -337,8 +348,8 @@ struct cons_pointer make_string_like_thing( wint_t c, struct cons_pointer tail,
cell->payload.string.cdr = tail;
cell->payload.string.hash = calculate_hash( c, tail );
debug_dump_object( pointer, DEBUG_ALLOC);
debug_println( DEBUG_ALLOC);
debug_dump_object( pointer, DEBUG_ALLOC );
debug_println( DEBUG_ALLOC );
} else {
// \todo should throw an exception!
debug_printf( DEBUG_ALLOC,

8
src/memory/dump.c
View file

@ -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 );

2
src/memory/dump.h
View file

@ -19,6 +19,8 @@
#ifndef __dump_h
#define __dump_h
void dump_string_cell( URL_FILE * output, wchar_t *prefix,
struct cons_pointer pointer );
void dump_object( URL_FILE * output, struct cons_pointer pointer );

29
src/memory/stack.c
View file

@ -122,8 +122,7 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
if ( nilp( result ) ) {
/* i.e. out of memory */
result =
make_exception( privileged_string_memory_exhausted,
previous );
make_exception( privileged_string_memory_exhausted, previous );
} else {
struct stack_frame *frame = get_stack_frame( result );
@ -234,7 +233,7 @@ void free_stack_frame( struct stack_frame *frame ) {
debug_print( L"Leaving free_stack_frame\n", DEBUG_ALLOC );
}
struct cons_pointer frame_get_previous( struct cons_pointer frame_pointer) {
struct cons_pointer frame_get_previous( struct cons_pointer frame_pointer ) {
struct stack_frame *frame = get_stack_frame( frame_pointer );
struct cons_pointer result = NIL;
@ -245,27 +244,31 @@ struct cons_pointer frame_get_previous( struct cons_pointer frame_pointer) {
return result;
}
void dump_frame_context_fragment( URL_FILE *output, struct cons_pointer frame_pointer) {
void dump_frame_context_fragment( URL_FILE *output,
struct cons_pointer frame_pointer ) {
struct stack_frame *frame = get_stack_frame( frame_pointer );
if ( frame != NULL ) {
url_fwprintf( output, L" <= ");
print( output, frame->arg[0]);
url_fwprintf( output, L" <= " );
print( output, frame->arg[0] );
}
}
void dump_frame_context( URL_FILE *output, struct cons_pointer frame_pointer, int depth ) {
void dump_frame_context( URL_FILE *output, struct cons_pointer frame_pointer,
int depth ) {
struct stack_frame *frame = get_stack_frame( frame_pointer );
if ( frame != NULL ) {
url_fwprintf( output, L"\tContext: ");
url_fwprintf( output, L"\tContext: " );
int i = 0;
for (struct cons_pointer cursor = frame_pointer; i++ < depth && !nilp( cursor); cursor = frame_get_previous( cursor)) {
dump_frame_context_fragment( output, cursor);
for ( struct cons_pointer cursor = frame_pointer;
i++ < depth && !nilp( cursor );
cursor = frame_get_previous( cursor ) ) {
dump_frame_context_fragment( output, cursor );
}
url_fwprintf( output, L"\n");
url_fwprintf( output, L"\n" );
}
}
@ -280,7 +283,7 @@ void dump_frame( URL_FILE *output, struct cons_pointer frame_pointer ) {
if ( frame != NULL ) {
url_fwprintf( output, L"Stack frame with %d arguments:\n",
frame->args );
dump_frame_context( output, frame_pointer, 4);
dump_frame_context( output, frame_pointer, 4 );
for ( int arg = 0; arg < frame->args; arg++ ) {
struct cons_space_object cell = pointer2cell( frame->arg[arg] );

5
src/memory/vectorspace.c
View file

@ -126,8 +126,9 @@ struct cons_pointer make_vso( uint32_t tag, uint64_t payload_size ) {
void free_vso( struct cons_pointer pointer ) {
struct cons_space_object cell = pointer2cell( pointer );
debug_printf( DEBUG_ALLOC, L"About to free vector-space object of type %s at 0x%lx\n",
(char *) cell.payload.vectorp.tag.bytes,
debug_printf( DEBUG_ALLOC,
L"About to free vector-space object of type %s at 0x%lx\n",
( char * ) cell.payload.vectorp.tag.bytes,
cell.payload.vectorp.address );
struct vector_space_object *vso = cell.payload.vectorp.address;

76
src/ops/equal.c
View file

@ -263,17 +263,18 @@ bool equal_number_number( struct cons_pointer a, struct cons_pointer b ) {
* @return false otherwise.
*/
bool equal_map_map( struct cons_pointer a, struct cons_pointer b ) {
bool result=false;
bool result = false;
struct cons_pointer keys_a = hashmap_keys( a);
if ( c_length( keys_a) == c_length( hashmap_keys( b))) {
struct cons_pointer keys_a = hashmap_keys( a );
if ( c_length( keys_a ) == c_length( hashmap_keys( b ) ) ) {
result = true;
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))) {
result = false; break;
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 ) ) ) {
result = false;
break;
}
}
}
@ -298,23 +299,23 @@ bool equal_map_map( struct cons_pointer a, struct cons_pointer b ) {
bool equal_vector_vector( struct cons_pointer a, struct cons_pointer b ) {
bool result = false;
if ( eq( a, b)) {
result = true; // same
if ( eq( a, b ) ) {
result = true; // same
/* there shouldn't ever be two separate VECP cells which point to the
* same address in vector space, so I don't believe it's worth checking
* for this.
*/
} else if ( vectorp( a) && vectorp( b)) {
struct vector_space_object * va = pointer_to_vso( a);
struct vector_space_object * vb = pointer_to_vso( b);
} else if ( vectorp( a ) && vectorp( b ) ) {
struct vector_space_object *va = pointer_to_vso( a );
struct vector_space_object *vb = pointer_to_vso( b );
/* what we're saying here is that a namespace is not equal to a map,
* even if they have identical logical structure. Is this right? */
if ( va->header.tag.value == vb->header.tag.value) {
switch ( va->header.tag.value) {
if ( va->header.tag.value == vb->header.tag.value ) {
switch ( va->header.tag.value ) {
case HASHTV:
case NAMESPACETV:
result = equal_map_map( a, b);
result = equal_map_map( a, b );
break;
}
}
@ -334,9 +335,9 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
debug_print( L" = ", DEBUG_ARITH );
debug_print_object( b, DEBUG_ARITH );
bool result = false;
if ( eq( a, b )) {
bool result = false;
if ( eq( a, b ) ) {
result = true;
} else if ( !numberp( a ) && same_type( a, b ) ) {
struct cons_space_object *cell_a = &pointer2cell( a );
@ -364,42 +365,47 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
/* TODO: it is not OK to do this on the stack since list-like
* structures can be of indefinite extent. It *must* be done by
* iteration (and even that is problematic) */
if (cell_a->payload.string.hash == cell_b->payload.string.hash) {
wchar_t a_buff[ STRING_SHIPYARD_SIZE], b_buff[ STRING_SHIPYARD_SIZE];
if ( cell_a->payload.string.hash ==
cell_b->payload.string.hash ) {
wchar_t a_buff[STRING_SHIPYARD_SIZE],
b_buff[STRING_SHIPYARD_SIZE];
uint32_t tag = cell_a->tag.value;
int i = 0;
memset(a_buff,0,sizeof(a_buff));
memset(b_buff,0,sizeof(b_buff));
memset( a_buff, 0, sizeof( a_buff ) );
memset( b_buff, 0, sizeof( b_buff ) );
for (; (i < (STRING_SHIPYARD_SIZE - 1)) && !nilp( a) && !nilp( b); i++) {
for ( ;
( i < ( STRING_SHIPYARD_SIZE - 1 ) ) && !nilp( a )
&& !nilp( b ); i++ ) {
a_buff[i] = cell_a->payload.string.character;
a = c_cdr(a);
a = c_cdr( a );
cell_a = &pointer2cell( a );
b_buff[i] = cell_b->payload.string.character;
b = c_cdr( b);
cell_b = &pointer2cell( b);
b = c_cdr( b );
cell_b = &pointer2cell( b );
}
#ifdef DEBUG
debug_print( L"Comparing '", DEBUG_ARITH);
debug_print( a_buff, DEBUG_ARITH);
debug_print( L"' to '", DEBUG_ARITH);
debug_print( b_buff, DEBUG_ARITH);
debug_print( L"'\n", DEBUG_ARITH);
debug_print( L"Comparing '", DEBUG_ARITH );
debug_print( a_buff, DEBUG_ARITH );
debug_print( L"' to '", DEBUG_ARITH );
debug_print( b_buff, DEBUG_ARITH );
debug_print( L"'\n", DEBUG_ARITH );
#endif
/* OK, now we have wchar string buffers loaded from the objects. We
* may not have exhausted either string, so the buffers being equal
* isn't sufficient. So we recurse at least once. */
result = (wcsncmp( a_buff, b_buff, i) == 0) && equal( c_cdr(a), c_cdr(b));
result = ( wcsncmp( a_buff, b_buff, i ) == 0 )
&& equal( c_cdr( a ), c_cdr( b ) );
}
break;
case VECTORPOINTTV:
if ( cell_b->tag.value == VECTORPOINTTV) {
result = equal_vector_vector( a, b);
if ( cell_b->tag.value == VECTORPOINTTV ) {
result = equal_vector_vector( a, b );
} else {
result = false;
}

35
src/ops/intern.c
View file

@ -310,7 +310,8 @@ internedp( struct cons_pointer key, struct cons_pointer store ) {
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_printf( DEBUG_BIND, L"%4.4s",
( char * ) pointer2cell( key ).tag.bytes );
debug_print( L", not a KEYW or SYMB", DEBUG_BIND );
}
@ -328,12 +329,12 @@ 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 ( !nilp( key ) ) {
if ( consp( store ) ) {
for ( struct cons_pointer next = store;
nilp( result ) && ( consp( next ) || hashmapp( next ) );
next = pointer2cell( next ).payload.cons.cdr ) {
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 );
@ -355,9 +356,9 @@ struct cons_pointer c_assoc( struct cons_pointer key,
break;
default:
throw_exception( c_append
( c_string_to_lisp_string
( L"Store entry is of unknown type: " ),
c_type( entry_ptr ) ), NIL );
( c_string_to_lisp_string
( L"Store entry is of unknown type: " ),
c_type( entry_ptr ) ), NIL );
}
// #ifdef DEBUG
@ -379,9 +380,9 @@ struct cons_pointer c_assoc( struct cons_pointer key,
// #endif
result =
throw_exception( c_append
( c_string_to_lisp_string
( L"Store is of unknown type: " ),
c_type( store ) ), NIL );
( c_string_to_lisp_string
( L"Store is of unknown type: " ),
c_type( store ) ), NIL );
}
}
@ -410,7 +411,7 @@ struct cons_pointer hashmap_put( struct cons_pointer mapp,
map->payload.hashmap.buckets[bucket_no] =
make_cons( make_cons( key, val ),
map->payload.hashmap.buckets[bucket_no] );
map->payload.hashmap.buckets[bucket_no] );
}
return mapp;
@ -425,13 +426,13 @@ struct cons_pointer set( struct cons_pointer key, struct cons_pointer value,
struct cons_pointer result = NIL;
#ifdef DEBUG
bool deep = vectorpointp( store);
debug_print_binding( key, value, deep, DEBUG_BIND);
bool deep = vectorpointp( store );
debug_print_binding( key, value, deep, DEBUG_BIND );
if (deep) {
if ( deep ) {
debug_printf( DEBUG_BIND, L"\t-> %4.4s\n",
pointer2cell(store).payload.vectorp.tag.bytes );
}
pointer2cell( store ).payload.vectorp.tag.bytes );
}
#endif
if ( nilp( value ) ) {
result = store;

214
src/ops/lispops.c
View file

@ -251,7 +251,7 @@ struct cons_pointer
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
#ifdef DEBUG
debug_print( L"eval_lambda called\n", DEBUG_LAMBDA );
debug_println( DEBUG_LAMBDA );
#endif
@ -308,7 +308,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
/* if a result is not the terminal result in the lambda, it's a
* side effect, and needs to be GCed */
if ( !nilp( result ) ){
if ( !nilp( result ) ) {
dec_ref( result );
}
@ -446,9 +446,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
result = next_pointer;
} else {
result =
( *fn_cell.payload.special.
executable ) ( get_stack_frame( next_pointer ),
next_pointer, env );
( *fn_cell.payload.
special.executable ) ( get_stack_frame
( next_pointer ),
next_pointer, env );
debug_print( L"Special form returning: ", DEBUG_EVAL );
debug_print_object( result, DEBUG_EVAL );
debug_println( DEBUG_EVAL );
@ -870,15 +871,14 @@ struct cons_pointer lisp_keys( struct stack_frame *frame,
struct cons_pointer lisp_eq( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer result = TRUE;
struct cons_pointer result = TRUE;
if ( frame->args > 1) {
for (int b = 1; ( truep( result )) && (b < frame->args); b++)
{
result = eq( frame->arg[0], fetch_arg( frame, b)) ? TRUE : NIL;
if ( frame->args > 1 ) {
for ( int b = 1; ( truep( result ) ) && ( b < frame->args ); b++ ) {
result = eq( frame->arg[0], fetch_arg( frame, b ) ) ? TRUE : NIL;
}
}
}
return result;
}
@ -895,32 +895,32 @@ struct cons_pointer lisp_eq( struct stack_frame *frame,
struct cons_pointer
lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer result = TRUE;
struct cons_pointer result = TRUE;
if ( frame->args > 1) {
for (int b = 1; ( truep( result )) && (b < frame->args); b++)
{
result = equal( frame->arg[0], fetch_arg( frame, b)) ? TRUE : NIL;
if ( frame->args > 1 ) {
for ( int b = 1; ( truep( result ) ) && ( b < frame->args ); b++ ) {
result =
equal( frame->arg[0], fetch_arg( frame, b ) ) ? TRUE : NIL;
}
}
}
return result;
}
long int c_count (struct cons_pointer p) {
struct cons_space_object * cell = &pointer2cell( p);
long int c_count( struct cons_pointer p ) {
struct cons_space_object *cell = &pointer2cell( p );
int result = 0;
switch (cell->tag.value) {
switch ( cell->tag.value ) {
case CONSTV:
case STRINGTV:
/* I think doctrine is that you cannot treat symbols or keywords as
* sequences, although internally, of course, they are. Integers are
* also internally sequences, but also should not be treated as such.
*/
for (p; !nilp( p); p = c_cdr( p)) {
result ++;
}
/* I think doctrine is that you cannot treat symbols or keywords as
* sequences, although internally, of course, they are. Integers are
* also internally sequences, but also should not be treated as such.
*/
for ( p; !nilp( p ); p = c_cdr( p ) ) {
result++;
}
}
return result;
@ -942,7 +942,7 @@ long int c_count (struct cons_pointer p) {
struct cons_pointer
lisp_count( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return acquire_integer( c_count( frame->arg[ 0]), NIL);
return acquire_integer( c_count( frame->arg[0] ), NIL );
}
/**
@ -1079,54 +1079,6 @@ struct cons_pointer lisp_inspect( struct stack_frame *frame,
return result;
}
/**
* Function; print one complete lisp expression and return NIL. If write-stream is specified and
* is a write stream, then print to that stream, else the stream which is the value of
* `*out*` in the environment.
*
* * (print expr)
* * (print expr write-stream)
*
* @param frame my stack_frame.
* @param frame_pointer a pointer to my stack_frame.
* @param env my environment (from which the stream may be extracted).
* @return NIL.
*/
struct cons_pointer
lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
debug_print( L"Entering print\n", DEBUG_IO );
struct cons_pointer result = NIL;
URL_FILE *output;
struct cons_pointer out_stream = writep( frame->arg[1] ) ?
frame->arg[1] : get_default_stream( false, env );
if ( writep( out_stream ) ) {
debug_print( L"lisp_print: setting output stream\n", DEBUG_IO );
debug_dump_object( out_stream, DEBUG_IO );
output = pointer2cell( out_stream ).payload.stream.stream;
inc_ref( out_stream );
} else {
output = file_to_url_file( stderr );
}
debug_print( L"lisp_print: about to print\n", DEBUG_IO );
debug_dump_object( frame->arg[0], DEBUG_IO );
result = print( output, frame->arg[0] );
debug_print( L"lisp_print returning\n", DEBUG_IO );
debug_dump_object( result, DEBUG_IO );
if ( writep( out_stream ) ) {
dec_ref( out_stream );
} else {
free( output );
}
return result;
}
/**
* Function: get the Lisp type of the single argument.
@ -1204,37 +1156,41 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer,
* @brief evaluate a single cond clause; if the test part succeeds return a
* pair whose car is TRUE and whose cdr is the value of the action part
*/
struct cons_pointer eval_cond_clause( struct cons_pointer clause,
struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env) {
struct cons_pointer eval_cond_clause( struct cons_pointer clause,
struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer result = NIL;
#ifdef DEBUG
debug_print( L"\n\tCond clause: ", DEBUG_EVAL );
debug_print_object( clause, DEBUG_EVAL );
debug_println( DEBUG_EVAL);
debug_println( DEBUG_EVAL );
#endif
if (consp(clause)) {
struct cons_pointer val = eval_form( frame, frame_pointer, c_car( clause ),
env );
if ( consp( clause ) ) {
struct cons_pointer val =
eval_form( frame, frame_pointer, c_car( clause ),
env );
if (!nilp( val)) {
result = make_cons( TRUE, c_progn( frame, frame_pointer, c_cdr( clause ),
env ));
if ( !nilp( val ) ) {
result =
make_cons( TRUE,
c_progn( frame, frame_pointer, c_cdr( clause ),
env ) );
#ifdef DEBUG
debug_print(L"\n\t\tclause succeeded; returning: ", DEBUG_EVAL);
debug_print_object( result, DEBUG_EVAL);
debug_println( DEBUG_EVAL);
debug_print( L"\n\t\tclause succeeded; returning: ", DEBUG_EVAL );
debug_print_object( result, DEBUG_EVAL );
debug_println( DEBUG_EVAL );
} else {
debug_print(L"\n\t\tclause failed.\n", DEBUG_EVAL);
debug_print( L"\n\t\tclause failed.\n", DEBUG_EVAL );
#endif
}
}
} else {
result = throw_exception( c_string_to_lisp_string
( L"Arguments to `cond` must be lists" ),
frame_pointer );
( L"Arguments to `cond` must be lists" ),
frame_pointer );
}
return result;
@ -1259,21 +1215,21 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer result = NIL;
bool done = false;
for ( int i = 0; (i < frame->args) && !done; i++ ) {
struct cons_pointer clause_pointer = fetch_arg( frame, i);
for ( int i = 0; ( i < frame->args ) && !done; i++ ) {
struct cons_pointer clause_pointer = fetch_arg( frame, i );
result = eval_cond_clause( clause_pointer, frame, frame_pointer, env);
result = eval_cond_clause( clause_pointer, frame, frame_pointer, env );
if ( !nilp( result ) && truep( c_car( result)) ) {
result = c_cdr( result);
if ( !nilp( result ) && truep( c_car( result ) ) ) {
result = c_cdr( result );
done = true;
break;
}
}
}
#ifdef DEBUG
debug_print( L"\tCond returning: ", DEBUG_EVAL );
debug_print_object( result, DEBUG_EVAL );
debug_println( DEBUG_EVAL);
debug_println( DEBUG_EVAL );
#endif
return result;
@ -1330,7 +1286,8 @@ 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->
previous );
}
/**
@ -1426,7 +1383,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
if ( exceptionp( expr )
&& url_feof( pointer2cell( input ).payload.stream.stream ) ) {
/* suppress printing end of stream exception */
dec_ref( expr);
dec_ref( expr );
break;
}
@ -1513,13 +1470,14 @@ 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 );
}
@ -1632,13 +1590,13 @@ struct cons_pointer lisp_let( struct stack_frame *frame,
struct cons_pointer symbol = c_car( pair );
if ( symbolp( symbol ) ) {
struct cons_pointer val = eval_form( frame, frame_pointer, c_cdr( pair ),
bindings );
struct cons_pointer val =
eval_form( frame, frame_pointer, c_cdr( pair ),
bindings );
debug_print_binding( symbol, val, false, DEBUG_BIND);
debug_print_binding( symbol, val, false, DEBUG_BIND );
bindings =
make_cons( make_cons( symbol, val ), bindings );
bindings = make_cons( make_cons( symbol, val ), bindings );
} else {
result =
throw_exception( c_string_to_lisp_string
@ -1648,7 +1606,7 @@ struct cons_pointer lisp_let( struct stack_frame *frame,
}
}
debug_print( L"\nlet: bindings complete.\n", DEBUG_BIND);
debug_print( L"\nlet: bindings complete.\n", DEBUG_BIND );
/* i.e., no exception yet */
for ( int form = 1; !exceptionp( result ) && form < frame->args; form++ ) {
@ -1676,13 +1634,13 @@ struct cons_pointer lisp_let( struct stack_frame *frame,
* @return struct cons_pointer a pointer to the result
*/
struct cons_pointer lisp_and( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
bool accumulator = true;
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
bool accumulator = true;
struct cons_pointer result = frame->more;
for ( int a = 0; accumulator == true && a < frame->args; a++) {
accumulator = truthy( fetch_arg( frame, a));
for ( int a = 0; accumulator == true && a < frame->args; a++ ) {
accumulator = truthy( fetch_arg( frame, a ) );
}
#
return accumulator ? TRUE : NIL;
@ -1697,13 +1655,13 @@ struct cons_pointer lisp_and( struct stack_frame *frame,
* @return struct cons_pointer a pointer to the result
*/
struct cons_pointer lisp_or( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
bool accumulator = false;
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
bool accumulator = false;
struct cons_pointer result = frame->more;
for ( int a = 0; accumulator == false && a < frame->args; a++) {
accumulator = truthy( fetch_arg( frame, a));
for ( int a = 0; accumulator == false && a < frame->args; a++ ) {
accumulator = truthy( fetch_arg( frame, a ) );
}
return accumulator ? TRUE : NIL;
@ -1718,7 +1676,7 @@ struct cons_pointer lisp_or( struct stack_frame *frame,
* @return struct cons_pointer `t` if the first argument is `nil`, else `nil`.
*/
struct cons_pointer lisp_not( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return nilp( frame->arg[0]) ? TRUE : NIL;
}
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return nilp( frame->arg[0] ) ? TRUE : NIL;
}

15
src/ops/lispops.h
View file

@ -137,9 +137,6 @@ struct cons_pointer lisp_eq( struct stack_frame *frame,
struct cons_pointer lisp_equal( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_print( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_read( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
@ -231,14 +228,14 @@ struct cons_pointer lisp_try( struct stack_frame *frame,
struct cons_pointer lisp_and( 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 lisp_or( 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 lisp_not( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer frame_pointer,
struct cons_pointer env );
#endif