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

13
src/c/environment/environment.c
View file

@ -81,7 +81,7 @@ struct pso_pointer initialise_environment( uint32_t node ) {
} }
} }
if ( !exceptionp( result ) ) { if ( !exceptionp( result ) ) {
frame_pointer = inc_ref( make_frame(0, nil)); frame_pointer = inc_ref( make_frame( 0, nil ) );
result = result =
lisp_bind( make_frame lisp_bind( make_frame
( 3, frame_pointer, ( 3, frame_pointer,
@ -103,12 +103,15 @@ struct pso_pointer initialise_environment( uint32_t node ) {
debug_print( L"\nEnvironment initialised successfully.\n", debug_print( L"\nEnvironment initialised successfully.\n",
DEBUG_BOOTSTRAP, 0 ); DEBUG_BOOTSTRAP, 0 );
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 );
} }
return result; return result;

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

@ -59,31 +59,37 @@
*/ */
struct pso_pointer struct pso_pointer
bind_function(struct pso_pointer frame_pointer, wchar_t *name, wchar_t *doc, bind_function( struct pso_pointer frame_pointer, wchar_t *name, wchar_t *doc,
struct pso_pointer (*executable)(struct pso_pointer)) { struct pso_pointer ( *executable ) ( struct pso_pointer ) ) {
struct pso_pointer result = fetch_env(frame_pointer); struct pso_pointer result = fetch_env( frame_pointer );
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,
make_cons(frame_pointer, privileged_keyword_layer, privileged_keyword_bootstrap), privileged_keyword_layer,
make_cons(frame_pointer, privileged_keyword_bootstrap ),
make_cons(frame_pointer, privileged_keyword_name, n), make_cons( frame_pointer,
make_cons(frame_pointer, make_cons( frame_pointer,
make_cons(frame_pointer, privileged_keyword_name,
privileged_keyword_documentation, d), n ),
nil))); make_cons( frame_pointer,
make_cons
( frame_pointer,
privileged_keyword_documentation,
d ),
nil ) ) );
struct pso_pointer r = make_function(frame_pointer, meta, executable); struct pso_pointer r = make_function( frame_pointer, meta, executable );
debug_print(doc, DEBUG_BOOTSTRAP, 0); debug_print( doc, DEBUG_BOOTSTRAP, 0 );
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 );
} }
return result; return result;
@ -94,31 +100,37 @@ bind_function(struct pso_pointer frame_pointer, wchar_t *name, wchar_t *doc,
* this `name` in the `oblist`. * this `name` in the `oblist`.
*/ */
struct pso_pointer struct pso_pointer
bind_special(struct pso_pointer frame_pointer, wchar_t *name, wchar_t *doc, bind_special( struct pso_pointer frame_pointer, wchar_t *name, wchar_t *doc,
struct pso_pointer (*executable)(struct pso_pointer)) { struct pso_pointer ( *executable ) ( struct pso_pointer ) ) {
struct pso_pointer result = fetch_env(frame_pointer); struct pso_pointer result = fetch_env( frame_pointer );
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,
make_cons(frame_pointer, privileged_keyword_bootstrap, nil), privileged_keyword_bootstrap,
make_cons(frame_pointer, nil ),
make_cons(frame_pointer, privileged_keyword_name, n), make_cons( frame_pointer,
make_cons(frame_pointer, make_cons( frame_pointer,
make_cons(frame_pointer, privileged_keyword_name,
privileged_keyword_documentation, d), n ),
nil))); make_cons( frame_pointer,
make_cons
( frame_pointer,
privileged_keyword_documentation,
d ),
nil ) ) );
struct pso_pointer r = make_special(frame_pointer, meta, executable); struct pso_pointer r = make_special( frame_pointer, meta, executable );
debug_print(doc, DEBUG_BOOTSTRAP, 0); debug_print( doc, DEBUG_BOOTSTRAP, 0 );
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 );
} }
return result; return result;
@ -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,25 +322,32 @@ 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 ) {
struct pso_pointer result = fetch_env(frame_pointer); struct pso_pointer result = fetch_env( 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].
result = make_cons( frame_pointer, b, result); documentation,
function_initialisers[i].
executable ) );
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].
result = make_cons( frame_pointer, b, result); documentation,
special_initialisers[i].
executable ) );
result = make_cons( frame_pointer, b, result );
} }
return result; return result;

2
src/c/environment/function_bindings.h
View file

@ -13,5 +13,5 @@
#define __psse_environment_function_bindings_h #define __psse_environment_function_bindings_h
struct pso_pointer struct pso_pointer
initialise_function_bindings(struct pso_pointer frame_pointer); initialise_function_bindings( struct pso_pointer frame_pointer );
#endif #endif

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

@ -63,12 +63,13 @@ 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
load_and_lock(privileged_keyword_bootstrap, PK_BOOTSTRAP); frame_pointer ) {
load_and_lock(privileged_keyword_documentation, PK_DOCUMENTATION); load_and_lock( privileged_keyword_bootstrap, PK_BOOTSTRAP );
load_and_lock(privileged_keyword_layer, PK_LAYER); load_and_lock( privileged_keyword_documentation, PK_DOCUMENTATION );
load_and_lock(privileged_keyword_location, PK_LOCATION); load_and_lock( privileged_keyword_layer, PK_LAYER );
load_and_lock( privileged_keyword_name, PK_NAME); load_and_lock( privileged_keyword_location, PK_LOCATION );
load_and_lock(privileged_keyword_system, PK_SYSTEM); load_and_lock( privileged_keyword_name, PK_NAME );
load_and_lock(privileged_keyword_user, PK_USER); load_and_lock( privileged_keyword_system, PK_SYSTEM );
load_and_lock( privileged_keyword_user, PK_USER );
} }

2
src/c/environment/privileged_keywords.h
View file

@ -29,5 +29,5 @@ extern struct pso_pointer privileged_keyword_name;
extern struct pso_pointer privileged_keyword_system; extern struct pso_pointer privileged_keyword_system;
extern struct pso_pointer privileged_keyword_user; extern struct pso_pointer privileged_keyword_user;
struct pso_pointer initialise_privileged_keywords( struct pso_pointer env); struct pso_pointer initialise_privileged_keywords( struct pso_pointer env );
#endif /* SRC_C_ENVIRONMENT_PRIVILEGED_KEYWORDS_H_ */ #endif /* SRC_C_ENVIRONMENT_PRIVILEGED_KEYWORDS_H_ */

14
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;
@ -393,13 +393,13 @@ struct pso_pointer push_back_character( struct pso_pointer c,
* @param env my environment. * @param env my environment.
* @return T if the stream was successfully closed, else nil. * @return T if the stream was successfully closed, else nil.
*/ */
struct pso_pointer lisp_close( struct pso_pointer frame_pointer) { struct pso_pointer lisp_close( struct pso_pointer frame_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 ( 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;
} }
@ -593,7 +593,7 @@ URL_FILE *stream_get_url_file( struct pso_pointer s ) {
* @param frame_pointer a pointer to my stack frame. * @param frame_pointer a pointer to my stack frame.
* @return a stream open on the URL indicated by the first argument. * @return a stream open on the URL indicated by the first argument.
*/ */
struct pso_pointer lisp_open( struct pso_pointer frame_pointer) { struct pso_pointer lisp_open( struct pso_pointer frame_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 ( stringp( fetch_arg( frame, 0 ) ) ) { if ( stringp( fetch_arg( frame, 0 ) ) ) {
@ -651,7 +651,7 @@ struct pso_pointer lisp_open( struct pso_pointer frame_pointer) {
* @return return a string representing all characters from the stream * @return return a string representing all characters from the stream
* indicated by arg 0 * indicated by arg 0
*/ */
struct pso_pointer lisp_slurp( struct pso_pointer frame_pointer) { struct pso_pointer lisp_slurp( struct pso_pointer frame_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 ( readp( fetch_arg( frame, 0 ) ) ) { if ( readp( fetch_arg( frame, 0 ) ) ) {

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

@ -24,9 +24,10 @@
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
struct pso_pointer env); frame_pointer,
struct pso_pointer env );
#define C_IO_IN L"*in*" #define C_IO_IN L"*in*"
#define C_IO_OUT L"*out*" #define C_IO_OUT L"*out*"
@ -49,19 +50,19 @@ extern struct pso_pointer lisp_stderr;
extern struct pso_pointer lisp_io_prompt; extern struct pso_pointer lisp_io_prompt;
URL_FILE *file_to_url_file(FILE *f); URL_FILE *file_to_url_file( FILE * f );
wint_t url_fgetwc(URL_FILE *input); wint_t url_fgetwc( URL_FILE * input );
wint_t url_ungetwc(wint_t wc, URL_FILE *input); wint_t url_ungetwc( wint_t wc, URL_FILE * input );
struct pso_pointer push_back_character(struct pso_pointer c, struct pso_pointer push_back_character( struct pso_pointer c,
struct pso_pointer r); struct pso_pointer r );
struct pso_pointer get_default_stream(bool inputp, struct pso_pointer env); struct pso_pointer get_default_stream( bool inputp, struct pso_pointer env );
URL_FILE *stream_get_url_file(struct pso_pointer s); URL_FILE *stream_get_url_file( struct pso_pointer s );
struct pso_pointer lisp_close(struct pso_pointer frame_pointer); struct pso_pointer lisp_close( struct pso_pointer frame_pointer );
struct pso_pointer lisp_open(struct pso_pointer frame_pointer); struct pso_pointer lisp_open( struct pso_pointer frame_pointer );
struct pso_pointer lisp_slurp(struct pso_pointer frame_pointer); struct pso_pointer lisp_slurp( struct pso_pointer frame_pointer );
#endif #endif

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

@ -25,18 +25,17 @@
* *
* (peek stream) * (peek stream)
*/ */
struct pso_pointer peek(struct pso_pointer frame_pointer) { struct pso_pointer peek( struct pso_pointer frame_pointer ) {
struct pso_pointer result = nil; struct pso_pointer result = nil;
struct pso_pointer input = struct pso_pointer input =
pointer_to_pso4(frame_pointer)->payload.stack_frame.arg[0]; pointer_to_pso4( frame_pointer )->payload.stack_frame.arg[0];
if (readp(input)) { if ( readp( input ) ) {
URL_FILE *stream = pointer_to_object(input)->payload.stream.stream; URL_FILE *stream = pointer_to_object( input )->payload.stream.stream;
wint_t c = url_fgetwc(stream); wint_t c = url_fgetwc( stream );
url_ungetwc(c, stream); url_ungetwc( c, stream );
result = make_character(frame_pointer, c); result = make_character( frame_pointer, c );
} }
return result; return result;
} }

43
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,12 +188,13 @@ 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; }
case FUNCTIONTV: { break;
struct pso2 *function = pointer_to_object(p); case FUNCTIONTV:{
url_fputws(L"<function: ", output); struct pso2 *function = pointer_to_object( p );
in_write(function->payload.function.meta, output, escape, url_fputws( L"<function: ", output );
indent); in_write( function->payload.function.meta, output, escape,
indent );
write_char( L'>', output, escape ); write_char( L'>', output, escape );
} break; } break;
case INTEGERTV: case INTEGERTV:
@ -217,11 +217,11 @@ struct pso_pointer in_write( struct pso_pointer p, URL_FILE *output,
indent ); indent );
write_char( L'>', output, escape ); write_char( L'>', output, escape );
break; break;
case SPECIALTV: { case SPECIALTV:{
struct pso2 *function = pointer_to_object(p); struct pso2 *function = pointer_to_object( p );
url_fputws(L"<special form: ", output); url_fputws( L"<special form: ", output );
in_write(function->payload.function.meta, output, escape, in_write( function->payload.function.meta, output, escape,
indent); indent );
write_char( L'>', output, escape ); write_char( L'>', output, escape );
} break; } break;
case TRUETV: case TRUETV:
@ -281,13 +281,17 @@ struct pso_pointer write( struct pso_pointer frame_pointer ) {
return result; return result;
} }
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,
nl_before ? t : nil, nl_after ? t : nil)); make_frame( 5, frame_pointer, object, stream,
struct pso_pointer result = push_local(frame_pointer, write(next_pointer)); escape ? t : nil,
nl_before ? t : nil, nl_after ? t : nil ) );
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;
} }

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

@ -26,9 +26,10 @@ struct pso_pointer princ( struct pso_pointer frame_pointer );
struct pso_pointer in_write( struct pso_pointer p, URL_FILE * output, 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))

17
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 );
@ -154,7 +156,7 @@ struct pso_pointer read_number( struct pso_pointer frame_pointer ) {
} // else exception? } // else exception?
#ifdef DEBUG #ifdef DEBUG
debug_printf( DEBUG_IO, 0, L"\nRead number %ld\n", value ); debug_printf( DEBUG_IO, 0, L"\nRead number %ld\n", value );
debug_dump_object(result, DEBUG_IO, 1); debug_dump_object( result, DEBUG_IO, 1 );
#endif #endif
return result; return result;
@ -185,13 +187,12 @@ 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 );
debug_print( L"`\n\t", DEBUG_IO, 0); debug_print( L"`\n\t", DEBUG_IO, 0 );
debug_dump_object(result, DEBUG_IO, 1); debug_dump_object( result, DEBUG_IO, 1 );
#endif #endif
return result; return result;
} }
@ -284,7 +285,7 @@ struct pso_pointer read( struct pso_pointer frame_pointer ) {
debug_print( L"Read expression: `", DEBUG_IO, 0 ); debug_print( L"Read expression: `", DEBUG_IO, 0 );
debug_print_object( result, DEBUG_IO, 0 ); debug_print_object( result, DEBUG_IO, 0 );
debug_print( L"`\n", DEBUG_IO, 0 ); debug_print( L"`\n", DEBUG_IO, 0 );
debug_dump_object(result, DEBUG_IO, 1); debug_dump_object( result, DEBUG_IO, 1 );
#endif #endif
return result; return result;

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

@ -45,13 +45,14 @@
void dump_string_cell( URL_FILE *output, wchar_t *prefix, void dump_string_cell( URL_FILE *output, wchar_t *prefix,
struct pso_pointer pointer ) { struct pso_pointer pointer ) {
struct pso2* object = pointer_to_object( pointer ); struct pso2 *object = pointer_to_object( pointer );
if ( object->payload.string.character == 0 ) { if ( object->payload.string.character == 0 ) {
url_fwprintf( output, url_fwprintf( output,
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,15 +61,19 @@ 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 =
url_fwprintf( output, L"[%3.3s %lc (%d)]", tag, c, 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 );
} }
} }
@ -79,8 +84,8 @@ void dump_string_cell( URL_FILE *output, wchar_t *prefix,
void dump_frame_context_fragment( URL_FILE *output, void dump_frame_context_fragment( URL_FILE *output,
struct pso_pointer frame_pointer, struct pso_pointer frame_pointer,
uint arg) { uint arg ) {
if ( stackp(frame_pointer )) { if ( stackp( frame_pointer ) ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso4 *frame = pointer_to_pso4( frame_pointer );
url_fwprintf( output, L" <= " ); url_fwprintf( output, L" <= " );
@ -90,7 +95,7 @@ void dump_frame_context_fragment( URL_FILE *output,
void dump_frame_context( URL_FILE *output, struct pso_pointer frame_pointer, void dump_frame_context( URL_FILE *output, struct pso_pointer frame_pointer,
int depth ) { int depth ) {
if ( stackp(frame_pointer) ) { if ( stackp( frame_pointer ) ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso4 *frame = pointer_to_pso4( frame_pointer );
url_fwprintf( output, L"\tContext: " ); url_fwprintf( output, L"\tContext: " );
@ -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 );
} }
@ -112,18 +118,20 @@ void dump_frame_context( URL_FILE *output, struct pso_pointer frame_pointer,
* @param frame_pointer the pointer to the frame * @param frame_pointer the pointer to the frame
*/ */
void dump_frame( URL_FILE *output, struct pso_pointer frame_pointer ) { void dump_frame( URL_FILE *output, struct pso_pointer frame_pointer ) {
if ( stackp(frame_pointer) ) { if ( stackp( 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 );
@ -139,13 +147,12 @@ void dump_frame( URL_FILE *output, struct pso_pointer frame_pointer ) {
void dump_stack_trace( URL_FILE *output, struct pso_pointer pointer ) { void dump_stack_trace( URL_FILE *output, struct pso_pointer pointer ) {
if ( exceptionp( pointer ) ) { if ( exceptionp( 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 );
pointer = pointer_to_pso4( pointer )->payload.stack_frame.previous; pointer = pointer_to_pso4( pointer )->payload.stack_frame.previous;
} }
@ -172,41 +179,41 @@ struct pso_pointer dump_object( struct pso_pointer frame_pointer ) {
struct pso_pointer stream = nil; struct pso_pointer stream = nil;
struct pso_pointer pointer = nil; struct pso_pointer pointer = nil;
if (stackp(frame_pointer)) { if ( stackp( frame_pointer ) ) {
struct pso4* frame = pointer_to_pso4( frame_pointer); struct pso4 *frame = pointer_to_pso4( frame_pointer );
pointer = fetch_arg( frame, 0); pointer = fetch_arg( frame, 0 );
stream = fetch_arg( frame, 1); stream = fetch_arg( frame, 1 );
} else { } else {
pointer = frame_pointer; 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 );
// url_fputws( L"\n", output ); // url_fputws( L"\n", output );
// fflush(stderr); // fflush(stderr);
URL_FILE* output = pointer_to_object(stream)->payload.stream.stream; URL_FILE *output = pointer_to_object( stream )->payload.stream.stream;
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:
url_fwprintf( output, url_fwprintf( output,
L"\t\tCons object: car at page %d offset %d, cdr at page %d " L"\t\tCons object: car at page %d offset %d, cdr at page %d "
@ -214,7 +221,7 @@ struct pso_pointer dump_object( struct pso_pointer frame_pointer ) {
object->payload.cons.car.page, object->payload.cons.car.page,
object->payload.cons.car.offset, object->payload.cons.car.offset,
object->payload.cons.cdr.page, object->payload.cons.cdr.page,
object->payload.cons.cdr.offset); object->payload.cons.cdr.offset );
in_write( pointer, output, false, 0 ); in_write( pointer, output, false, 0 );
url_fputws( L"\n", output ); url_fputws( L"\n", output );
break; break;
@ -226,7 +233,7 @@ struct pso_pointer dump_object( struct pso_pointer frame_pointer ) {
url_fwprintf( output, url_fwprintf( output,
L"\t\tFree object: next at page %d offset %d\n", L"\t\tFree object: next at page %d offset %d\n",
object->payload.free.next.page, object->payload.free.next.page,
object->payload.free.next.offset); object->payload.free.next.offset );
break; break;
case INTEGERTV: case INTEGERTV:
url_fwprintf( output, L"\t\tInteger object: value %ld\n", url_fwprintf( output, L"\t\tInteger object: value %ld\n",

16
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,
@ -147,7 +147,7 @@ struct pso_pointer allocate( struct pso_pointer frame_pointer, char *tag,
fputws( L"\nWARNING: No stack frame passed to `allocate`.\n", stderr ); fputws( L"\nWARNING: No stack frame passed to `allocate`.\n", stderr );
} }
return cheaty_allocate(frame_pointer, tag, size_class); return cheaty_allocate( frame_pointer, tag, size_class );
} }
@ -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 );

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

@ -45,7 +45,7 @@ struct pso_pointer search( struct pso_pointer key,
debug_print( L"In search; key is: `", DEBUG_BIND, 0 ); debug_print( L"In search; key is: `", DEBUG_BIND, 0 );
debug_print_object( key, DEBUG_BIND, 0 ); debug_print_object( key, DEBUG_BIND, 0 );
debug_print( L"`\n", DEBUG_BIND, 0 ); debug_print( L"`\n", DEBUG_BIND, 0 );
debug_dump_object(key, DEBUG_BIND, 1); debug_dump_object( key, DEBUG_BIND, 1 );
#endif #endif
if ( consp( store ) ) { if ( consp( store ) ) {
@ -54,9 +54,9 @@ struct pso_pointer search( struct pso_pointer key,
struct pso_pointer pair = c_car( cursor ); struct pso_pointer pair = c_car( cursor );
#ifdef DEBUG #ifdef DEBUG
debug_print( L"Checking `", DEBUG_BIND, 1 ); debug_print( L"Checking `", DEBUG_BIND, 1 );
debug_print_object( c_car( pair), DEBUG_BIND, 0 ); debug_print_object( c_car( pair ), DEBUG_BIND, 0 );
debug_print(L"`\n", DEBUG_BIND, 2); debug_print( L"`\n", DEBUG_BIND, 2 );
debug_dump_object(c_car(pair), DEBUG_BIND, 2); debug_dump_object( c_car( pair ), DEBUG_BIND, 2 );
#endif #endif
if ( consp( pair ) && c_equal( c_car( pair ), key ) ) { if ( consp( pair ) && c_equal( c_car( pair ), key ) ) {
@ -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;
} }

2
src/c/ops/assoc.h
View file

@ -16,7 +16,7 @@
#include "memory/pointer.h" #include "memory/pointer.h"
struct pso_pointer assoc(struct pso_pointer frame_pointer); struct pso_pointer assoc( struct pso_pointer frame_pointer );
struct pso_pointer search( struct pso_pointer key, struct pso_pointer search( struct pso_pointer key,
struct pso_pointer store, bool return_key ); struct pso_pointer store, bool return_key );

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

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

@ -30,31 +30,34 @@
*/ */
struct pso_pointer eval_cond_clause( struct pso_pointer clause, struct pso_pointer eval_cond_clause( struct pso_pointer clause,
struct pso4 *frame, struct pso4 *frame,
struct pso_pointer frame_pointer) { struct pso_pointer frame_pointer ) {
struct pso_pointer result = nil; struct pso_pointer result = nil;
struct pso_pointer env = fetch_env(frame_pointer); struct pso_pointer env = fetch_env( frame_pointer );
#ifdef DEBUG #ifdef DEBUG
debug_print( L"\n\tCond clause: ", DEBUG_EVAL, 0 ); debug_print( L"\n\tCond clause: ", DEBUG_EVAL, 0 );
debug_print_object( clause, DEBUG_EVAL, 0 ); debug_print_object( clause, DEBUG_EVAL, 0 );
debug_println( DEBUG_EVAL); debug_println( DEBUG_EVAL );
#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 =
struct pso_pointer val = lisp_eval(test_frame); push_local( frame_pointer,
make_frame( 1, frame_pointer, c_car( clause ) ) );
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 );
debug_print_object( clause, DEBUG_EVAL, 0 ); debug_print_object( clause, DEBUG_EVAL, 0 );
debug_print( L" succeeded; returning: ", DEBUG_EVAL, 0 ); debug_print( L" succeeded; returning: ", DEBUG_EVAL, 0 );
debug_print_object( result, DEBUG_EVAL, 0 ); debug_print_object( result, DEBUG_EVAL, 0 );
debug_println( DEBUG_EVAL); debug_println( DEBUG_EVAL );
} else { } else {
debug_print( L"\n\t\tCond clause ", DEBUG_EVAL, 0 ); debug_print( L"\n\t\tCond clause ", DEBUG_EVAL, 0 );
debug_print_object( clause, DEBUG_EVAL, 0 ); debug_print_object( 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 );
} }
@ -81,8 +85,8 @@ struct pso_pointer eval_cond_clause( struct pso_pointer clause,
* *
* @return the value of the last expression of the first successful `clause`. * @return the value of the last expression of the first successful `clause`.
*/ */
struct pso_pointer lisp_cond(struct pso_pointer frame_pointer) { struct pso_pointer lisp_cond( struct pso_pointer frame_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;
bool done = false; bool done = false;
@ -105,7 +109,7 @@ struct pso_pointer lisp_cond(struct pso_pointer frame_pointer) {
#ifdef DEBUG #ifdef DEBUG
debug_print( L"\tCond returning: ", DEBUG_EVAL, 0 ); debug_print( L"\tCond returning: ", DEBUG_EVAL, 0 );
debug_print_object( result, DEBUG_EVAL, 0 ); debug_print_object( result, DEBUG_EVAL, 0 );
debug_println( DEBUG_EVAL); debug_println( DEBUG_EVAL );
#endif #endif
return result; return result;

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

@ -110,7 +110,7 @@ struct pso_pointer eval_form( struct pso_pointer frame_pointer ) {
debug_print( L" returning: ", DEBUG_EVAL, 0 ); debug_print( L" returning: ", DEBUG_EVAL, 0 );
debug_print_object( result, DEBUG_EVAL, 0 ); debug_print_object( result, DEBUG_EVAL, 0 );
debug_println( DEBUG_EVAL ); debug_println( DEBUG_EVAL );
debug_dump_object(result, DEBUG_EVAL, 1); debug_dump_object( result, DEBUG_EVAL, 1 );
return result; return result;
} }
@ -155,11 +155,12 @@ struct pso_pointer eval_forms( struct pso_pointer frame_pointer ) {
* *
* This is experimental. It almost certainly WILL change. * This is experimental. It almost certainly WILL change.
*/ */
struct pso_pointer lisp_try( struct pso_pointer frame_pointer) { 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 ) );
} }
@ -195,7 +199,7 @@ struct pso_pointer lisp_try( struct pso_pointer frame_pointer) {
* @return the root namespace. * @return the root namespace.
*/ */
struct pso_pointer struct pso_pointer
lisp_oblist( struct pso4 *frame, struct pso_pointer frame_pointer) { lisp_oblist( struct pso4 *frame, struct pso_pointer frame_pointer ) {
return oblist; return oblist;
} }
@ -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 ),
return make_lambda( frame_pointer, fetch_arg(frame, 0), compose_body( frame_pointer ) ); compose_body( frame_pointer ) );
} }
/** /**
@ -253,22 +257,21 @@ 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 ),
return make_nlambda( frame_pointer, fetch_arg(frame, 0), compose_body( frame_pointer ) ); 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 ) );
struct pso_pointer args = fetch_arg( frame, 1); struct pso_pointer args = fetch_arg( frame, 1 );
struct pso_pointer new_env = fetch_env( frame_pointer ); struct pso_pointer new_env = fetch_env( frame_pointer );
struct pso_pointer names = lambda->payload.lambda.args; struct pso_pointer names = lambda->payload.lambda.args;
@ -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 =
@ -407,38 +410,41 @@ struct pso_pointer maybe_fixup_exception_location( struct pso_pointer r,
* *
* @return a pointer to the new frame. * @return a pointer to the new frame.
*/ */
struct pso_pointer make_fn_frame(struct pso_pointer previous, struct pso_pointer make_fn_frame( struct pso_pointer previous,
struct pso_pointer fn_pointer, struct pso_pointer fn_pointer,
struct pso_pointer arg_list) { struct pso_pointer arg_list ) {
struct pso_pointer new_pointer = make_frame( 0, previous ); struct pso_pointer new_pointer = make_frame( 0, previous );
struct pso4 *new_frame = pointer_to_pso4( new_pointer ); struct pso4 *new_frame = pointer_to_pso4( new_pointer );
struct pso_pointer next_pointer = struct pso_pointer next_pointer =
push_local(previous, make_frame(1, previous, nil)); push_local( previous, make_frame( 1, previous, nil ) );
struct pso4 *next_frame = pointer_to_pso4(next_pointer); struct pso4 *next_frame = pointer_to_pso4( next_pointer );
new_frame->payload.stack_frame.function = fn_pointer; new_frame->payload.stack_frame.function = fn_pointer;
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;
for (; consp(cursor); cursor = c_cdr(cursor)) { for ( ; consp( cursor ); cursor = c_cdr( cursor ) ) {
// Reusing a frame like this is a bit of an abuse but will save // Reusing a frame like this is a bit of an abuse but will save
// allocation churn. // allocation churn.
next_frame->payload.stack_frame.arg[0] = c_car(cursor); next_frame->payload.stack_frame.arg[0] = c_car( cursor );
more = make_cons(previous, lisp_eval(next_pointer), more); more = make_cons( previous, lisp_eval( next_pointer ), more );
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;
@ -457,9 +463,9 @@ struct pso_pointer make_fn_frame(struct pso_pointer previous,
* *
* @return a pointer to the new frame. * @return a pointer to the new frame.
*/ */
struct pso_pointer make_special_frame(struct pso_pointer previous, struct pso_pointer make_special_frame( struct pso_pointer previous,
struct pso_pointer fn_pointer, struct pso_pointer fn_pointer,
struct pso_pointer arg_list) { struct pso_pointer arg_list ) {
struct pso_pointer new_pointer = make_frame( 0, previous ); struct pso_pointer new_pointer = make_frame( 0, previous );
struct pso4 *new_frame = pointer_to_pso4( new_pointer ); struct pso4 *new_frame = pointer_to_pso4( new_pointer );
@ -468,13 +474,15 @@ 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 ) ) {
new_frame->payload.stack_frame.more = inc_ref( cursor); new_frame->payload.stack_frame.more = inc_ref( cursor );
} }
new_frame->payload.stack_frame.args = args; new_frame->payload.stack_frame.args = args;
@ -489,15 +497,18 @@ struct pso_pointer make_special_frame(struct pso_pointer previous,
* @param env The evaluation environment. * @param env The evaluation environment.
* @return the result of evaluating the function with its arguments. * @return the result of evaluating the function with its arguments.
*/ */
struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) { 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 ) );
dec_ref( fn_frame); dec_ref( fn_frame );
if ( exceptionp( fn_pointer ) ) { if ( exceptionp( fn_pointer ) ) {
result = fn_pointer; result = fn_pointer;
@ -514,32 +525,30 @@ 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 );
} }
} }
break; break;
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 =
c_assoc(fn_pointer, push_local( frame_pointer,
maybe_fixup_exception_location( c_assoc( fn_pointer,
eval_form(map_frame), fn_pointer))); maybe_fixup_exception_location
( 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,15 +603,12 @@ 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 );
debug_print_object( result, DEBUG_EVAL, 0 ); debug_print_object( result, DEBUG_EVAL, 0 );
debug_println( DEBUG_EVAL); debug_println( DEBUG_EVAL );
dec_ref( next_pointer ); dec_ref( next_pointer );
} }
} }
@ -617,14 +621,15 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) {
memset( buffer, '\0', bs ); memset( buffer, '\0', bs );
swprintf( buffer, bs, swprintf( buffer, bs,
L"Unexpected cell with tag %u (%3.3s) in function position", L"Unexpected cell with tag %u (%3.3s) in function position",
get_tag_value(fn_pointer), get_tag_value( fn_pointer ),
&( fn_cell->header.tag.bytes.mnemonic[0] ) ); &( fn_cell->header.tag.bytes.mnemonic[0] ) );
struct pso_pointer message = struct pso_pointer message =
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,42 +660,46 @@ 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 );
struct pso4* frame = pointer_to_pso4(frame_pointer); struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer result = frame->payload.stack_frame.arg[0]; struct pso_pointer result = frame->payload.stack_frame.arg[0];
struct pso2 *cell = pointer_to_object(frame->payload.stack_frame.arg[0]); struct pso2 *cell = pointer_to_object( frame->payload.stack_frame.arg[0] );
struct pso_pointer env = fetch_env(frame_pointer); struct pso_pointer env = fetch_env( frame_pointer );
switch (get_tag_value(result)) { switch ( get_tag_value( result ) ) {
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:
{ {
#ifdef DEBUG #ifdef DEBUG
debug_print( L"\nEvaluating symbol `", DEBUG_EVAL, 0); debug_print( L"\nEvaluating symbol `", DEBUG_EVAL, 0 );
debug_print_object( fetch_arg( frame, 0), DEBUG_EVAL, 0); debug_print_object( fetch_arg( frame, 0 ), DEBUG_EVAL, 0 );
debug_print( L"`\n\tEnvironment is: ", DEBUG_EVAL, 0); debug_print( L"`\n\tEnvironment is: ", DEBUG_EVAL, 0 );
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 ) );
} }
@ -779,13 +793,13 @@ lisp_type( struct pso_pointer frame_pointer ) {
* @return the source of the `object` indicated, if it is a function, a lambda, * @return the source of the `object` indicated, if it is a function, a lambda,
* an nlambda, or a spcial form; else `nil`. * an nlambda, or a spcial form; else `nil`.
*/ */
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 );
break; break;
@ -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 ) );
@ -820,7 +836,7 @@ struct pso_pointer lisp_source( struct pso_pointer frame_pointer) {
* @return struct pso_pointer a pointer to the result * @return struct pso_pointer a pointer to the result
*/ */
struct pso_pointer lisp_list( struct pso_pointer frame_pointer ) { struct pso_pointer lisp_list( struct pso_pointer frame_pointer ) {
struct pso4* frame = pointer_to_pso4( frame_pointer); struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer result = frame->payload.stack_frame.more; struct pso_pointer result = frame->payload.stack_frame.more;
for ( int a = for ( int a =
@ -840,51 +856,60 @@ struct pso_pointer lisp_list( struct pso_pointer frame_pointer ) {
* This is `let*` in Common Lisp parlance; `let` in Clojure parlance. * This is `let*` in Common Lisp parlance; `let` in Clojure parlance.
*/ */
struct pso_pointer lisp_let( struct pso_pointer frame_pointer ) { struct pso_pointer lisp_let( struct pso_pointer frame_pointer ) {
struct pso4* frame = pointer_to_pso4( frame_pointer); struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer bindings = fetch_env(frame_pointer); struct pso_pointer bindings = fetch_env( frame_pointer );
struct pso_pointer result = nil; struct pso_pointer result = nil;
for ( struct pso_pointer cursor = fetch_arg( frame, 0); for ( struct pso_pointer cursor = fetch_arg( frame, 0 );
c_truep( cursor ); cursor = c_cdr( cursor ) ) { c_truep( cursor ); cursor = c_cdr( cursor ) ) {
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;
} }
} }
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 =
struct pso4* progn_frame = pointer_to_pso4(progn_pointer); make_frame_with_env( 0, frame_pointer, bindings );
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] =
progn_frame->payload.stack_frame.args ++; fetch_arg( frame, a );
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 );
} }
return result; return result;
@ -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 ) );
} }
# #

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

@ -35,7 +35,7 @@
* @param env my environment (from which the stream may be extracted). * @param env my environment (from which the stream may be extracted).
* @return nil. * @return nil.
*/ */
struct pso_pointer lisp_inspect(struct pso_pointer frame_pointer) { struct pso_pointer lisp_inspect( struct pso_pointer frame_pointer ) {
debug_print( L"Entering lisp_inspect\n", DEBUG_IO, 0 ); debug_print( L"Entering lisp_inspect\n", DEBUG_IO, 0 );
struct pso_pointer result = nil; struct pso_pointer result = nil;
@ -46,7 +46,7 @@ struct pso_pointer lisp_inspect(struct pso_pointer frame_pointer) {
: get_default_stream( false, fetch_env( frame_pointer ) ); : get_default_stream( false, fetch_env( frame_pointer ) );
URL_FILE *output; URL_FILE *output;
dump_object( frame_pointer, fetch_arg(frame,1), fetch_arg(frame, 0) ); dump_object( frame_pointer, fetch_arg( frame, 1 ), fetch_arg( frame, 0 ) );
debug_print( L"Leaving lisp_inspect", DEBUG_IO, 0 ); debug_print( L"Leaving lisp_inspect", DEBUG_IO, 0 );

2
src/c/ops/inspect.h
View file

@ -17,7 +17,7 @@
/** /**
* Legacy technical debt to be entirely rewritten * Legacy technical debt to be entirely rewritten
*/ */
void dump_object(struct pso_pointer frame_pointer, void dump_object( struct pso_pointer frame_pointer,
struct pso_pointer output, struct pso_pointer pointer ); struct pso_pointer output, struct pso_pointer pointer );

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

@ -20,7 +20,7 @@
* @brief an implementation of `keys` convenient for calling from C * @brief an implementation of `keys` convenient for calling from C
* *
* @param */ * @param */
struct pso_pointer c_keys(struct pso_pointer frame_pointer, struct pso_pointer c_keys( struct pso_pointer frame_pointer,
struct pso_pointer store ) { struct pso_pointer store ) {
struct pso_pointer result = nil; struct pso_pointer result = nil;
@ -44,7 +44,8 @@ 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] );
} }

2
src/c/ops/keys.h
View file

@ -14,6 +14,6 @@
struct pso_pointer c_keys( struct pso_pointer store ); struct pso_pointer c_keys( struct pso_pointer store );
struct pso_pointer lisp_keys(struct pso_pointer frame_pointer); struct pso_pointer lisp_keys( struct pso_pointer frame_pointer );
#endif #endif

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

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

@ -26,33 +26,42 @@
struct pso_pointer lisp_mapcar( struct pso_pointer frame_pointer ) { struct pso_pointer lisp_mapcar( 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 );
debug_print( L"Mapcar: ", DEBUG_EVAL, 0 ); debug_print( L"Mapcar: ", DEBUG_EVAL, 0 );
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 );
debug_println( DEBUG_EVAL); debug_println( DEBUG_EVAL );
} }
result = consp( result ) ? c_reverse( frame_pointer, result ) : result; result = consp( result ) ? c_reverse( frame_pointer, result ) : result;

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

@ -32,13 +32,13 @@ c_progn( struct pso4 *frame, struct pso_pointer frame_pointer,
struct pso_pointer expressions, struct pso_pointer env ) { struct pso_pointer expressions, struct pso_pointer env ) {
struct pso_pointer result = nil; struct pso_pointer result = nil;
struct pso_pointer next_pointer = struct pso_pointer next_pointer =
push_local(frame_pointer, make_frame(1, frame_pointer, nil)); push_local( frame_pointer, make_frame( 1, frame_pointer, nil ) );
struct pso4 *next_frame = pointer_to_pso4(next_pointer); struct pso4 *next_frame = pointer_to_pso4( next_pointer );
while ( consp( expressions ) ) { while ( consp( expressions ) ) {
next_frame->payload.stack_frame.arg[0] = c_car(expressions); next_frame->payload.stack_frame.arg[0] = c_car( expressions );
result = lisp_eval( next_pointer); result = lisp_eval( next_pointer );
expressions = exceptionp( result ) ? nil : c_cdr( expressions ); expressions = exceptionp( result ) ? nil : c_cdr( expressions );
} }
@ -60,24 +60,24 @@ 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 =
push_local(frame_pointer, make_frame(1, frame_pointer, nil)); push_local( frame_pointer, make_frame( 1, frame_pointer, nil ) );
struct pso4 *next_frame = pointer_to_pso4(next_pointer); struct pso4 *next_frame = pointer_to_pso4( next_pointer );
for (int i = 0; i < args_in_frame; i++) { for ( int i = 0; i < args_in_frame; i++ ) {
next_frame->payload.stack_frame.arg[0] = next_frame->payload.stack_frame.arg[0] =
frame->payload.stack_frame.arg[i]; frame->payload.stack_frame.arg[i];
result = push_local(frame_pointer, lisp_eval(next_pointer)); result = push_local( frame_pointer, lisp_eval( next_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 =
fetch_env(frame_pointer)); c_progn( frame, frame_pointer, frame->payload.stack_frame.more,
fetch_env( frame_pointer ) );
} }
return result; return result;

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

@ -15,9 +15,10 @@
#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 );
struct pso_pointer lisp_progn(struct pso_pointer frame_pointer); struct pso_pointer lisp_progn( struct pso_pointer frame_pointer );
#endif #endif

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

@ -21,6 +21,6 @@
* *
* @return the expression. * @return the expression.
*/ */
struct pso_pointer quote(struct pso_pointer frame_pointer){ struct pso_pointer quote( struct pso_pointer frame_pointer ) {
return fetch_arg(pointer_to_pso4(frame_pointer), 0); return fetch_arg( pointer_to_pso4( frame_pointer ), 0 );
} }

2
src/c/ops/quote.h
View file

@ -14,5 +14,5 @@
#include "memory/pointer.h" #include "memory/pointer.h"
struct pso_pointer quote(struct pso_pointer frame_pointer); struct pso_pointer quote( struct pso_pointer frame_pointer );
#endif #endif

2
src/c/ops/repl.c
View file

@ -106,7 +106,7 @@ struct pso_pointer repl( struct pso_pointer frame_pointer ) {
dec_ref( base_of_stack ); dec_ref( base_of_stack );
} }
debug_print(L"Leaving repl\n", DEBUG_REPL, 0); debug_print( L"Leaving repl\n", DEBUG_REPL, 0 );
return nil; return nil;
} }

20
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:
@ -105,7 +105,7 @@ struct pso_pointer c_reverse( struct pso_pointer frame_pointer,
struct pso_pointer result = nil; struct pso_pointer result = nil;
if ( stackp( frame_pointer ) ) { if ( stackp( frame_pointer ) ) {
result = reverse( make_frame(1, frame_pointer, sequence) ); result = reverse( make_frame( 1, frame_pointer, sequence ) );
} }
return result; return result;

6
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;
@ -183,7 +183,7 @@ struct pso_pointer c_string_to_lisp_symbol( struct pso_pointer frame_pointer,
for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) { for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) {
wchar_t c = symbol[i]; wchar_t c = symbol[i];
if ( symbol_char_p(c)) { if ( symbol_char_p( c ) ) {
result = make_symbol( frame_pointer, c, result ); result = make_symbol( frame_pointer, c, result );
} }
} }

6
src/c/ops/string_ops.h
View file

@ -27,11 +27,11 @@ char *lisp_string_to_c_string( struct pso_pointer s );
struct pso_pointer c_string_to_lisp_keyword( struct pso_pointer frame_pointer, struct pso_pointer c_string_to_lisp_keyword( struct pso_pointer frame_pointer,
wchar_t * symbol ); wchar_t *symbol );
struct pso_pointer c_string_to_lisp_symbol( struct pso_pointer frame_pointer, struct pso_pointer c_string_to_lisp_symbol( struct pso_pointer frame_pointer,
wchar_t * symbol ); wchar_t *symbol );
bool end_of_stringp(struct pso_pointer arg); bool end_of_stringp( struct pso_pointer arg );
#endif #endif

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

@ -121,26 +121,26 @@ struct pso_pointer throw_exception_with_cause( struct pso_pointer location,
debug_print( L"`\n", DEBUG_ANY, 0 ); debug_print( L"`\n", DEBUG_ANY, 0 );
if ( !c_nilp( cause ) ) { if ( !c_nilp( cause ) ) {
debug_print( L"\tCaused by: ", DEBUG_ANY, 0 ); debug_print( L"\tCaused by: ", DEBUG_ANY, 0 );
debug_print_object( cause, DEBUG_ANY, 0); debug_print_object( cause, DEBUG_ANY, 0 );
debug_print( L"`\n", DEBUG_ANY, 0 ); debug_print( L"`\n", DEBUG_ANY, 0 );
} }
#endif #endif
struct pso2 *cell = pointer_to_object( message ); struct pso2 *cell = pointer_to_object( message );
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,
privileged_keyword_location, location), location ),
nil)), nil ) ),
cause)); cause ) );
result = push_local(frame_pointer, make_exception(x_frame)); result = push_local( frame_pointer, make_exception( x_frame ) );
} }
return result; return result;
@ -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 );
} }

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

@ -12,11 +12,14 @@
#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
struct pso_pointer result = allocate(frame_pointer, FUNCTIONTAG, 2); pso_pointer
struct pso2 *object = pointer_to_object(result); frame_pointer ) )
{
struct pso_pointer result = allocate( frame_pointer, FUNCTIONTAG, 2 );
struct pso2 *object = pointer_to_object( result );
object->payload.function.meta = meta; object->payload.function.meta = meta;
object->payload.function.executable = executable; object->payload.function.executable = executable;

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

4
src/c/payloads/keyword.c
View file

@ -21,7 +21,7 @@
* @param c the character to add (prepend); * @param c the character to add (prepend);
* @param tail the keyword which is being built. * @param tail the keyword which is being built.
*/ */
struct pso_pointer make_keyword( struct pso_pointer frame_pointer, wint_t c, struct pso_pointer make_keyword( struct pso_pointer frame_pointer, wint_t c,
struct pso_pointer tail ) { struct pso_pointer tail ) {
return make_string_like_thing( frame_pointer, c, tail, KEYTAG ); return make_string_like_thing( frame_pointer, c, tail, KEYTAG );
} }

2
src/c/payloads/keyword.h
View file

@ -17,7 +17,7 @@
* Strings are of indefinite length, but keywords are really not, and might * Strings are of indefinite length, but keywords are really not, and might
* fit into any size class. */ * fit into any size class. */
struct pso_pointer make_keyword( struct pso_pointer frame_pointer, wint_t c, struct pso_pointer make_keyword( struct pso_pointer frame_pointer, wint_t c,
struct pso_pointer tail ); struct pso_pointer tail );
#endif #endif

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

@ -13,12 +13,13 @@
#include "memory/pso.h" #include "memory/pso.h"
#include "memory/pso2.h" #include "memory/pso2.h"
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 );
object->payload.lambda.args = args; object->payload.lambda.args = args;
object->payload.lambda.body = body; object->payload.lambda.body = body;
} }

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

@ -30,9 +30,10 @@ struct lambda_payload {
struct pso_pointer body; struct pso_pointer body;
}; };
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

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

@ -12,11 +12,14 @@
#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
struct pso_pointer result = allocate(frame_pointer, SPECIALTAG, 2); pso_pointer
struct pso2 *object = pointer_to_object(result); frame_pointer ) )
{
struct pso_pointer result = allocate( frame_pointer, SPECIALTAG, 2 );
struct pso2 *object = pointer_to_object( result );
object->payload.special.meta = meta; object->payload.special.meta = meta;
object->payload.special.executable = executable; object->payload.special.executable = executable;

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

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

@ -100,22 +100,28 @@ 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 pso4* frame = pointer_to_pso4( frame_pointer); struct pso_pointer arg_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
if (exceptionp(new_more)) { ( frame_pointer,
frame->payload.
stack_frame.
more ) ) );
if ( exceptionp( new_more ) ) {
result = new_more; result = new_more;
} else { } else {
frame->payload.stack_frame.more = frame->payload.stack_frame.more =
push_local( frame_pointer, new_more); push_local( frame_pointer, new_more );
} }
} }
@ -205,13 +211,14 @@ 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 =
struct pso4* new_frame = pointer_to_pso4(new_pointer); in_make_frame( arg_count, previous, args );
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 ) ?
inc_ref(pointer_to_pso4(previous)->payload.stack_frame.env) : nil; inc_ref( pointer_to_pso4( previous )->payload.stack_frame.env ) : nil;
va_end(args); va_end( args );
return new_pointer; return new_pointer;
} }
@ -238,10 +245,11 @@ 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 =
pointer_to_pso4(new_pointer)->payload.stack_frame.env = inc_ref( env); in_make_frame( arg_count, previous, args );
pointer_to_pso4( new_pointer )->payload.stack_frame.env = inc_ref( env );
va_end(args); va_end( args );
return new_pointer; return new_pointer;
} }
@ -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

2
src/c/payloads/symbol.c
View file

@ -26,4 +26,4 @@
struct pso_pointer make_symbol( struct pso_pointer frame_pointer, wint_t c, struct pso_pointer make_symbol( struct pso_pointer frame_pointer, wint_t c,
struct pso_pointer tail ) { struct pso_pointer tail ) {
return make_string_like_thing( frame_pointer, c, tail, SYMBOLTAG ); return make_string_like_thing( frame_pointer, c, tail, SYMBOLTAG );
} }

2
src/c/payloads/symbol.h
View file

@ -28,7 +28,7 @@
* Strings are of indefinite length, but symbols are really not, and might * Strings are of indefinite length, but symbols are really not, and might
* fit into any size class. */ * fit into any size class. */
struct pso_pointer make_symbol( struct pso_pointer frame_pointer, wint_t c, struct pso_pointer make_symbol( struct pso_pointer frame_pointer, wint_t c,
struct pso_pointer tail ); struct pso_pointer tail );
#endif #endif