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

Ran a 'make format', because !'m close to being able to merge this feature.

Browse source
This commit is contained in:
Simon Brooke 2026-05-06 16:45:56 +01:00
parent 5e64a33965
commit 80049f2272
52 changed files with 936 additions and 843 deletions
Download patch file Download diff file Expand all files Collapse all files

7
src/c/environment/environment.c
View file

@ -105,8 +105,11 @@ struct pso_pointer initialise_environment( uint32_t node ) {
initialise_privileged_keywords( frame_pointer ); initialise_privileged_keywords( frame_pointer );
result = inc_ref( initialise_function_bindings(push_local( result =
frame_pointer, make_frame_with_env(0, frame_pointer, result)))); inc_ref( initialise_function_bindings
( push_local
( frame_pointer,
make_frame_with_env( 0, frame_pointer, result ) ) ) );
dec_ref( frame_pointer ); dec_ref( frame_pointer );
} }

66
src/c/environment/function_bindings.c
View file

@ -65,14 +65,19 @@ bind_function(struct pso_pointer frame_pointer, wchar_t *name, wchar_t *doc,
struct pso_pointer n = c_string_to_lisp_symbol( frame_pointer, name ); struct pso_pointer n = c_string_to_lisp_symbol( frame_pointer, name );
struct pso_pointer d = c_string_to_lisp_string( frame_pointer, doc ); struct pso_pointer d = c_string_to_lisp_string( frame_pointer, doc );
struct pso_pointer meta = make_cons( struct pso_pointer meta = make_cons( frame_pointer,
frame_pointer,
make_cons(frame_pointer, privileged_keyword_layer, privileged_keyword_bootstrap),
make_cons( frame_pointer, make_cons( frame_pointer,
make_cons(frame_pointer, privileged_keyword_name, n), privileged_keyword_layer,
privileged_keyword_bootstrap ),
make_cons( frame_pointer, make_cons( frame_pointer,
make_cons( frame_pointer, make_cons( frame_pointer,
privileged_keyword_documentation, d), privileged_keyword_name,
n ),
make_cons( frame_pointer,
make_cons
( frame_pointer,
privileged_keyword_documentation,
d ),
nil ) ) ); nil ) ) );
struct pso_pointer r = make_function( frame_pointer, meta, executable ); struct pso_pointer r = make_function( frame_pointer, meta, executable );
@ -81,7 +86,8 @@ bind_function(struct pso_pointer frame_pointer, wchar_t *name, wchar_t *doc,
if ( !exceptionp( r ) ) { if ( !exceptionp( r ) ) {
debug_print( L"... bound\n", DEBUG_BOOTSTRAP, 0 ); debug_print( L"... bound\n", DEBUG_BOOTSTRAP, 0 );
result = result =
make_cons(frame_pointer, make_cons(frame_pointer, n, r), result); make_cons( frame_pointer, make_cons( frame_pointer, n, r ),
result );
} else { } else {
debug_print( L"... failed to bind\n", DEBUG_BOOTSTRAP, 0 ); debug_print( L"... failed to bind\n", DEBUG_BOOTSTRAP, 0 );
} }
@ -100,14 +106,19 @@ bind_special(struct pso_pointer frame_pointer, wchar_t *name, wchar_t *doc,
struct pso_pointer n = c_string_to_lisp_symbol( frame_pointer, name ); struct pso_pointer n = c_string_to_lisp_symbol( frame_pointer, name );
struct pso_pointer d = c_string_to_lisp_string( frame_pointer, doc ); struct pso_pointer d = c_string_to_lisp_string( frame_pointer, doc );
struct pso_pointer meta = make_cons( struct pso_pointer meta = make_cons( frame_pointer,
frame_pointer,
make_cons(frame_pointer, privileged_keyword_bootstrap, nil),
make_cons( frame_pointer, make_cons( frame_pointer,
make_cons(frame_pointer, privileged_keyword_name, n), privileged_keyword_bootstrap,
nil ),
make_cons( frame_pointer, make_cons( frame_pointer,
make_cons( frame_pointer, make_cons( frame_pointer,
privileged_keyword_documentation, d), privileged_keyword_name,
n ),
make_cons( frame_pointer,
make_cons
( frame_pointer,
privileged_keyword_documentation,
d ),
nil ) ) ); nil ) ) );
struct pso_pointer r = make_special( frame_pointer, meta, executable ); struct pso_pointer r = make_special( frame_pointer, meta, executable );
@ -116,7 +127,8 @@ bind_special(struct pso_pointer frame_pointer, wchar_t *name, wchar_t *doc,
if ( !exceptionp( r ) ) { if ( !exceptionp( r ) ) {
debug_print( L"... bound\n", DEBUG_BOOTSTRAP, 0 ); debug_print( L"... bound\n", DEBUG_BOOTSTRAP, 0 );
result = result =
make_cons(frame_pointer, make_cons(frame_pointer, n, r), result); make_cons( frame_pointer, make_cons( frame_pointer, n, r ),
result );
} else { } else {
debug_print( L"... failed to bind\n", DEBUG_BOOTSTRAP, 0 ); debug_print( L"... failed to bind\n", DEBUG_BOOTSTRAP, 0 );
} }
@ -149,8 +161,7 @@ struct function_data function_initialisers[] = {
L"(slurp stream): read the whole contents of this `stream`, " L"(slurp stream): read the whole contents of this `stream`, "
L"which may " L"which may "
L"be an open stream open for reading or a URL, into a string, and return " L"be an open stream open for reading or a URL, into a string, and return "
L"the " L"the " L"string.",
L"string.",
&lisp_slurp}, &lisp_slurp},
#endif #endif
#ifdef __psse_io_peek_h #ifdef __psse_io_peek_h
@ -272,8 +283,7 @@ struct function_data function_initialisers[] = {
&nilp}, &nilp},
{L"not", {L"not",
L"(not expression): returns `t` unless `expression` evaluates to `nil`, " L"(not expression): returns `t` unless `expression` evaluates to `nil`, "
L"else " L"else " L"`nil`.",
L"`nil`.",
&not}, &not},
{L"or", {L"or",
L"(or expressions...): returns `nil` if every one of these `expressions...` " L"(or expressions...): returns `nil` if every one of these `expressions...` "
@ -285,7 +295,8 @@ struct function_data function_initialisers[] = {
&truep}, &truep},
#endif #endif
{L"END MARKER", L"END MARKER", NULL}}; {L"END MARKER", L"END MARKER", NULL}
};
/* right, the problem with all those pretty '#ifdefs' which might allow us to /* right, the problem with all those pretty '#ifdefs' which might allow us to
* simply switch functions on and off just by including or not including .h * simply switch functions on and off just by including or not including .h
@ -311,7 +322,8 @@ struct function_data special_initialisers[] = {
L"evaluation.", L"evaluation.",
&quote}, &quote},
#endif #endif
{L"END MARKER", L"END MARKER", NULL}}; {L"END MARKER", L"END MARKER", NULL}
};
struct pso_pointer struct pso_pointer
initialise_function_bindings( struct pso_pointer frame_pointer ) { initialise_function_bindings( struct pso_pointer frame_pointer ) {
@ -319,16 +331,22 @@ initialise_function_bindings(struct pso_pointer frame_pointer) {
for ( int i = 0; function_initialisers[i].executable != NULL; i++ ) { for ( int i = 0; function_initialisers[i].executable != NULL; i++ ) {
struct pso_pointer b = c_car( bind_function( frame_pointer, struct pso_pointer b = c_car( bind_function( frame_pointer,
function_initialisers[i].name, function_initialisers[i].
function_initialisers[i].documentation, name,
function_initialisers[i].executable)); function_initialisers[i].
documentation,
function_initialisers[i].
executable ) );
result = make_cons( frame_pointer, b, result ); result = make_cons( frame_pointer, b, result );
} }
for ( int i = 0; special_initialisers[i].executable != NULL; i++ ) { for ( int i = 0; special_initialisers[i].executable != NULL; i++ ) {
struct pso_pointer b = c_car( bind_special( frame_pointer, struct pso_pointer b = c_car( bind_special( frame_pointer,
special_initialisers[i].name, special_initialisers[i].
special_initialisers[i].documentation, name,
special_initialisers[i].executable)); special_initialisers[i].
documentation,
special_initialisers[i].
executable ) );
result = make_cons( frame_pointer, b, result ); result = make_cons( frame_pointer, b, result );
} }

3
src/c/environment/privileged_keywords.c
View file

@ -63,7 +63,8 @@ struct pso_pointer privileged_keyword_user;
#define load_and_lock(var,val)(var = lock_object(c_string_to_lisp_keyword(frame_pointer, val))) #define load_and_lock(var,val)(var = lock_object(c_string_to_lisp_keyword(frame_pointer, val)))
struct pso_pointer initialise_privileged_keywords(struct pso_pointer frame_pointer) { struct pso_pointer initialise_privileged_keywords( struct pso_pointer
frame_pointer ) {
load_and_lock( privileged_keyword_bootstrap, PK_BOOTSTRAP ); load_and_lock( privileged_keyword_bootstrap, PK_BOOTSTRAP );
load_and_lock( privileged_keyword_documentation, PK_DOCUMENTATION ); load_and_lock( privileged_keyword_documentation, PK_DOCUMENTATION );
load_and_lock( privileged_keyword_layer, PK_LAYER ); load_and_lock( privileged_keyword_layer, PK_LAYER );

8
src/c/io/io.c
View file

@ -371,8 +371,8 @@ struct pso_pointer push_back_character( struct pso_pointer c,
struct pso_pointer result = nil; struct pso_pointer result = nil;
if ( characterp( c ) && readp( r ) ) { if ( characterp( c ) && readp( r ) ) {
if ( url_ungetwc( ( wint_t ) if ( url_ungetwc( ( wint_t )
( pointer_to_object( c )->payload.character. ( pointer_to_object( c )->payload.
character ), character.character ),
pointer_to_object( r )->payload.stream.stream ) >= pointer_to_object( r )->payload.stream.stream ) >=
0 ) { 0 ) {
result = t; result = t;
@ -398,8 +398,8 @@ struct pso_pointer lisp_close( struct pso_pointer frame_pointer) {
struct pso_pointer result = nil; struct pso_pointer result = nil;
if ( readp( fetch_arg( frame, 0 ) ) || writep( fetch_arg( frame, 0 ) ) ) { if ( readp( fetch_arg( frame, 0 ) ) || writep( fetch_arg( frame, 0 ) ) ) {
if ( url_fclose if ( url_fclose
( pointer_to_object( fetch_arg( frame, 0 ) )->payload.stream. ( pointer_to_object( fetch_arg( frame, 0 ) )->payload.
stream ) stream.stream )
== 0 ) { == 0 ) {
result = t; result = t;
} }

3
src/c/io/io.h
View file

@ -25,7 +25,8 @@
extern CURLSH *io_share; extern CURLSH *io_share;
int initialise_io( ); int initialise_io( );
struct pso_pointer initialise_default_streams(struct pso_pointer frame_pointer, struct pso_pointer initialise_default_streams( struct pso_pointer
frame_pointer,
struct pso_pointer env ); struct pso_pointer env );
#define C_IO_IN L"*in*" #define C_IO_IN L"*in*"

1
src/c/io/peek.c
View file

@ -39,4 +39,3 @@ struct pso_pointer peek(struct pso_pointer frame_pointer) {
} }
return result; return result;
} }

19
src/c/io/print.c
View file

@ -83,8 +83,7 @@ struct pso_pointer print_string_like_thing( struct pso_pointer p,
if ( keywordp( p ) || stringp( p ) || symbolp( p ) ) { if ( keywordp( p ) || stringp( p ) || symbolp( p ) ) {
for ( struct pso_pointer cursor = p; !c_nilp( cursor ); for ( struct pso_pointer cursor = p; !c_nilp( cursor );
cursor = pointer_to_object( cursor )->payload.string.cdr ) { cursor = pointer_to_object( cursor )->payload.string.cdr ) {
wchar_t wc = wchar_t wc = pointer_to_object( cursor )->payload.string.character;
pointer_to_object( cursor )->payload.string.character;
write_char( wc, output, escape ); write_char( wc, output, escape );
} }
@ -189,7 +188,8 @@ struct pso_pointer in_write( struct pso_pointer p, URL_FILE *output,
} else { } else {
url_fputws( L"<broken exception :-( >", output ); url_fputws( L"<broken exception :-( >", output );
} }
} break; }
break;
case FUNCTIONTV:{ case FUNCTIONTV:{
struct pso2 *function = pointer_to_object( p ); struct pso2 *function = pointer_to_object( p );
url_fputws( L"<function: ", output ); url_fputws( L"<function: ", output );
@ -282,12 +282,16 @@ struct pso_pointer write( struct pso_pointer frame_pointer ) {
} }
struct pso_pointer c_write( struct pso_pointer frame_pointer, struct pso_pointer c_write( struct pso_pointer frame_pointer,
struct pso_pointer object, struct pso_pointer stream, struct pso_pointer object,
bool escape, bool nl_before, bool nl_after) { struct pso_pointer stream, bool escape,
bool nl_before, bool nl_after ) {
struct pso_pointer next_pointer = struct pso_pointer next_pointer =
push_local(frame_pointer, make_frame(5, frame_pointer, object, stream, escape ? t : nil, push_local( frame_pointer,
make_frame( 5, frame_pointer, object, stream,
escape ? t : nil,
nl_before ? t : nil, nl_after ? t : nil ) ); nl_before ? t : nil, nl_after ? t : nil ) );
struct pso_pointer result = push_local(frame_pointer, write(next_pointer)); struct pso_pointer result =
push_local( frame_pointer, write( next_pointer ) );
return result; return result;
} }
@ -333,4 +337,3 @@ struct pso_pointer princ( struct pso_pointer frame_pointer ) {
return result; return result;
} }

5
src/c/io/print.h
View file

@ -27,8 +27,9 @@ struct pso_pointer in_write( struct pso_pointer p, URL_FILE * output,
bool escape, int indent ); bool escape, int indent );
struct pso_pointer c_write( struct pso_pointer frame_pointer, struct pso_pointer c_write( struct pso_pointer frame_pointer,
struct pso_pointer object, struct pso_pointer stream, struct pso_pointer object,
bool escape, bool nl_before, bool nl_after); struct pso_pointer stream, bool escape,
bool nl_before, bool nl_after );
#define c_print(f,o,s)(c_write(f,o,s,true,true,false)) #define c_print(f,o,s)(c_write(f,o,s,true,true,false))
#define c_princ(f,o,s)(c_write(f,o,s,false,true,false)) #define c_princ(f,o,s)(c_write(f,o,s,false,true,false))

5
src/c/io/read.c
View file

@ -146,7 +146,9 @@ struct pso_pointer read_number( struct pso_pointer frame_pointer ) {
URL_FILE *input = pointer_to_object( stream )->payload.stream.stream; URL_FILE *input = pointer_to_object( stream )->payload.stream.stream;
for ( ; iswdigit( c ) || c == L','; c = url_fgetwc( input ) ) { for ( ; iswdigit( c ) || c == L','; c = url_fgetwc( input ) ) {
if ( iswdigit( c ) ){value = ( value * base ) + ( ( int ) c - ( int ) L'0' );} if ( iswdigit( c ) ) {
value = ( value * base ) + ( ( int ) c - ( int ) L'0' );
}
} }
url_ungetwc( c, input ); url_ungetwc( c, input );
@ -185,7 +187,6 @@ struct pso_pointer read_symbol( struct pso_pointer frame_pointer ) {
url_ungetwc( c, input ); url_ungetwc( c, input );
result = c_reverse( frame_pointer, result ); result = c_reverse( frame_pointer, result );
} }
#ifdef DEBUG #ifdef DEBUG
debug_print( L"\nRead symbol `", DEBUG_IO, 0 ); debug_print( L"\nRead symbol `", DEBUG_IO, 0 );
debug_print_object( result, DEBUG_IO, 0 ); debug_print_object( result, DEBUG_IO, 0 );

39
src/c/memory/dump.c
View file

@ -51,7 +51,8 @@ void dump_string_cell( URL_FILE *output, wchar_t *prefix,
L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n", L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n",
prefix, prefix,
object->payload.string.cdr.page, object->payload.string.cdr.page,
object->payload.string.cdr.offset, object->header.count ); object->payload.string.cdr.offset,
object->header.count );
} else { } else {
url_fwprintf( output, url_fwprintf( output,
L"\t\t%ls cell: character '%lc' (%d) with hash %d; next at page %d offset %d, count %u\n", L"\t\t%ls cell: character '%lc' (%d) with hash %d; next at page %d offset %d, count %u\n",
@ -60,14 +61,18 @@ void dump_string_cell( URL_FILE *output, wchar_t *prefix,
object->payload.string.character, object->payload.string.character,
object->payload.string.hash, object->payload.string.hash,
object->payload.string.cdr.page, object->payload.string.cdr.page,
object->payload.string.cdr.offset, object->header.count ); object->payload.string.cdr.offset,
object->header.count );
url_fwprintf( output, L"\t\t value: " ); url_fwprintf( output, L"\t\t value: " );
in_write( pointer, output, false, 0 ); in_write( pointer, output, false, 0 );
if ( stringlikep( pointer ) ) { if ( stringlikep( pointer ) ) {
url_fwprintf( output, L"\n\t\t structure: " ); url_fwprintf( output, L"\n\t\t structure: " );
for ( struct pso_pointer cursor = pointer; !c_nilp(cursor); cursor = c_cdr(cursor)) { for ( struct pso_pointer cursor = pointer; !c_nilp( cursor );
wint_t c = pointer_to_object(cursor)->payload.string.character; cursor = c_cdr( cursor ) ) {
char* tag = (pointer_to_object(cursor)->header.tag.bytes.mnemonic); wint_t c =
pointer_to_object( cursor )->payload.string.character;
char *tag =
( pointer_to_object( cursor )->header.tag.bytes.mnemonic );
url_fwprintf( output, L"[%3.3s %lc (%d)]", tag, c, c ); url_fwprintf( output, L"[%3.3s %lc (%d)]", tag, c, c );
} }
} }
@ -98,7 +103,8 @@ void dump_frame_context( URL_FILE *output, struct pso_pointer frame_pointer,
int i = 0; int i = 0;
for ( struct pso_pointer cursor = frame_pointer; for ( struct pso_pointer cursor = frame_pointer;
i++ < depth && !c_nilp( cursor ); i++ < depth && !c_nilp( cursor );
cursor = pointer_to_pso4(cursor)->payload.stack_frame.previous ) { cursor =
pointer_to_pso4( cursor )->payload.stack_frame.previous ) {
dump_frame_context_fragment( output, cursor, 0 ); dump_frame_context_fragment( output, cursor, 0 );
} }
@ -116,14 +122,16 @@ void dump_frame( URL_FILE *output, struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso4 *frame = pointer_to_pso4( frame_pointer );
url_fwprintf( output, L"Stack frame %d with %d arguments:\n", url_fwprintf( output, L"Stack frame %d with %d arguments:\n",
frame->payload.stack_frame.depth, frame->payload.stack_frame.args ); frame->payload.stack_frame.depth,
frame->payload.stack_frame.args );
dump_frame_context( output, frame_pointer, 4 ); dump_frame_context( output, frame_pointer, 4 );
for ( int arg = 0; arg < frame->payload.stack_frame.args; arg++ ) { for ( int arg = 0; arg < frame->payload.stack_frame.args; arg++ ) {
struct pso2 *object = pointer_to_object( fetch_arg( frame, arg ) ); struct pso2 *object = pointer_to_object( fetch_arg( frame, arg ) );
url_fwprintf( output, L"\tArg %d:\t%3.3s\tcount: %10u\tvalue: ", url_fwprintf( output, L"\tArg %d:\t%3.3s\tcount: %10u\tvalue: ",
arg, object->header.tag.bytes.mnemonic[0], object->header.count ); arg, object->header.tag.bytes.mnemonic[0],
object->header.count );
in_write( frame->payload.stack_frame.arg[arg], output, false, 0 ); in_write( frame->payload.stack_frame.arg[arg], output, false, 0 );
url_fputws( L"\n", output ); url_fputws( L"\n", output );
@ -142,8 +150,7 @@ void dump_stack_trace( URL_FILE *output, struct pso_pointer pointer ) {
struct pso3 *exep = pointer_to_pso3( pointer ); struct pso3 *exep = pointer_to_pso3( pointer );
in_write( exep->payload.exception.message, output, false, 0 ); in_write( exep->payload.exception.message, output, false, 0 );
url_fputws( L"\n", output ); url_fputws( L"\n", output );
dump_stack_trace( output, dump_stack_trace( output, exep->payload.exception.stack );
exep->payload.exception.stack );
} else { } else {
while ( stackp( pointer ) ) { while ( stackp( pointer ) ) {
dump_frame( output, pointer ); dump_frame( output, pointer );
@ -184,7 +191,6 @@ struct pso_pointer dump_object( struct pso_pointer frame_pointer ) {
if ( !writep( stream ) ) { if ( !writep( stream ) ) {
stream = lisp_stderr; stream = lisp_stderr;
} }
// URL_FILE* output = file_to_url_file(stderr); // URL_FILE* output = file_to_url_file(stderr);
// url_fputws( L"\ndump_object printing to output stream; metadata: ", output ); // url_fputws( L"\ndump_object printing to output stream; metadata: ", output );
// in_write( pointer_to_object(stream)->payload.stream.meta, output, false, 0 ); // in_write( pointer_to_object(stream)->payload.stream.meta, output, false, 0 );
@ -196,15 +202,16 @@ struct pso_pointer dump_object( struct pso_pointer frame_pointer ) {
if ( c_nilp( pointer ) ) { if ( c_nilp( pointer ) ) {
// the object at (node, 0, 0) ought to have been initialised, but may not // the object at (node, 0, 0) ought to have been initialised, but may not
// have been... // have been...
url_fputws(L"nil of size class 2 at page 0, offset 0, count xxxx\n", output ); url_fputws( L"nil of size class 2 at page 0, offset 0, count xxxx\n",
output );
} else { } else {
struct pso2 *object = pointer_to_object( pointer ); struct pso2 *object = pointer_to_object( pointer );
url_fwprintf( output, L"\t%3.3s (%d) of size class %d at page %d, offset %d count %u\n", url_fwprintf( output,
L"\t%3.3s (%d) of size class %d at page %d, offset %d count %u\n",
object->header.tag.bytes.mnemonic, object->header.tag.bytes.mnemonic,
get_tag_value( pointer ), get_tag_value( pointer ),
object->header.tag.bytes.size_class, object->header.tag.bytes.size_class, pointer.page,
pointer.page, pointer.offset, pointer.offset, object->header.count );
object->header.count );
switch ( get_tag_value( pointer ) ) { switch ( get_tag_value( pointer ) ) {
case CONSTV: case CONSTV:

14
src/c/memory/pso.c
View file

@ -60,8 +60,8 @@ void print_allocation_table( ) {
} }
#endif #endif
struct pso_pointer cheaty_allocate(struct pso_pointer frame_pointer, char *tag, struct pso_pointer cheaty_allocate( struct pso_pointer frame_pointer,
uint8_t size_class); char *tag, uint8_t size_class );
/** /**
* @brief a means of creating a cons cell without using a stack frame, to * @brief a means of creating a cons cell without using a stack frame, to
@ -88,8 +88,8 @@ struct pso_pointer cheaty_make_cons( struct pso_pointer car,
* get excessive spurius missing stack frame warnings. Not to be called * get excessive spurius missing stack frame warnings. Not to be called
* outside this file! * outside this file!
*/ */
struct pso_pointer cheaty_allocate(struct pso_pointer frame_pointer, char *tag, struct pso_pointer cheaty_allocate( struct pso_pointer frame_pointer,
uint8_t size_class) { char *tag, uint8_t size_class ) {
struct pso_pointer result = pop_freelist( size_class ); struct pso_pointer result = pop_freelist( size_class );
#ifdef DEBUG #ifdef DEBUG
debug_printf( DEBUG_ALLOC, 0, debug_printf( DEBUG_ALLOC, 0,
@ -189,8 +189,10 @@ struct pso_pointer inc_ref( struct pso_pointer pointer ) {
L"\nIncremented object of type %3.3s, size class %d, " L"\nIncremented object of type %3.3s, size class %d, "
L"at page %u, offset %u to count %u", ( ( char * ) L"at page %u, offset %u to count %u", ( ( char * )
& &
( object->header.tag. ( object->
bytes.mnemonic header.
tag.bytes.
mnemonic
[0] ) ), [0] ) ),
( int ) object->header.tag.bytes.size_class, ( int ) object->header.tag.bytes.size_class,
pointer.page, pointer.offset, object->header.count ); pointer.page, pointer.offset, object->header.count );

15
src/c/ops/assoc.c
View file

@ -117,14 +117,13 @@ bool c_internedp( struct pso_pointer key, struct pso_pointer store ) {
* *
* @return a pointer to the value of the key in the store, or nil if not found * @return a pointer to the value of the key in the store, or nil if not found
*/ */
struct pso_pointer assoc( struct pso_pointer assoc( struct pso_pointer frame_pointer ) {
struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer key = fetch_arg( frame, 0 );
struct pso_pointer store = or( make_frame( 2, frame_pointer, struct pso_pointer store = or( make_frame( 2, frame_pointer,
fetch_arg( frame, 1 ), fetch_arg( frame, 1 ),
frame->payload. frame->payload.stack_frame.
stack_frame.env ) ); env ) );
return c_assoc( key, store ); return c_assoc( key, store );
} }
@ -145,8 +144,8 @@ struct pso_pointer interned(
struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer key = fetch_arg( frame, 0 );
struct pso_pointer store = or( make_frame( 2, frame_pointer, struct pso_pointer store = or( make_frame( 2, frame_pointer,
fetch_arg( frame, 1 ), fetch_arg( frame, 1 ),
frame->payload. frame->payload.stack_frame.
stack_frame.env ) ); env ) );
return c_interned( key, store ); return c_interned( key, store );
} }
@ -167,8 +166,8 @@ struct pso_pointer internedp(
struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer key = fetch_arg( frame, 0 );
struct pso_pointer store = or( make_frame( 2, frame_pointer, struct pso_pointer store = or( make_frame( 2, frame_pointer,
fetch_arg( frame, 1 ), fetch_arg( frame, 1 ),
frame->payload. frame->payload.stack_frame.
stack_frame.env ) ); env ) );
return c_internedp( key, store ) ? t : nil; return c_internedp( key, store ) ? t : nil;
} }

1
src/c/ops/bind.c
View file

@ -35,4 +35,3 @@ struct pso_pointer lisp_bind( struct pso_pointer frame_pointer ) {
return cons( make_frame( 2, frame_pointer, binding, store ) ); return cons( make_frame( 2, frame_pointer, binding, store ) );
} }

14
src/c/ops/cond.c
View file

@ -41,13 +41,16 @@ struct pso_pointer eval_cond_clause( struct pso_pointer clause,
#endif #endif
if ( consp( clause ) ) { if ( consp( clause ) ) {
struct pso_pointer test_frame = push_local( frame_pointer, make_frame(1, frame_pointer, c_car(clause))); struct pso_pointer test_frame =
push_local( frame_pointer,
make_frame( 1, frame_pointer, c_car( clause ) ) );
struct pso_pointer val = lisp_eval( test_frame ); struct pso_pointer val = lisp_eval( test_frame );
if ( !c_nilp( val ) ) { if ( !c_nilp( val ) ) {
result = result =
make_cons( frame_pointer, t, make_cons( frame_pointer, t,
c_progn( frame, frame_pointer, c_cdr( clause ), env ) ); c_progn( frame, frame_pointer, c_cdr( clause ),
env ) );
#ifdef DEBUG #ifdef DEBUG
debug_print( L"\n\t\tCond clause ", DEBUG_EVAL, 0 ); debug_print( L"\n\t\tCond clause ", DEBUG_EVAL, 0 );
@ -62,9 +65,10 @@ struct pso_pointer eval_cond_clause( struct pso_pointer clause,
#endif #endif
} }
} else { } else {
result = throw_exception( c_string_to_lisp_symbol( frame_pointer, L"cond" ), result =
c_string_to_lisp_string throw_exception( c_string_to_lisp_symbol( frame_pointer, L"cond" ),
(frame_pointer, L"Arguments to `cond` must be lists" ), c_string_to_lisp_string( frame_pointer,
L"Arguments to `cond` must be lists" ),
frame_pointer ); frame_pointer );
} }

181
src/c/ops/eval_apply.c
View file

@ -159,7 +159,8 @@ struct pso_pointer lisp_try( struct pso_pointer frame_pointer) {
struct pso_pointer result = nil; struct pso_pointer result = nil;
struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer body_frame = struct pso_pointer body_frame =
push_local( frame_pointer, make_frame( 1, frame_pointer, fetch_arg( frame, 0 ) ) ); push_local( frame_pointer,
make_frame( 1, frame_pointer, fetch_arg( frame, 0 ) ) );
result = push_local( frame_pointer, lisp_progn( body_frame ) ); result = push_local( frame_pointer, lisp_progn( body_frame ) );
@ -167,16 +168,19 @@ struct pso_pointer lisp_try( struct pso_pointer frame_pointer) {
// TODO: need to put the exception into the environment! // TODO: need to put the exception into the environment!
struct pso_pointer catch_frame = struct pso_pointer catch_frame =
push_local( frame_pointer, make_frame_with_env( 1, frame_pointer, push_local( frame_pointer, make_frame_with_env( 1, frame_pointer,
make_cons( frame_pointer, make_cons
make_cons( frame_pointer, ( frame_pointer,
make_cons
( frame_pointer,
c_string_to_lisp_symbol c_string_to_lisp_symbol
( frame_pointer, ( frame_pointer,
L"*exception*" ), L"*exception*" ),
result ), result ),
fetch_env fetch_env
( frame_pointer ) ), ( frame_pointer ) ),
frame->payload.stack_frame. frame->payload.
arg[1] ) ); stack_frame.arg
[1] ) );
result = push_local( frame_pointer, lisp_progn( catch_frame ) ); result = push_local( frame_pointer, lisp_progn( catch_frame ) );
} }
@ -235,10 +239,10 @@ struct pso_pointer compose_body( struct pso_pointer frame_pointer ) {
* @param env the environment in which it is to be intepreted. * @param env the environment in which it is to be intepreted.
* @return an interpretable function with these `args` and this `body`. * @return an interpretable function with these `args` and this `body`.
*/ */
struct pso_pointer struct pso_pointer lisp_lambda( struct pso_pointer frame_pointer ) {
lisp_lambda( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso4 *frame = pointer_to_pso4( frame_pointer );
return make_lambda( frame_pointer, fetch_arg(frame, 0), compose_body( frame_pointer ) ); return make_lambda( frame_pointer, fetch_arg( frame, 0 ),
compose_body( frame_pointer ) );
} }
/** /**
@ -253,18 +257,17 @@ lisp_lambda( struct pso_pointer frame_pointer ) {
* @return an interpretable special form with these `args` and this `body`. * @return an interpretable special form with these `args` and this `body`.
*/ */
struct pso_pointer struct pso_pointer
lisp_nlambda( struct pso_pointer frame_pointer, lisp_nlambda( struct pso_pointer frame_pointer, struct pso_pointer env ) {
struct pso_pointer env ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso4 *frame = pointer_to_pso4( frame_pointer );
return make_nlambda( frame_pointer, fetch_arg(frame, 0), compose_body( frame_pointer ) ); return make_nlambda( frame_pointer, fetch_arg( frame, 0 ),
compose_body( frame_pointer ) );
} }
/** /**
* Evaluate a lambda or nlambda expression. * Evaluate a lambda or nlambda expression.
*/ */
struct pso_pointer struct pso_pointer eval_lambda( struct pso_pointer frame_pointer ) {
eval_lambda( struct pso_pointer frame_pointer ) {
struct pso_pointer result = nil; struct pso_pointer result = nil;
struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso2 *lambda = pointer_to_object( fetch_arg( frame, 0 ) ); struct pso2 *lambda = pointer_to_object( fetch_arg( frame, 0 ) );
@ -299,12 +302,12 @@ eval_lambda( struct pso_pointer frame_pointer ) {
/* if `names` is a symbol, rather than a list of symbols, /* if `names` is a symbol, rather than a list of symbols,
* then bind a list of the values of args to that symbol. */ * then bind a list of the values of args to that symbol. */
/* \todo eval all the things in frame->payload.stack_frame.more */ /* \todo eval all the things in frame->payload.stack_frame.more */
struct pso_pointer more_frame = inc_ref( struct pso_pointer more_frame = inc_ref( make_frame( 1, frame_pointer,
make_frame(1, frame_pointer, frame->payload.
frame->payload.stack_frame.more)); stack_frame.
more ) );
struct pso_pointer vals = struct pso_pointer vals = eval_forms( more_frame );
eval_forms( more_frame );
for ( int i = args_in_frame - 1; i >= 0; i-- ) { for ( int i = args_in_frame - 1; i >= 0; i-- ) {
struct pso_pointer next = struct pso_pointer next =
@ -421,10 +424,12 @@ struct pso_pointer make_fn_frame(struct pso_pointer previous,
int args = 0; int args = 0;
struct pso_pointer cursor; struct pso_pointer cursor;
for ( cursor = arg_list; consp(cursor) && args < args_in_frame; cursor = c_cdr(cursor)) { for ( cursor = arg_list; consp( cursor ) && args < args_in_frame;
cursor = c_cdr( cursor ) ) {
// Reusing a frame like this is a bit of an abuse but will save allocation churn. // Reusing a frame like this is a bit of an abuse but will save allocation churn.
next_frame->payload.stack_frame.arg[0] = c_car( cursor ); next_frame->payload.stack_frame.arg[0] = c_car( cursor );
new_frame->payload.stack_frame.arg[args++] = inc_ref( lisp_eval( next_pointer) ); new_frame->payload.stack_frame.arg[args++] =
inc_ref( lisp_eval( next_pointer ) );
} }
if ( consp( cursor ) ) { if ( consp( cursor ) ) {
struct pso_pointer more = nil; struct pso_pointer more = nil;
@ -438,7 +443,8 @@ struct pso_pointer make_fn_frame(struct pso_pointer previous,
args++; args++;
} }
new_frame->payload.stack_frame.more = push_local( previous, c_reverse( previous, more)); new_frame->payload.stack_frame.more =
push_local( previous, c_reverse( previous, more ) );
} }
new_frame->payload.stack_frame.args = args; new_frame->payload.stack_frame.args = args;
@ -468,9 +474,11 @@ struct pso_pointer make_special_frame(struct pso_pointer previous,
int args = 0; int args = 0;
struct pso_pointer cursor; struct pso_pointer cursor;
for ( cursor = arg_list; consp(cursor) && args < args_in_frame; cursor = c_cdr(cursor)) { for ( cursor = arg_list; consp( cursor ) && args < args_in_frame;
cursor = c_cdr( cursor ) ) {
// Reusing a frame like this is a bit of an abuse but will save allocation churn. // Reusing a frame like this is a bit of an abuse but will save allocation churn.
new_frame->payload.stack_frame.arg[args++] = inc_ref( c_car(cursor) ); new_frame->payload.stack_frame.arg[args++] =
inc_ref( c_car( cursor ) );
} }
if ( consp( cursor ) ) { if ( consp( cursor ) ) {
@ -493,7 +501,10 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) {
debug_print( L"Entering apply\n", DEBUG_EVAL, 0 ); debug_print( L"Entering apply\n", DEBUG_EVAL, 0 );
struct pso_pointer result = nil; struct pso_pointer result = nil;
struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer fn_frame = inc_ref( make_frame(1, frame_pointer, c_car( frame->payload.stack_frame.arg[0] ))); struct pso_pointer fn_frame =
inc_ref( make_frame
( 1, frame_pointer,
c_car( frame->payload.stack_frame.arg[0] ) ) );
struct pso_pointer fn_pointer = struct pso_pointer fn_pointer =
push_local( frame_pointer, eval_form( fn_frame ) ); push_local( frame_pointer, eval_form( fn_frame ) );
@ -514,19 +525,15 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) {
case FUNCTIONTV: case FUNCTIONTV:
{ {
struct pso_pointer next_pointer = struct pso_pointer next_pointer =
inc_ref( make_fn_frame( frame_pointer, fn_pointer, args )); inc_ref( make_fn_frame
( frame_pointer, fn_pointer, args ) );
if ( exceptionp( next_pointer ) ) { if ( exceptionp( next_pointer ) ) {
result = next_pointer; result = next_pointer;
} else { } else {
result = push_local( frame_pointer, result = push_local( frame_pointer,
maybe_fixup_exception_location( ( * maybe_fixup_exception_location( ( *( fn_cell->payload.function.executable ) )
( fn_cell-> ( next_pointer ), fn_pointer ) );
payload.
function.
executable ) )
(next_pointer ),
fn_pointer ));
dec_ref( next_pointer ); dec_ref( next_pointer );
} }
} }
@ -534,12 +541,14 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) {
case KEYTV:{ case KEYTV:{
struct pso_pointer map_frame = struct pso_pointer map_frame =
inc_ref(make_frame(1, frame_pointer, c_car(args))); inc_ref( make_frame
result = push_local( ( 1, frame_pointer, c_car( args ) ) );
frame_pointer, result =
push_local( frame_pointer,
c_assoc( fn_pointer, c_assoc( fn_pointer,
maybe_fixup_exception_location( maybe_fixup_exception_location
eval_form(map_frame), fn_pointer))); ( eval_form( map_frame ),
fn_pointer ) ) );
} break; } break;
case LAMBDATV: case LAMBDATV:
@ -551,8 +560,7 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) {
result = next_pointer; result = next_pointer;
} else { } else {
struct pso4 *next = pointer_to_pso4( next_pointer ); struct pso4 *next = pointer_to_pso4( next_pointer );
result = result = eval_lambda( next_pointer );
eval_lambda( next_pointer );
if ( !exceptionp( result ) ) { if ( !exceptionp( result ) ) {
dec_ref( next_pointer ); dec_ref( next_pointer );
} }
@ -580,8 +588,7 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) {
result = next_pointer; result = next_pointer;
} else { } else {
struct pso4 *next = pointer_to_pso4( next_pointer ); struct pso4 *next = pointer_to_pso4( next_pointer );
result = result = eval_lambda( next_pointer );
eval_lambda( next_pointer );
dec_ref( next_pointer ); dec_ref( next_pointer );
} }
} }
@ -596,10 +603,7 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) {
result = next_pointer; result = next_pointer;
} else { } else {
result = maybe_fixup_exception_location( ( * result = maybe_fixup_exception_location( ( *
( fn_cell-> ( fn_cell->payload.special.executable ) )
payload.
special.
executable ) )
( next_pointer ), fn_pointer ); ( next_pointer ), fn_pointer );
debug_print( L"Special form returning: ", DEBUG_EVAL, debug_print( L"Special form returning: ", DEBUG_EVAL,
0 ); 0 );
@ -623,8 +627,9 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) {
c_string_to_lisp_string( frame_pointer, buffer ); c_string_to_lisp_string( frame_pointer, buffer );
free( buffer ); free( buffer );
result = result =
throw_exception( c_string_to_lisp_symbol( frame_pointer, L"apply" ), throw_exception( c_string_to_lisp_symbol
message, frame_pointer ); ( frame_pointer, L"apply" ), message,
frame_pointer );
} }
} }
@ -655,8 +660,7 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) {
* * If a special form, passes the cdr of expression to the special form as argument. * * If a special form, passes the cdr of expression to the special form as argument.
* @exception if `expression` is a symbol which is not bound in `env`. * @exception if `expression` is a symbol which is not bound in `env`.
*/ */
struct pso_pointer struct pso_pointer lisp_eval( struct pso_pointer frame_pointer ) {
lisp_eval( struct pso_pointer frame_pointer ) {
debug_print( L"Eval: ", DEBUG_EVAL, 0 ); debug_print( L"Eval: ", DEBUG_EVAL, 0 );
debug_dump_object( frame_pointer, DEBUG_EVAL, 0 ); debug_dump_object( frame_pointer, DEBUG_EVAL, 0 );
@ -669,8 +673,10 @@ lisp_eval( struct pso_pointer frame_pointer ) {
case CONSTV:{ case CONSTV:{
struct pso_pointer next_pointer = struct pso_pointer next_pointer =
push_local( frame_pointer, make_frame( 2, frame_pointer, push_local( frame_pointer, make_frame( 2, frame_pointer,
c_car(result), c_cdr(result))); c_car( result ),
result = push_local(frame_pointer, lisp_apply(next_pointer)); c_cdr( result ) ) );
result =
push_local( frame_pointer, lisp_apply( next_pointer ) );
} break; } break;
case SYMBOLTV: case SYMBOLTV:
@ -682,15 +688,18 @@ lisp_eval( struct pso_pointer frame_pointer ) {
debug_dump_object( fetch_env( frame_pointer ), DEBUG_EVAL, 0 ); debug_dump_object( fetch_env( frame_pointer ), DEBUG_EVAL, 0 );
#endif #endif
struct pso_pointer canonical = struct pso_pointer canonical =
c_interned( frame->payload.stack_frame.arg[0], fetch_env(frame_pointer) ); c_interned( frame->payload.stack_frame.arg[0],
fetch_env( frame_pointer ) );
if ( c_nilp( canonical ) ) { if ( c_nilp( canonical ) ) {
struct pso_pointer message = struct pso_pointer message =
make_cons( frame_pointer, c_string_to_lisp_string make_cons( frame_pointer, c_string_to_lisp_string
( frame_pointer, L"Attempt to take value of unbound symbol." ), ( frame_pointer,
L"Attempt to take value of unbound symbol." ),
frame->payload.stack_frame.arg[0] ); frame->payload.stack_frame.arg[0] );
result = result =
throw_exception( c_string_to_lisp_symbol( frame_pointer, L"eval" ), throw_exception( c_string_to_lisp_symbol
message, frame_pointer ); ( frame_pointer, L"eval" ), message,
frame_pointer );
} else { } else {
result = c_assoc( canonical, env ); result = c_assoc( canonical, env );
// inc_ref( result ); // inc_ref( result );
@ -737,17 +746,22 @@ lisp_quote( struct pso4 *frame, struct pso_pointer frame_pointer,
* @param pointer a pointer to the object whose type is requested. * @param pointer a pointer to the object whose type is requested.
* @return As a Lisp string, the tag of the object which is at that pointer. * @return As a Lisp string, the tag of the object which is at that pointer.
*/ */
struct pso_pointer c_type( struct pso_pointer frame_pointer, struct pso_pointer pointer ) { struct pso_pointer c_type( struct pso_pointer frame_pointer,
struct pso_pointer pointer ) {
/* Strings read by `read` have the null character termination. This means /* Strings read by `read` have the null character termination. This means
* that for the same printable string, the hashcode is different from * that for the same printable string, the hashcode is different from
* strings made with NIL termination. The question is which should be * strings made with NIL termination. The question is which should be
* fixed, and actually that's probably strings read by `read`. However, * fixed, and actually that's probably strings read by `read`. However,
* for now, it was easier to add a null character here. */ * for now, it was easier to add a null character here. */
struct pso_pointer result = make_symbol( frame_pointer, ( wchar_t ) 0, nil ); struct pso_pointer result =
make_symbol( frame_pointer, ( wchar_t ) 0, nil );
struct pso2 *cell = pointer_to_object( pointer ); struct pso2 *cell = pointer_to_object( pointer );
for ( int i = TAGLENGTH - 1; i >= 0; i-- ) { for ( int i = TAGLENGTH - 1; i >= 0; i-- ) {
result = make_symbol( frame_pointer, ( wchar_t ) cell->header.tag.bytes.mnemonic[i], result ); result =
make_symbol( frame_pointer,
( wchar_t ) cell->header.tag.bytes.mnemonic[i],
result );
} }
return result; return result;
@ -761,9 +775,9 @@ struct pso_pointer c_type( struct pso_pointer frame_pointer, struct pso_pointer
* *
* @return As a Lisp symbol, the tag of `expression`. * @return As a Lisp symbol, the tag of `expression`.
*/ */
struct pso_pointer struct pso_pointer lisp_type( struct pso_pointer frame_pointer ) {
lisp_type( struct pso_pointer frame_pointer ) { return c_type( frame_pointer,
return c_type( frame_pointer, fetch_arg( pointer_to_pso4( frame_pointer), 0) ); fetch_arg( pointer_to_pso4( frame_pointer ), 0 ) );
} }
@ -782,9 +796,9 @@ lisp_type( struct pso_pointer frame_pointer ) {
struct pso_pointer lisp_source( struct pso_pointer frame_pointer ) { struct pso_pointer lisp_source( struct pso_pointer frame_pointer ) {
struct pso_pointer result = nil; struct pso_pointer result = nil;
struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso2 *cell = struct pso2 *cell = pointer_to_object( fetch_arg( frame, 0 ) );
pointer_to_object( fetch_arg( frame, 0) ); struct pso_pointer source_key =
struct pso_pointer source_key = c_string_to_lisp_keyword( frame_pointer, L"source" ); c_string_to_lisp_keyword( frame_pointer, L"source" );
switch ( get_tag_value( fetch_arg( frame, 0 ) ) ) { switch ( get_tag_value( fetch_arg( frame, 0 ) ) ) {
case FUNCTIONTV: case FUNCTIONTV:
result = c_assoc( source_key, cell->payload.function.meta ); result = c_assoc( source_key, cell->payload.function.meta );
@ -794,14 +808,16 @@ struct pso_pointer lisp_source( struct pso_pointer frame_pointer) {
break; break;
case LAMBDATV: case LAMBDATV:
result = make_cons( frame_pointer, result = make_cons( frame_pointer,
c_string_to_lisp_symbol( frame_pointer, L"λ" ), c_string_to_lisp_symbol( frame_pointer,
L"λ" ),
make_cons( frame_pointer, make_cons( frame_pointer,
cell->payload.lambda.args, cell->payload.lambda.args,
cell->payload.lambda.body ) ); cell->payload.lambda.body ) );
break; break;
case NLAMBDATV: case NLAMBDATV:
result = make_cons( frame_pointer, result = make_cons( frame_pointer,
c_string_to_lisp_symbol( frame_pointer, L"nλ" ), c_string_to_lisp_symbol( frame_pointer,
L"nλ" ),
make_cons( frame_pointer, make_cons( frame_pointer,
cell->payload.lambda.args, cell->payload.lambda.args,
cell->payload.lambda.body ) ); cell->payload.lambda.body ) );
@ -849,20 +865,25 @@ struct pso_pointer lisp_let( struct pso_pointer frame_pointer ) {
struct pso_pointer pair = c_car( cursor ); struct pso_pointer pair = c_car( cursor );
struct pso_pointer symbol = c_car( pair ); struct pso_pointer symbol = c_car( pair );
struct pso_pointer next_pointer = push_local( frame_pointer, make_frame_with_env( 0, frame_pointer, bindings)); struct pso_pointer next_pointer =
push_local( frame_pointer,
make_frame_with_env( 0, frame_pointer, bindings ) );
if ( symbolp( symbol ) ) { if ( symbolp( symbol ) ) {
add_arg( next_pointer, c_cdr( pair ) ); add_arg( next_pointer, c_cdr( pair ) );
struct pso_pointer val = struct pso_pointer val = eval_form( next_pointer );
eval_form( next_pointer );
// debug_print_binding( symbol, val, false, DEBUG_BIND ); // debug_print_binding( symbol, val, false, DEBUG_BIND );
bindings = make_cons( frame_pointer, make_cons( frame_pointer, symbol, val ), bindings ); bindings =
make_cons( frame_pointer,
make_cons( frame_pointer, symbol, val ), bindings );
} else { } else {
result = result =
throw_exception( c_string_to_lisp_symbol( frame_pointer, L"let" ), throw_exception( c_string_to_lisp_symbol
c_string_to_lisp_string( frame_pointer, L"Let: cannot bind, not a symbol" ), ( frame_pointer, L"let" ),
c_string_to_lisp_string( frame_pointer,
L"Let: cannot bind, not a symbol" ),
frame_pointer ); frame_pointer );
break; break;
} }
@ -871,17 +892,21 @@ struct pso_pointer lisp_let( struct pso_pointer frame_pointer ) {
if ( !exceptionp( result ) ) { if ( !exceptionp( result ) ) {
debug_print( L"\nlet: bindings complete.\n", DEBUG_BIND, 0 ); debug_print( L"\nlet: bindings complete.\n", DEBUG_BIND, 0 );
struct pso_pointer progn_pointer = make_frame_with_env( 0, frame_pointer, bindings); struct pso_pointer progn_pointer =
make_frame_with_env( 0, frame_pointer, bindings );
struct pso4 *progn_frame = pointer_to_pso4( progn_pointer ); struct pso4 *progn_frame = pointer_to_pso4( progn_pointer );
int a = 1; int a = 1;
for ( ; a < frame->payload.stack_frame.args && a < args_in_frame; a++ ) { for ( ; a < frame->payload.stack_frame.args && a < args_in_frame; a++ ) {
progn_frame->payload.stack_frame.arg[a-1] = fetch_arg( frame, a); progn_frame->payload.stack_frame.arg[a - 1] =
fetch_arg( frame, a );
progn_frame->payload.stack_frame.args++; progn_frame->payload.stack_frame.args++;
} }
if ( a < frame->payload.stack_frame.args ) { if ( a < frame->payload.stack_frame.args ) {
progn_frame->payload.stack_frame.arg[a-1] = fetch_arg( frame, a); progn_frame->payload.stack_frame.arg[a - 1] =
progn_frame->payload.stack_frame.more = c_cdr( frame->payload.stack_frame.more); fetch_arg( frame, a );
progn_frame->payload.stack_frame.more =
c_cdr( frame->payload.stack_frame.more );
} }
result = lisp_progn( progn_pointer ); result = lisp_progn( progn_pointer );
@ -904,8 +929,8 @@ struct pso_pointer lisp_and( struct pso4 *frame,
bool accumulator = true; bool accumulator = true;
struct pso_pointer result = frame->payload.stack_frame.more; struct pso_pointer result = frame->payload.stack_frame.more;
for ( int a = 0; accumulator == true && a < frame->payload.stack_frame.args; for ( int a = 0;
a++ ) { accumulator == true && a < frame->payload.stack_frame.args; a++ ) {
accumulator = truthy( fetch_arg( frame, a ) ); accumulator = truthy( fetch_arg( frame, a ) );
} }
# #

5
src/c/ops/keys.c
View file

@ -45,6 +45,7 @@ struct pso_pointer c_keys(struct pso_pointer frame_pointer,
struct pso_pointer lisp_keys( struct pso_pointer frame_pointer ) { struct pso_pointer lisp_keys( struct pso_pointer frame_pointer ) {
return c_keys( frame_pointer, pointer_to_pso4(frame_pointer)->payload.stack_frame.arg[0] ); return c_keys( frame_pointer,
pointer_to_pso4( frame_pointer )->payload.stack_frame.
arg[0] );
} }

1
src/c/ops/list_ops.c
View file

@ -33,4 +33,3 @@ struct pso_pointer count( struct pso_pointer frame_pointer ) {
return acquire_integer( frame_pointer, c ); return acquire_integer( frame_pointer, c );
} }

25
src/c/ops/mapcar.c
View file

@ -31,24 +31,33 @@ struct pso_pointer lisp_mapcar( struct pso_pointer frame_pointer ) {
debug_dump_object( frame_pointer, DEBUG_EVAL, 0 ); debug_dump_object( frame_pointer, DEBUG_EVAL, 0 );
int i = 0; int i = 0;
for ( struct pso_pointer c = frame->payload.stack_frame.arg[1]; c_truep( c ); for ( struct pso_pointer c = frame->payload.stack_frame.arg[1];
c = c_cdr( c ) ) { c_truep( c ); c = c_cdr( c ) ) {
struct pso_pointer expr = struct pso_pointer expr = push_local( frame_pointer,
push_local( frame_pointer, make_cons( frame_pointer,
make_cons( frame_pointer, frame->payload.stack_frame.arg[0], frame->payload.
make_cons( frame_pointer, c_car( c ), nil ) ) ); stack_frame.arg[0],
make_cons
( frame_pointer,
c_car( c ),
nil ) ) );
debug_printf( DEBUG_EVAL, 0, L"Mapcar %d, evaluating ", i ); debug_printf( DEBUG_EVAL, 0, L"Mapcar %d, evaluating ", i );
debug_print_object( expr, DEBUG_EVAL, 0 ); debug_print_object( expr, DEBUG_EVAL, 0 );
debug_println( DEBUG_EVAL ); debug_println( DEBUG_EVAL );
struct pso_pointer r = lisp_eval( push_local( frame_pointer, make_frame(1, frame_pointer, expr))); struct pso_pointer r =
lisp_eval( push_local
( frame_pointer,
make_frame( 1, frame_pointer, expr ) ) );
if ( exceptionp( r ) ) { if ( exceptionp( r ) ) {
result = r; result = r;
break; break;
} else { } else {
result = push_local( frame_pointer, make_cons( frame_pointer, r, result )); result =
push_local( frame_pointer,
make_cons( frame_pointer, r, result ) );
} }
debug_printf( DEBUG_EVAL, 0, L"Mapcar %d, result is ", i++ ); debug_printf( DEBUG_EVAL, 0, L"Mapcar %d, result is ", i++ );
debug_print_object( result, DEBUG_EVAL, 0 ); debug_print_object( result, DEBUG_EVAL, 0 );

6
src/c/ops/progn.c
View file

@ -60,8 +60,7 @@ c_progn( struct pso4 *frame, struct pso_pointer frame_pointer,
* @return the value of the last `expression` of the sequence which is my single * @return the value of the last `expression` of the sequence which is my single
* argument. * argument.
*/ */
struct pso_pointer struct pso_pointer lisp_progn( struct pso_pointer frame_pointer ) {
lisp_progn( struct pso_pointer frame_pointer) {
struct pso_pointer result = nil; struct pso_pointer result = nil;
struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer next_pointer = struct pso_pointer next_pointer =
@ -76,7 +75,8 @@ lisp_progn( struct pso_pointer frame_pointer) {
} }
if ( consp( frame->payload.stack_frame.more ) ) { if ( consp( frame->payload.stack_frame.more ) ) {
result = c_progn(frame, frame_pointer, frame->payload.stack_frame.more, result =
c_progn( frame, frame_pointer, frame->payload.stack_frame.more,
fetch_env( frame_pointer ) ); fetch_env( frame_pointer ) );
} }

3
src/c/ops/progn.h
View file

@ -15,7 +15,8 @@
#include "memory/pointer.h" #include "memory/pointer.h"
#include "memory/pso4.h" #include "memory/pso4.h"
struct pso_pointer c_progn(struct pso4 *frame, struct pso_pointer frame_pointer, struct pso_pointer c_progn( struct pso4 *frame,
struct pso_pointer frame_pointer,
struct pso_pointer expressions, struct pso_pointer expressions,
struct pso_pointer env ); struct pso_pointer env );

18
src/c/ops/reverse.c
View file

@ -49,25 +49,25 @@ struct pso_pointer reverse( struct pso_pointer frame_pointer ) {
case KEYTV: case KEYTV:
result = push_local( frame_pointer, result = push_local( frame_pointer,
make_string_like_thing( frame_pointer, make_string_like_thing( frame_pointer,
object->payload. object->
string.character, payload.string.
result, character, result,
KEYTAG ) ); KEYTAG ) );
break; break;
case STRINGTV: case STRINGTV:
result = push_local( frame_pointer, result = push_local( frame_pointer,
make_string_like_thing( frame_pointer, make_string_like_thing( frame_pointer,
object->payload. object->
string.character, payload.string.
result, character, result,
STRINGTAG ) ); STRINGTAG ) );
break; break;
case SYMBOLTV: case SYMBOLTV:
result = push_local( frame_pointer, result = push_local( frame_pointer,
make_string_like_thing( frame_pointer, make_string_like_thing( frame_pointer,
object->payload. object->
string.character, payload.string.
result, character, result,
SYMBOLTAG ) ); SYMBOLTAG ) );
break; break;
default: default:

4
src/c/ops/string_ops.c
View file

@ -146,8 +146,8 @@ char *lisp_string_to_c_string( struct pso_pointer s ) {
int i = 0; int i = 0;
for ( struct pso_pointer c = s; !c_nilp( c ); c = c_cdr( c ) ) { for ( struct pso_pointer c = s; !c_nilp( c ); c = c_cdr( c ) ) {
buffer[i++] = buffer[i++] =
( wchar_t ) ( pointer_to_object( c )->payload. ( wchar_t ) ( pointer_to_object( c )->payload.string.
string.character ); character );
} }
mbstate_t ps; mbstate_t ps;

11
src/c/payloads/exception.c
View file

@ -130,13 +130,13 @@ struct pso_pointer throw_exception_with_cause( struct pso_pointer location,
if ( get_tag_value( message ) ) { if ( get_tag_value( message ) ) {
result = message; result = message;
} else { } else {
struct pso_pointer x_frame = inc_ref(make_frame( struct pso_pointer x_frame =
2, frame_pointer, message, inc_ref( make_frame( 2, frame_pointer, message,
( c_nilp( location ) ( c_nilp( location )
? nil ? nil : make_cons( frame_pointer,
: make_cons(frame_pointer,
make_cons( frame_pointer, make_cons( frame_pointer,
privileged_keyword_location, location), privileged_keyword_location,
location ),
nil ) ), nil ) ),
cause ) ); cause ) );
@ -162,4 +162,3 @@ throw_exception( struct pso_pointer location,
struct pso_pointer frame_pointer ) { struct pso_pointer frame_pointer ) {
return throw_exception_with_cause( location, payload, nil, frame_pointer ); return throw_exception_with_cause( location, payload, nil, frame_pointer );
} }

9
src/c/payloads/function.c
View file

@ -12,9 +12,12 @@
#include "memory/pso2.h" #include "memory/pso2.h"
#include "memory/tags.h" #include "memory/tags.h"
struct pso_pointer make_function( struct pso_pointer make_function( struct pso_pointer frame_pointer,
struct pso_pointer frame_pointer, struct pso_pointer meta, struct pso_pointer meta,
struct pso_pointer (*executable)(struct pso_pointer frame_pointer)) { struct pso_pointer ( *executable ) ( struct
pso_pointer
frame_pointer ) )
{
struct pso_pointer result = allocate( frame_pointer, FUNCTIONTAG, 2 ); struct pso_pointer result = allocate( frame_pointer, FUNCTIONTAG, 2 );
struct pso2 *object = pointer_to_object( result ); struct pso2 *object = pointer_to_object( result );

8
src/c/payloads/function.h
View file

@ -39,8 +39,10 @@ struct function_payload {
struct pso_pointer ( *executable ) ( struct pso_pointer frame_pointer ); struct pso_pointer ( *executable ) ( struct pso_pointer frame_pointer );
}; };
struct pso_pointer make_function( struct pso_pointer make_function( struct pso_pointer frame_pointer,
struct pso_pointer frame_pointer, struct pso_pointer meta, struct pso_pointer meta,
struct pso_pointer (*executable)(struct pso_pointer frame_pointer)); struct pso_pointer ( *executable ) ( struct
pso_pointer
frame_pointer ) );
#endif #endif

3
src/c/payloads/lambda.c
View file

@ -15,7 +15,8 @@
struct pso_pointer make_lambda_like_thing( struct pso_pointer frame_pointer, struct pso_pointer make_lambda_like_thing( struct pso_pointer frame_pointer,
struct pso_pointer args, struct pso_pointer args,
struct pso_pointer body, char *tag) { struct pso_pointer body,
char *tag ) {
struct pso_pointer result = allocate( frame_pointer, tag, 2 ); struct pso_pointer result = allocate( frame_pointer, tag, 2 );
struct pso2 *object = pointer_to_object( result ); struct pso2 *object = pointer_to_object( result );

3
src/c/payloads/lambda.h
View file

@ -32,7 +32,8 @@ struct lambda_payload {
struct pso_pointer make_lambda_like_thing( struct pso_pointer frame_pointer, struct pso_pointer make_lambda_like_thing( struct pso_pointer frame_pointer,
struct pso_pointer args, struct pso_pointer args,
struct pso_pointer body, char *tag); struct pso_pointer body,
char *tag );
#define make_lambda(f,a,b) (make_lambda_like_thing( f, a, b, LAMBDATAG)) #define make_lambda(f,a,b) (make_lambda_like_thing( f, a, b, LAMBDATAG))
#endif #endif

9
src/c/payloads/special.c
View file

@ -12,9 +12,12 @@
#include "memory/pso2.h" #include "memory/pso2.h"
#include "memory/tags.h" #include "memory/tags.h"
struct pso_pointer make_special( struct pso_pointer make_special( struct pso_pointer frame_pointer,
struct pso_pointer frame_pointer, struct pso_pointer meta, struct pso_pointer meta,
struct pso_pointer (*executable)(struct pso_pointer frame_pointer)) { struct pso_pointer ( *executable ) ( struct
pso_pointer
frame_pointer ) )
{
struct pso_pointer result = allocate( frame_pointer, SPECIALTAG, 2 ); struct pso_pointer result = allocate( frame_pointer, SPECIALTAG, 2 );
struct pso2 *object = pointer_to_object( result ); struct pso2 *object = pointer_to_object( result );

8
src/c/payloads/special.h
View file

@ -22,8 +22,10 @@
* \see NLAMBDATAG. * \see NLAMBDATAG.
*/ */
struct pso_pointer make_special( struct pso_pointer make_special( struct pso_pointer frame_pointer,
struct pso_pointer frame_pointer, struct pso_pointer meta, struct pso_pointer meta,
struct pso_pointer (*executable)(struct pso_pointer frame_pointer)); struct pso_pointer ( *executable ) ( struct
pso_pointer
frame_pointer ) );
#endif #endif

26
src/c/payloads/stack.c
View file

@ -100,17 +100,23 @@ struct pso_pointer push_local( struct pso_pointer frame_pointer,
* *
* @return `nil` on success; potentially an exception on failure. * @return `nil` on success; potentially an exception on failure.
*/ */
struct pso_pointer add_arg( struct pso_pointer frame_pointer, struct pso_pointer arg_pointer) { struct pso_pointer add_arg( struct pso_pointer frame_pointer,
struct pso_pointer arg_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer result = nil; struct pso_pointer result = nil;
if ( frame->payload.stack_frame.args < args_in_frame ) { if ( frame->payload.stack_frame.args < args_in_frame ) {
frame->payload.stack_frame.arg[frame->payload.stack_frame.args++] = push_local(frame_pointer, arg_pointer); frame->payload.stack_frame.arg[frame->payload.stack_frame.args++] =
push_local( frame_pointer, arg_pointer );
} else { } else {
struct pso_pointer new_more = c_reverse( frame_pointer, struct pso_pointer new_more = c_reverse( frame_pointer,
make_cons( frame_pointer, make_cons( frame_pointer,
arg_pointer, arg_pointer,
c_reverse( frame_pointer, frame->payload.stack_frame.more))); c_reverse
( frame_pointer,
frame->payload.
stack_frame.
more ) ) );
if ( exceptionp( new_more ) ) { if ( exceptionp( new_more ) ) {
result = new_more; result = new_more;
} else { } else {
@ -205,7 +211,8 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous,
va_list args; va_list args;
va_start( args, previous ); va_start( args, previous );
struct pso_pointer new_pointer = in_make_frame( arg_count, previous, args); struct pso_pointer new_pointer =
in_make_frame( arg_count, previous, args );
struct pso4 *new_frame = pointer_to_pso4( new_pointer ); struct pso4 *new_frame = pointer_to_pso4( new_pointer );
new_frame->payload.stack_frame.env = stackp( previous ) ? new_frame->payload.stack_frame.env = stackp( previous ) ?
@ -238,7 +245,8 @@ struct pso_pointer make_frame_with_env( int arg_count,
va_list args; va_list args;
va_start( args, env ); va_start( args, env );
struct pso_pointer new_pointer = in_make_frame( arg_count, previous, args); struct pso_pointer new_pointer =
in_make_frame( arg_count, previous, args );
pointer_to_pso4( new_pointer )->payload.stack_frame.env = inc_ref( env ); pointer_to_pso4( new_pointer )->payload.stack_frame.env = inc_ref( env );
va_end( args ); va_end( args );
@ -270,8 +278,8 @@ struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer
struct pso_pointer arg_length = struct pso_pointer arg_length =
count( push_local( previous, make_frame( 1, previous, argvalues ) ) ); count( push_local( previous, make_frame( 1, previous, argvalues ) ) );
int arg_count = int arg_count =
integerp( arg_length ) ? pointer_to_object( arg_length )-> integerp( arg_length ) ? pointer_to_object( arg_length )->payload.
payload.integer.value : 0; integer.value : 0;
#ifdef DEBUG #ifdef DEBUG
debug_printf( DEBUG_ALLOC, 0, debug_printf( DEBUG_ALLOC, 0,
L"\nAllocating stack frame with %d arguments at page %d, " L"\nAllocating stack frame with %d arguments at page %d, "
@ -330,8 +338,8 @@ struct pso_pointer make_frame_with_arglist( struct pso_pointer previous,
struct pso_pointer argvalues ) { struct pso_pointer argvalues ) {
return make_frame_with_arglist_and_env( previous, argvalues, return make_frame_with_arglist_and_env( previous, argvalues,
pointer_to_pso4 pointer_to_pso4
( previous )->payload.stack_frame. ( previous )->payload.
env ); stack_frame.env );
} }

3
src/c/payloads/stack.h
View file

@ -54,6 +54,7 @@ struct pso_pointer make_frame_with_arglist( struct pso_pointer previous,
struct pso_pointer destroy_stack_frame( struct pso_pointer fp, struct pso_pointer destroy_stack_frame( struct pso_pointer fp,
struct pso_pointer env ); struct pso_pointer env );
struct pso_pointer add_arg( struct pso_pointer frame_pointer, struct pso_pointer arg_pointer); struct pso_pointer add_arg( struct pso_pointer frame_pointer,
struct pso_pointer arg_pointer );
#endif #endif