diff --git a/docs/State-of-play.md b/docs/State-of-play.md index 6796248..155aaab 100644 --- a/docs/State-of-play.md +++ b/docs/State-of-play.md @@ -1,5 +1,88 @@ # State of Play +## 20260424 + +### To have `c_` functions or not to have `c_` functions, revisited + +Right, I was hugely pleased with my 'make everything a Lisp, function, and then call it from C' idea. I wrote things like: + +```c + print( make_frame( 2, base_of_stack, + eval( make_frame( 1, base_of_stack, + read( make_frame( 1, base_of_stack, input_stream ) ) ) ), + output_stream ) ); +``` + +Isn't it beautiful? Isn't it elegant? Isn't it clear? Yes, it is. Does it work? Yes, actually, it does. Is it a total crock? Unfortunately, dear reader, it is. In this pattern, we don't have a handle on any of the stack frames made with make_frame, so we can't `dec_ref` them, so they don't get garbage collected. And while during bootstrap it's inevitable that there's a little crud left over because it was created before we have enough infrastructure set up, what I'm seeing at present from a 'start up and shut down run' is + +| Size class | Allocated | Deallocated | Remaining | +| ------------ | ------------ | ------------ | ------------ | +| 2 | 453 | 1 | 452 | +| 3 | 1 | 0 | 1 | +| 4 | 49 | 4 | 45 | +| 5 | 0 | 0 | 0 | +| 6 | 0 | 0 | 0 | + +The 452 unfreed objects in size class two are cons cells and string fragments, and they mostly represent the metadata on the streams `*in*`, `*out*`, `*log*` and `*sink*`, all of which are deliberately protected from garbage collection because, frankly, you don't want those things going away under you; so that's kind of OK. The one in size class three is an exception, and I'm quite pleased I'm only throwing one exception during bootstrap (although it would be nice it it got cleaned up). + +But the 45 unfreed objects in size class four are stackframes, and the reason they're unfreed is the coding pattern you see above. + +So, how to get around this? + +The code snippet above could be rewritten: + +```c + struct pso_pointer next = inc_ref( make_frame(1, base_of_stack, input_stream)); + struct pso_pointer read_value = inc_ref(read(next)); + dec_ref( next); + + next = inc_ref( make_frame(1, base_of_stack, read_value)); + struct pso_pointer eval_value = inc_ref( eval( next)); + dec_ref( next); + dec_ref( read_value); + + next = inc_ref( make_frame(2, base_of_stack, eval_value, output_stream)); + print( next); + dec_ref( next); + dec_ref( eval_value); +``` +This is much more prolix and, to me, less elegant; but it does get the garbage collected. In each stanza we're first setting up a frame with the arguments for the function we're about to call, then calling that function with the frame we've set up, and then `dec_ref`ing the frame. We shouldn't need to `dec_ref` the value returned by `print`, since we don't use it and the only thing holding a reference to it is the frame in which it was created, which we do `dec_ref`. + +I could `dec_ref` `read_value`, for instance, as soon as I've put it into the frame for `eval` rather than after `eval` has actually been invoked, since the frame is now protecting it from garbage collection; but I've delayed doing so until afterwards out of caution. + +Once we have `eval`/`apply` working, we won't need to do all this bureaucratic incrementing and decrementing of reference counts explicitly, since `eval`/`apply` *should* take care of it automatically. + +I'm still not 100% confident I can make the reference counting garbage collector work reliably, irrespective of whether it's actually efficient. + +### To recode or not to recode? + +There are 55 calls to `make_frame` in existing C code, and they're almost all written in the 'elegant but insanitary' pattern. Could they be rewritten more cleanly? Yes, they could. But my hope is most of this code will be replaced with code written in Lisp, once we have Lisp sufficiently bootstrapped to make that possible. + +So I think I'm going to put up with the uncollected garbage until we get to that point, at which point I'll audit the C code to see what is actually still in use, sanitise that, and delete the rest. + +However, any new C code (and there is going to have to be some) *must* be written in the sanitary but bureaucratic pattern. + +#### 21:24 + +Well, at the end of the day I think the git log says it all: + +``` +commit 63906fe817d509adb6171a72d16c045c2793ebed (HEAD -> feature/reengineering-17-21) +Author: Simon Brooke +Date: Fri Apr 24 21:20:23 2026 +0100 + + Print is less badly broken. Read is less badly broken. GC is too aggressive. + +commit 22b0160a266999c939c9a21df150542f8b2f0b25 (origin/feature/reengineering-17-21) +Author: Simon Brooke +Date: Fri Apr 24 09:22:06 2026 +0100 + + Builds and runs, but print is badly broken. Need some rethink. +``` + +I could just disable the garbage collector until I've got `eval`/`apply` working. I *believe* that with `eval`/`apply` I'll be able to automate all the garbage collection bookkeeping work. I hope so. Mark and sweep, or even my preferred mark but don't sweep, on a massively parallel machine, just doesn't bear thinking on. + + ## 20260421 ### To have `c_` functions or not to have `c_` functions? diff --git a/src/c/debug.c b/src/c/debug.c index a494358..6c4796d 100644 --- a/src/c/debug.c +++ b/src/c/debug.c @@ -19,7 +19,7 @@ #include "io/io.h" #include "io/print.h" -#include "memory/dump.h" +// #include "memory/dump.h" int verbosity = 0; diff --git a/src/c/io/io.c b/src/c/io/io.c index 7a8aacd..9a95c2f 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -114,7 +114,8 @@ struct pso_pointer lisp_io_readbase; /** * @brief bound to the Lisp symbol representing C_IO_READTABLE in initialisation */ -struct pso_pointer lisp_io_readtable; +struct pso_pointer lisp_io_read_table; + /** * Allow a one-character unget facility. This may not be enough - we may need @@ -175,7 +176,7 @@ struct pso_pointer initialise_default_streams( struct pso_pointer lisp_io_log = c_string_to_lisp_symbol( frame_pointer, C_IO_LOG ); lisp_io_prompt = c_string_to_lisp_symbol( frame_pointer, C_IO_PROMPT ); lisp_io_readbase = c_string_to_lisp_symbol( frame_pointer, C_IO_READBASE ); - lisp_io_readtable = + lisp_io_read_table = c_string_to_lisp_symbol( frame_pointer, C_IO_READTABLE ); debug_print( L"In initialise_default_streams; environment is: ", DEBUG_IO, @@ -192,7 +193,7 @@ struct pso_pointer initialise_default_streams( struct pso_pointer 10 ), lisp_bind( make_frame ( 3, frame_pointer, - lisp_io_readtable, + lisp_io_read_table, nil, env ) ) ) ) ) ); lisp_stdin = @@ -370,8 +371,8 @@ struct pso_pointer push_back_character( struct pso_pointer c, struct pso_pointer result = nil; if ( characterp( c ) && readp( r ) ) { if ( url_ungetwc( ( wint_t ) - ( pointer_to_object( c )->payload. - character.character ), + ( pointer_to_object( c )->payload.character. + character ), pointer_to_object( r )->payload.stream.stream ) >= 0 ) { result = t; @@ -398,8 +399,8 @@ struct pso_pointer lisp_close( struct pso_pointer frame_pointer, struct pso_pointer result = nil; if ( readp( fetch_arg( frame, 0 ) ) || writep( fetch_arg( frame, 0 ) ) ) { if ( url_fclose - ( pointer_to_object( fetch_arg( frame, 0 ) )->payload. - stream.stream ) + ( pointer_to_object( fetch_arg( frame, 0 ) )->payload.stream. + stream ) == 0 ) { result = t; } @@ -451,48 +452,51 @@ struct pso_pointer add_meta_time( struct pso_pointer frame_pointer, * Callback to assemble metadata for a URL stream. This is naughty because * it modifies data, but it's really the only way to create metadata. */ -static size_t write_meta_callback( struct pso_pointer frame_pointer, char *string, size_t size, size_t nmemb, +static size_t write_meta_callback( struct pso_pointer frame_pointer, + char *string, size_t size, size_t nmemb, struct pso_pointer stream ) { struct pso2 *object = pointer_to_object( stream ); // TODO: reimplement /* make a copy of the string that we can destructively change */ - char *s = calloc( strlen( string ), sizeof( char ) ); - strcpy( s, string ); - if ( readp(stream) || - writep(stream) ) { - int offset = index_of( ':', s ); - if ( offset != -1 ) { - s[offset] = ( char ) 0; - char *name = trim( s ); - char *value = trim( &s[++offset] ); - char32_t wname[strlen( name )]; - mbstowcs( wname, name, strlen( name ) + 1 ); - object->payload.stream.meta = - add_meta_string( frame_pointer, object->payload.stream.meta, wname, value ); - debug_printf( DEBUG_IO, 0, - L"write_meta_callback: added header '%s': value '%s'\n", name, value ); - } else if ( strncmp( "HTTP", s, 4 ) == 0 ) { - int offset = index_of( ' ', s ); - char *value = trim( &s[offset] ); - object->payload.stream.meta = - add_meta_integer( frame_pointer, add_meta_string - (frame_pointer, object->payload.stream.meta, L"status", - value ), L"status-code", strtol( value, - NULL, - 10 ) ); - debug_printf( DEBUG_IO, 0, - L"write_meta_callback: added header 'status': value '%s'\n", value ); - } else { - debug_printf( DEBUG_IO, 0, - L"write_meta_callback: header passed with no colon: '%s'\n", s ); - } - } else { - debug_print - ( L"Pointer passed to write_meta_callback did not point to a stream: ", - DEBUG_IO, 0 ); - debug_dump_object( stream, DEBUG_IO, 0 ); - } - free( s ); + char *s = calloc( strlen( string ), sizeof( char ) ); + strcpy( s, string ); + if ( readp( stream ) || writep( stream ) ) { + int offset = index_of( ':', s ); + if ( offset != -1 ) { + s[offset] = ( char ) 0; + char *name = trim( s ); + char *value = trim( &s[++offset] ); + char32_t wname[strlen( name )]; + mbstowcs( wname, name, strlen( name ) + 1 ); + object->payload.stream.meta = + add_meta_string( frame_pointer, object->payload.stream.meta, + wname, value ); + debug_printf( DEBUG_IO, 0, + L"write_meta_callback: added header '%s': value '%s'\n", + name, value ); + } else if ( strncmp( "HTTP", s, 4 ) == 0 ) { + int offset = index_of( ' ', s ); + char *value = trim( &s[offset] ); + object->payload.stream.meta = + add_meta_integer( frame_pointer, add_meta_string + ( frame_pointer, object->payload.stream.meta, + L"status", value ), L"status-code", + strtol( value, NULL, 10 ) ); + debug_printf( DEBUG_IO, 0, + L"write_meta_callback: added header 'status': value '%s'\n", + value ); + } else { + debug_printf( DEBUG_IO, 0, + L"write_meta_callback: header passed with no colon: '%s'\n", + s ); + } + } else { + debug_print + ( L"Pointer passed to write_meta_callback did not point to a stream: ", + DEBUG_IO, 0 ); + debug_dump_object( stream, DEBUG_IO, 0 ); + } + free( s ); return 0; // strlen( string ); } diff --git a/src/c/io/print.c b/src/c/io/print.c index 7a158d1..1ca8a35 100644 --- a/src/c/io/print.c +++ b/src/c/io/print.c @@ -120,7 +120,8 @@ struct pso_pointer write_list_content( struct pso_pointer p, URL_FILE *output, default: url_fputws( L" . ", output ); result = - in_write( object->payload.cons.cdr, output, escape, 0 ); + in_write( object->payload.cons.cdr, output, escape, + 0 ); } } } else { @@ -130,11 +131,11 @@ struct pso_pointer write_list_content( struct pso_pointer p, URL_FILE *output, return result; } -void in_write_nl (URL_FILE *output, int indent) { - write_char( L'\n', output, false); - for (int i = 0; i < indent; i++) { - write_char( L'\t', output, false); - } +void in_write_nl( URL_FILE *output, int indent ) { + write_char( L'\n', output, false ); + for ( int i = 0; i < indent; i++ ) { + write_char( L'\t', output, false ); + } } /** @@ -160,26 +161,36 @@ struct pso_pointer in_write( struct pso_pointer p, URL_FILE *output, escape ); break; case CONSTV: - write_char( L'(', output, escape); + write_char( L'(', output, escape ); result = write_list_content( p, output, escape ); - write_char( L')', output, escape); + write_char( L')', output, escape ); + break; + case EXCEPTIONTV:{ + struct pso3 *exception = pointer_to_pso3( p ); + + if ( exception != NULL ) { + url_fputws( L"payload.exception.message, output, + escape, indent ); + if ( !c_nilp( exception->payload.exception.meta ) ) { + in_write_nl( output, indent + 1 ); + url_fputws( L"metadata: ", output ); + in_write( exception->payload.exception.meta, + output, escape, indent ); + } + + if ( !c_nilp( exception->payload.exception.cause ) ) { + in_write_nl( output, indent + 1 ); + url_fputws( L"cause: ", output ); + in_write( exception->payload.exception.cause, + output, escape, indent ); + } + write_char( L'>', output, escape ); + } else { + url_fputws( L"", output ); + } + } break; - case EXCEPTIONTV : - struct pso3* exception = pointer_to_pso3(p); - url_fputws( L"payload.exception.message, output, escape, indent); - if (!c_nilp( exception->payload.exception.meta)) { - in_write_nl( output, indent+1); - url_fputws( L"metadata: ", output); - in_write( exception->payload.exception.meta, output, escape, indent); - } - if (!c_nilp( exception->payload.exception.cause)) { - in_write_nl( output, indent+1); - url_fputws( L"cause: ", output); - in_write( exception->payload.exception.cause, output, escape, indent); - } - write_char( L'>', output, escape); - break; case INTEGERTV: url_fwprintf( output, L"%d", ( int64_t ) ( object->payload.integer.value ) ); @@ -196,7 +207,8 @@ struct pso_pointer in_write( struct pso_pointer p, URL_FILE *output, case WRITETV: url_fwprintf( output, L"<%s stream: ", v == READTV ? "read" : "write" ); - in_write( object->payload.stream.meta, output, escape, indent ); + in_write( object->payload.stream.meta, output, escape, + indent ); write_char( L'>', output, escape ); break; case TRUETV: @@ -234,15 +246,15 @@ struct pso_pointer write( struct pso_pointer frame_pointer ) { bool nl_before = c_truep( fetch_arg( frame, 3 ) ); bool nl_after = c_truep( fetch_arg( frame, 4 ) ); struct pso_pointer result = object; - struct pso2* stream_obj = pointer_to_object( stream ); + struct pso2 *stream_obj = pointer_to_object( stream ); if ( writep( stream ) ) { - URL_FILE *output = stream_obj->payload.stream.stream; + URL_FILE *output = stream_obj->payload.stream.stream; if ( nl_before ) url_fputwc( L'\n', output ); - result = in_write( object, output, true, 0); + result = in_write( object, output, escape, 0 ); url_fputwc( nl_after ? L'\n' : L' ', output ); } else { @@ -267,12 +279,13 @@ struct pso_pointer print( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer next = inc_ref( make_frame( 5, frame_pointer, - fetch_arg( frame, 0 ), fetch_arg( frame, 1 ), t, - t, nil )); + fetch_arg( frame, 0 ), + fetch_arg( frame, 1 ), t, + t, nil ) ); struct pso_pointer result = write( next ); - dec_ref( next); + dec_ref( next ); return result; } @@ -284,12 +297,13 @@ struct pso_pointer princ( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer next = inc_ref( make_frame( 5, frame_pointer, - fetch_arg( frame, 0 ), fetch_arg( frame, 1 ), - nil, t, nil )); + fetch_arg( frame, 0 ), + fetch_arg( frame, 1 ), + nil, t, nil ) ); - struct pso_pointer result = write( next ); + struct pso_pointer result = write( next ); - dec_ref( next); + dec_ref( next ); return result; } diff --git a/src/c/io/read.c b/src/c/io/read.c index 2b44d55..336311f 100644 --- a/src/c/io/read.c +++ b/src/c/io/read.c @@ -32,6 +32,7 @@ #include "memory/pso2.h" #include "memory/tags.h" +#include "payloads/character.h" #include "payloads/exception.h" #include "payloads/function.h" #include "payloads/integer.h" @@ -101,9 +102,12 @@ struct pso_pointer read_character( struct pso_pointer frame_pointer ) { struct pso_pointer result = nil; struct pso_pointer stream_pointer = fetch_arg( frame, 0 ); if ( readp( stream_pointer ) ) { - result = make_string( frame_pointer, - url_fgetwc( stream_get_url_file - ( stream_pointer ) ), nil ); + wint_t chr = url_fgetwc( stream_get_url_file( stream_pointer ) ); + result = make_character( frame_pointer, chr ); + +#ifdef DEBUG + debug_printf( DEBUG_IO, 0, L"\nRead character %lc\n", chr ); +#endif } return result; @@ -204,8 +208,7 @@ struct pso_pointer read( struct pso_pointer frame_pointer ) { } if ( c_nilp( readtable ) ) { - // TODO: check for the value of `*read-table*` in the environment and - // use that. + readtable = c_assoc( lisp_io_read_table, fetch_env( frame_pointer ) ); } if ( c_nilp( character ) ) { @@ -240,9 +243,9 @@ struct pso_pointer read( struct pso_pointer frame_pointer ) { ( frame_pointer, c ) ); inc_ref( next ); if ( iswdigit( c ) ) { - result = read_number( next ); + result = push_local( frame_pointer, read_number( next ) ); } else if ( iswalpha( c ) ) { - result = read_symbol( next ); + result = push_local( frame_pointer, read_symbol( next ) ); } else { // result = // throw_exception( @@ -260,10 +263,15 @@ struct pso_pointer read( struct pso_pointer frame_pointer ) { // ), // frame_pointer ); } - dec_ref( next ); +// dec_ref( next ); break; } } +#ifdef DEBUG + debug_print( L"Read object: ", DEBUG_IO, 0 ); + debug_print_object( result, DEBUG_IO, 0 ); + debug_println( DEBUG_IO ); +#endif return result; } diff --git a/src/c/memory/memory.c b/src/c/memory/memory.c index 658f649..bc1e722 100644 --- a/src/c/memory/memory.c +++ b/src/c/memory/memory.c @@ -76,9 +76,14 @@ struct pso_pointer initialise_memory( uint32_t node ) { /** * @brief Pop an object off the freelist for the specified `size_class`. + * + * There is no conventional way this function can signal an error. Any pointer + * it returns is potentially valid. However, every valid object must have an + * even numbered offset, so possibly {:node 0, :page 0, :offset 1} could be + * used as a magic marker to indicate total exhaustion of store for this size + * class. TODO: think about this. */ struct pso_pointer pop_freelist( uint8_t size_class ) { - // `t`, because if `allocate_page` fails it will be set to `nil`. struct pso_pointer result = t; if ( size_class <= MAX_SIZE_CLASS ) { @@ -103,16 +108,16 @@ struct pso_pointer pop_freelist( uint8_t size_class ) { /* the object ought already to have the right size class in its tag * because it was popped off the freelist for that size class. */ if ( object->header.tag.bytes.size_class != size_class ) { - // TODO: return an exception instead? Or warn, set it, and continue? + fwprintf( stderr, + L"WARNING: Unexpected size class %x. on free list for class %x while allocating.\n", + object->header.tag.bytes.size_class, size_class ); } /* the objext ought to have a reference count ot zero, because it's * on the freelist, but again we should sanity check. */ if ( object->header.count != 0 ) { fwprintf( stderr, - L"WARNING: Count of %d in newly allocated object at %d, %d, should be 0\n", - result.page, - result.offset, - object->header.count ); + L"\nWARNING: Count of %u in newly allocated object at %u, %u, should be 0\n", + object->header.count, result.page, result.offset ); object->header.count = 0; } } diff --git a/src/c/memory/page.c b/src/c/memory/page.c index 1d9eebd..b22846a 100644 --- a/src/c/memory/page.c +++ b/src/c/memory/page.c @@ -286,8 +286,9 @@ struct pso_pointer initialise_page( union page *page_addr, uint16_t page_index, result = nil; } - debug_print( (c_nilp( result ) && (page_index != 0)) ? L"fail.\n" : L"success.\n", DEBUG_ALLOC, - 0 ); + debug_print( ( c_nilp( result ) + && ( page_index != 0 ) ) ? L"fail.\n" : L"success.\n", + DEBUG_ALLOC, 0 ); return result; } @@ -311,7 +312,7 @@ struct pso_pointer allocate_page( uint8_t size_class ) { if ( npages_allocated < NPAGES ) { if ( size_class >= 2 && size_class <= MAX_SIZE_CLASS ) { - void *pg = malloc( sizeof( union page ) ); + void *pg = calloc( sizeof( union page ), 1 ); if ( pg != NULL ) { memset( pg, 0, sizeof( union page ) ); diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index 93696d7..aff210b 100644 --- a/src/c/memory/pso.c +++ b/src/c/memory/pso.c @@ -4,9 +4,9 @@ * Paged space objects. * * Broadly, it should be save to cast any paged space object to a pso2, since - * that is the smallest actually used size class. This should work to extract - * the tag and size class fields from the header, for example. I'm not - * confident enough of my understanding of C to know whether it is similarly + * that is the smallest actually used size class. This should work to extract + * the tag and size class fields from the header, for example. I'm not + * confident enough of my understanding of C to know whether it is similarly * safe to cast something passed to you as a pso2 up to something larger, even * if you know from the size class field that it actually is something larger. * @@ -41,19 +41,22 @@ int allocation_table_allocated = 0; int allocation_table_freed = 1; -long int allocation_table[MAX_SIZE_CLASS +1][2]; +long int allocation_table[MAX_SIZE_CLASS + 1][2]; -void print_allocation_table() { - fputws( L"| Size class | Allocated | Deallocated | Remaining |\n", stderr); - fputws( L"| ============ | ============ | ============ | ============ |\n", stderr ); - - for ( int s = 2; s<= MAX_SIZE_CLASS; s++) { - long int a = allocation_table[s][allocation_table_allocated]; - long int d = allocation_table[s][allocation_table_freed]; - long int r = a - d; - fwprintf( stderr, L"| %12d | %12ld | %12ld | %12ld |\n", s, a, d, r); - } - fputws( L"| ============ | ============ | ============ | ============ |\n", stderr ); +void print_allocation_table( ) { + fputws( L"| Size class | Allocated | Deallocated | Remaining |\n", + stderr ); + fputws( L"| ============ | ============ | ============ | ============ |\n", + stderr ); + + for ( int s = 2; s <= MAX_SIZE_CLASS; s++ ) { + long int a = allocation_table[s][allocation_table_allocated]; + long int d = allocation_table[s][allocation_table_freed]; + long int r = a - d; + fwprintf( stderr, L"| %12d | %12ld | %12ld | %12ld |\n", s, a, d, r ); + } + fputws( L"| ============ | ============ | ============ | ============ |\n", + stderr ); } #endif @@ -77,64 +80,53 @@ struct pso_pointer cheaty_make_cons( struct pso_pointer car, return result; } - /** - * @brief Allocate an object of this `size_class` with this `tag`. - * - * All objects that are allocated (after completion of init)) should be linked - * onto the `locals` slot of a stack frame. This guarantees - * 1. that they do get `inc_ref`ed; and that, - * 2. if nothing else hangs onto them they will be reclaimed when that stack - * frame is reclaimed. - * for some objects (e.g. those cons cells on the locals list) this isn't - * possible due to infinite recursion, but those special cases need to be - * audited carefully. - * - * @param frame_pointer pointer to an active stack frame (or - * nil, but only during initialisation). - * @param tag The tag. Only the first three bytes will be used; - * @param size_class The size class for the object to be allocated; - * @return struct pso_pointer a pointer to the newly allocated object - */ +/** + * @brief Allocate an object of this `size_class` with this `tag`. + * + * All objects that are allocated (after completion of init)) should be linked + * onto the `locals` slot of a stack frame. This guarantees + * 1. that they do get `inc_ref`ed; and that, + * 2. if nothing else hangs onto them they will be reclaimed when that stack + * frame is reclaimed. + * for some objects (e.g. those cons cells on the locals list) this isn't + * possible due to infinite recursion, but those special cases need to be + * audited carefully. + * + * @param frame_pointer pointer to an active stack frame (or + * nil, but only during initialisation). + * @param tag The tag. Only the first three bytes will be used; + * @param size_class The size class for the object to be allocated; + * @return struct pso_pointer a pointer to the newly allocated object + */ struct pso_pointer allocate( struct pso_pointer frame_pointer, char *tag, uint8_t size_class ) { - // todo: issue #21: must have stack frame passed in. + struct pso_pointer result = pop_freelist( size_class ); + if ( memory_initialised && c_nilp( frame_pointer ) ) { + fputws( L"\nWARNING: No stack frame passed to `allocate`.\n", stderr ); + } #ifdef DEBUG debug_printf( DEBUG_ALLOC, 0, - L"Allocating object of size class %d with tag `%s`... ", + L"\nAllocating object of size class %d with tag `%s`... ", size_class, tag ); #endif - struct pso_pointer result = pop_freelist( size_class ); - struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso2 *obj = pointer_to_object( result ); + strncpy( ( char * ) ( obj->header.tag.bytes.mnemonic ), tag, TAGLENGTH ); - if ( memory_initialised && c_nilp(frame_pointer)) { - fputws( L"WARNING: No stack frame passed to `allocate`.\n", - stderr ); - } - - if ( !c_nilp( result ) ) { - struct pso2 *obj = pointer_to_object(result); - strncpy((char*) (obj->header.tag.bytes. - mnemonic ), tag, TAGLENGTH ); - - debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ", - result.page, result.offset ); - if ( stackp( frame_pointer ) ) { - // You can't make a stack frame in the middle of making a stack - // frame. Infinite recursion. So we have to cheat. - struct pso_pointer locals = cheaty_make_cons( result, - frame-> - payload.stack_frame. - locals ); - frame->payload.stack_frame.locals = locals; - } -#ifdef DEBUG - allocation_table[size_class][allocation_table_allocated]++; -#endif - } else { - // TODO: throw exception + debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ", result.page, + result.offset ); + if ( stackp( frame_pointer ) ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + // You can't make a stack frame in the middle of making a stack + // frame. Infinite recursion. So we have to cheat. + struct pso_pointer locals = + cheaty_make_cons( result, frame->payload.stack_frame.locals ); + frame->payload.stack_frame.locals = locals; } +#ifdef DEBUG + allocation_table[size_class][allocation_table_allocated]++; +#endif #ifdef DEBUG debug_print( exceptionp( result ) ? L"fail\n" : L"success\n", DEBUG_ALLOC, @@ -164,25 +156,39 @@ int payload_size( struct pso2 *object ) { * Returns the `pointer`. */ struct pso_pointer inc_ref( struct pso_pointer pointer ) { - struct pso2 *object = pointer_to_object( pointer ); + if ( c_nilp( pointer ) || c_truep( pointer ) ) { + /* You can't do this and there's no point trying or cluttering the + logs. */ + return pointer; + } else if ( freep( pointer ) ) { + fwprintf( stderr, + L"\nWARNING: Attempt to inc_ref a FREE object at %u, %u blocked\n", + pointer.page, pointer.offset ); + } else { + struct pso2 *object = pointer_to_object( pointer ); - if ( object->header.count < MAXREFERENCE ) { - object->header.count++; + if ( object->header.count < MAXREFERENCE ) { + object->header.count++; #ifdef DEBUG - debug_printf( DEBUG_ALLOC, 0, - L"\nIncremented object of type %3.3s, size class %d, at page %u, offset %u to count %u", - ( ( char * ) &(object->header.tag.bytes.mnemonic[0] )), - (int)object->header.tag.bytes.size_class, - pointer.page, pointer.offset, object->header.count ); - if ( vectorpointp( pointer ) ) { debug_printf( DEBUG_ALLOC, 0, - L"; pointer to vector object of type %3.3s.\n", - ( ( char * ) - &( object->payload.vectorp.tag.bytes[0] ) ) ); - } else { - debug_println( DEBUG_ALLOC ); - } + L"\nIncremented object of type %3.3s, size class %d, " + L"at page %u, offset %u to count %u", ( ( char * ) + & + ( object->header.tag. + bytes.mnemonic + [0] ) ), + ( int ) object->header.tag.bytes.size_class, + pointer.page, pointer.offset, object->header.count ); + if ( vectorpointp( pointer ) ) { + debug_printf( DEBUG_ALLOC, 0, + L"; pointer to vector object of type %3.3s.\n", + ( ( char * ) + &( object->payload.vectorp.tag.bytes[0] ) ) ); + } else { + debug_println( DEBUG_ALLOC ); + } #endif + } } return pointer; @@ -197,42 +203,48 @@ struct pso_pointer inc_ref( struct pso_pointer pointer ) { * Returns the `pointer`, or, if the object has been freed, a pointer to `nil`. */ struct pso_pointer dec_ref( struct pso_pointer pointer ) { - struct pso2 *object = pointer_to_object( pointer ); - - if (freep(pointer)) { - fputws( L"WARNING: SHOULDN'T: Decrementing free object?\n", stderr); - } + if ( c_nilp( pointer ) || c_truep( pointer ) ) { + /* You can't do this and there's no point trying or cluttering the + logs. */ + return pointer; + } else if ( freep( pointer ) ) { + fwprintf( stderr, + L"\nWARNING: Attempt to dec_ref a FREE object at %u, %u blocked\n", + pointer.page, pointer.offset ); + } else { + struct pso2 *object = pointer_to_object( pointer ); - if ( !c_nilp( pointer ) && object->header.count > 0 - && object->header.count != MAXREFERENCE ) { - object->header.count--; + if ( object->header.count > 0 && object->header.count != MAXREFERENCE ) { + object->header.count--; #ifdef DEBUG - debug_printf( DEBUG_ALLOC, 0, - L"\nDecremented object of type %3.3s, size class %d, at page %d, offset %d to count %d", - ( ( char * ) ( object->header.tag.bytes.mnemonic ) ), - (int)object->header.tag.bytes.size_class, - pointer.page, pointer.offset, object->header.count ); - if ( vectorpointp( pointer ) ) { debug_printf( DEBUG_ALLOC, 0, - L"; pointer to vector object of type %3.3s.\n", - ( ( char * ) - &( object->payload.vectorp.tag.bytes ) ) ); - } else { - debug_println( DEBUG_ALLOC ); - } + L"\nDecremented object of type %3.3s, size class %d, " + L"at page %d, offset %d to count %d", + ( ( char * ) ( object->header.tag.bytes.mnemonic ) ), + ( int ) object->header.tag.bytes.size_class, + pointer.page, pointer.offset, object->header.count ); + if ( vectorpointp( pointer ) ) { + debug_printf( DEBUG_ALLOC, 0, + L"; pointer to vector object of type %3.3s.\n", + ( ( char * ) + &( object->payload.vectorp.tag.bytes ) ) ); + } else { + debug_println( DEBUG_ALLOC ); + } #endif + } + if ( object->header.count == 0 ) { + free_object( pointer ); + pointer = nil; + } } - if ( object->header.count == 0 ) { - free_object( pointer ); - pointer = nil; - } return pointer; } /** * @brief Prevent an object ever being dereferenced. - * + * * @param pointer pointer to an object to lock. * * @return the `pointer` @@ -257,24 +269,27 @@ struct pso_pointer free_object( struct pso_pointer pointer ) { result = destroy( pointer ); - /* will C just let me cheerfully walk off the end of the array I've declared? */ + /* will C just let me cheerfully walk off the end of the array I've + * declared? */ for ( int i = 0; i < array_size; i++ ) { object->payload.words[i] = 0; } - #ifdef DEBUG - debug_printf( DEBUG_ALLOC, 0, - L"Freeing object of type %3.3s, size class %d, at page %d, offset %d.\n", - ( ( char * ) ( object->header.tag.bytes.mnemonic ) ), - (int)object->header.tag.bytes.size_class, - pointer.page, pointer.offset, object->header.count - ); - - allocation_table[size_class][allocation_table_freed]++; - #endif - - strncpy((char*) (object->header.tag.bytes. - mnemonic ), FREETAG, TAGLENGTH ); +#ifdef DEBUG + debug_printf( DEBUG_ALLOC, 0, + L"Freeing object of type %3.3s, size class %d, at page %d, " + L"offset %d.\n", + ( ( char * ) ( object->header.tag.bytes.mnemonic ) ), + ( int ) object->header.tag.bytes.size_class, pointer.page, + pointer.offset, object->header.count ); + + allocation_table[size_class][allocation_table_freed]++; +#endif + + strncpy( ( char * ) ( object->header.tag.bytes.mnemonic ), FREETAG, + TAGLENGTH ); + object->header.count = ( uint8_t ) 0; + object->header.access = nil; push_freelist( pointer ); return result; diff --git a/src/c/memory/pso.h b/src/c/memory/pso.h index 45bfdce..8643163 100644 --- a/src/c/memory/pso.h +++ b/src/c/memory/pso.h @@ -28,6 +28,6 @@ struct pso_pointer lock_object( struct pso_pointer pointer ); struct pso_pointer free_object( struct pso_pointer p ); #ifdef DEBUG -void print_allocation_table(); +void print_allocation_table( ); #endif #endif diff --git a/src/c/ops/assoc.c b/src/c/ops/assoc.c index d61f6e8..9e5672d 100644 --- a/src/c/ops/assoc.c +++ b/src/c/ops/assoc.c @@ -11,6 +11,7 @@ #include +#include "debug.h" #include "memory/node.h" #include "memory/pointer.h" #include "memory/pso2.h" @@ -40,15 +41,31 @@ struct pso_pointer search( struct pso_pointer key, struct pso_pointer result = nil; bool found = false; +#ifdef DEBUG + debug_print( L"In search; key is: ", DEBUG_BIND, 0 ); + debug_print_object( key, DEBUG_BIND, 0 ); + debug_println( DEBUG_BIND ); +#endif + if ( consp( store ) ) { for ( struct pso_pointer cursor = store; consp( cursor ) && found == false; cursor = c_cdr( cursor ) ) { struct pso_pointer pair = c_car( cursor ); +#ifdef DEBUG + debug_print( L"Checking ", DEBUG_BIND, 2 ); + debug_print_object( pair, DEBUG_BIND, 0 ); +#endif if ( consp( pair ) && c_equal( c_car( pair ), key ) ) { found = true; result = return_key ? c_car( pair ) : c_cdr( pair ); +#ifdef DEBUG + debug_print( L" ...found!", DEBUG_BIND, 0 ); +#endif } +#ifdef DEBUG + debug_println( DEBUG_BIND ); +#endif } } @@ -108,8 +125,8 @@ struct pso_pointer assoc( struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer store = or( make_frame( 2, frame_pointer, fetch_arg( frame, 1 ), - frame->payload.stack_frame. - env ) ); + frame->payload. + stack_frame.env ) ); return c_assoc( key, store ); } @@ -130,8 +147,8 @@ struct pso_pointer interned( struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer store = or( make_frame( 2, frame_pointer, fetch_arg( frame, 1 ), - frame->payload.stack_frame. - env ) ); + frame->payload. + stack_frame.env ) ); return c_interned( key, store ); } @@ -152,8 +169,8 @@ struct pso_pointer internedp( struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer store = or( make_frame( 2, frame_pointer, fetch_arg( frame, 1 ), - frame->payload.stack_frame. - env ) ); + frame->payload. + stack_frame.env ) ); return c_internedp( key, store ) ? t : nil; } diff --git a/src/c/ops/eq.c b/src/c/ops/eq.c index 60c5316..f350d5a 100644 --- a/src/c/ops/eq.c +++ b/src/c/ops/eq.c @@ -41,7 +41,7 @@ bool c_eq( struct pso_pointer a, struct pso_pointer b ) { } bool c_equal( struct pso_pointer a, struct pso_pointer b ) { - bool result = true; + bool result = false; if ( c_eq( a, b ) ) { result = true; @@ -73,6 +73,7 @@ bool c_equal( struct pso_pointer a, struct pso_pointer b ) { b = c_cdr( b ); } else { result = false; + break; } } result = result && c_nilp( a ) && c_nilp( b ); diff --git a/src/c/ops/eval_apply.c b/src/c/ops/eval_apply.c index c95513c..e26fc1c 100644 --- a/src/c/ops/eval_apply.c +++ b/src/c/ops/eval_apply.c @@ -10,14 +10,25 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#include +#include +#include +#include +#include + + +#include "debug.h" #include "memory/node.h" #include "memory/pointer.h" #include "memory/pso.h" +#include "memory/pso2.h" #include "memory/pso3.h" #include "memory/pso4.h" #include "memory/tags.h" #include "ops/assoc.h" +#include "ops/bind.h" +#include "ops/reverse.h" #include "ops/stack_ops.h" #include "ops/string_ops.h" #include "ops/truth.h" @@ -26,79 +37,1638 @@ #include "payloads/function.h" #include "payloads/stack.h" -/** - * @brief Apply a function to arguments in an environment. +///** +// * @brief Apply a function to arguments in an environment. +// * +// * * (apply fn args) +// */ +//struct pso_pointer apply( struct pso_pointer frame_pointer ) { +// +//// TODO. +// +//} +// +///** +// * @brief Evaluate a form, in an environment +// * +// * * (eval form) +// */ +//struct pso_pointer eval( struct pso_pointer frame_pointer ) { +// struct pso4 *frame = pointer_to_pso4( frame_pointer ); +// +// struct pso_pointer arg = fetch_arg( frame, 0 ); +// struct pso_pointer result = nil; +// +// if ( !c_c_nilp( arg ) ) { +// switch ( get_tag_value( arg ) ) { +// // case CONSTV: +// // result = eval_cons( frame, frame_pointer, env); +// // break; +// case INTEGERTV: +// case KEYTV: +// case NILTV: +// case STRINGTV: +// // self evaluating +// result = nil; +// break; +// case SYMBOLTV: +// result = c_assoc( arg, fetch_env( frame_pointer ) ); +// break; +// // case LAMBDATV: +// // result = eval_lambda( frame, frame_pointer, env); +// // break; +// // case NLAMBDATV: +// // result = eval_nlambda( frame, frame_pointer, env); +// // break; +// // case SPECIALTV: +// // result = eval_special( frame, frame_pointer, env); +// // break; +// default: +//#ifdef DEBUG +// struct pso2 *object = pointer_to_object( arg ); +// debug_printf( DEBUG_EVAL, 0, +// L"Can't yet evaluate objects of type %3.3s\n", +// object->header.tag.bytes.mnemonic[0] ); +// debug_print_object( arg, DEBUG_EVAL, 2 ); +// debug_println( DEBUG_EVAL, 0 ); +//#endif +// result = make_exception( make_frame( 1, frame_pointer, +// make_cons( frame_pointer, +// c_string_to_lisp_string +// ( frame_pointer, +// L"Can't yet evaluate things of this type: " ), +// arg ), +// make_cons( frame_pointer, +// make_cons +// ( frame_pointer, +// c_string_to_lisp_keyword +// ( frame_pointer, +// L"tag" ), +// get_tag_string +// ( frame_pointer, +// arg ) ), +// nil ), nil ) ); +// } +// } +// +// if ( exceptionp( result ) ) { +// struct pso3 *x = +// ( struct pso3 * ) pointer_to_object_with_tag_value( result, +// EXCEPTIONTV ); +// +// if ( c_c_nilp( x->payload.exception.stack ) ) { +// x->payload.exception.stack = frame_pointer; +// } +// } +// +// return result; +//} +/* + * lispops.c * - * * (apply fn args) + * List processing operations. + * + * The general idea here is that a list processing operation is a + * function which takes two arguments, both pso_pointers: + * + * 1. args, the argument list to this function; + * 2. env, the environment in which this function should be evaluated; + * + * and returns a pso_pointer, the result. + * + * They must all have the same signature so that I can call them as + * function pointers. + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. */ -struct pso_pointer apply( struct pso_pointer frame_pointer ) { -// TODO. +/** + * Useful building block; evaluate this single form in the context of this + * parent stack frame and this environment. + * @param parent the parent stack frame. + * @param form the form to be evaluated. + * @param env the evaluation environment. + * @return the result of evaluating the form. + */ +struct pso_pointer eval_form( struct pso_pointer frame_pointer ) { + struct pso_pointer form = + pointer_to_pso4( frame_pointer )->payload.stack_frame.arg[0]; +#ifdef DEBUG + debug_print( L"eval_form: ", DEBUG_EVAL, 0 ); + debug_print_object( form, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL, 0 ); +#endif + struct pso_pointer result = form; + switch ( pointer_to_object( form )->header.tag.value & 0xfffff ) { + /* things which evaluate to themselves */ + case EXCEPTIONTV: + case FREETV: // shouldn't happen, but anyway... + case INTEGERTV: + case KEYTV: + case LOOPTV: // don't think this should happen... + case NILTV: + case RATIOTV: + case REALTV: + case READTV: + case STRINGTV: + case TIMETV: + case TRUETV: + case WRITETV: + break; + default: + { + struct pso_pointer next_pointer = + make_frame( 0, frame_pointer ); + + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct pso4 *next = pointer_to_pso4( next_pointer ); + next->payload.stack_frame.arg[0] = form; + next->payload.stack_frame.args = 1; + + result = + push_local( frame_pointer, lisp_eval( next_pointer ) ); + + if ( !exceptionp( result ) ) { + /* if we're returning an exception, we should NOT free the + * stack frame. Corollary is, when we free an exception, we + * should free all the frames it's holding on to. */ + dec_ref( next_pointer ); + } + } + } + break; + } + + debug_print( L"eval_form ", DEBUG_EVAL, 0 ); + debug_print_object( form, DEBUG_EVAL, 0 ); + debug_print( L" returning: ", DEBUG_EVAL, 0 ); + debug_print_object( result, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL, 0 ); + + return result; } /** - * @brief Evaluate a form, in an environment - * - * * (eval form) + * Evaluate all the forms in this `list` in the context of this stack `frame` + * and this `env`, and return a list of their values. If the arg passed as + * `list` is not in fact a list, return nil. + * @param frame the stack frame. + * @param list the list of forms to be evaluated. + * @param env the evaluation environment. + * @return a list of the the results of evaluating the forms. */ -struct pso_pointer eval( struct pso_pointer frame_pointer ) { - struct pso4 *frame = pointer_to_pso4( frame_pointer ); - - struct pso_pointer arg = fetch_arg( frame, 0 ); +struct pso_pointer eval_forms( struct pso_pointer frame_pointer ) { + struct pso_pointer list = + pointer_to_pso4( frame_pointer )->payload.stack_frame.arg[0]; struct pso_pointer result = nil; - switch ( get_tag_value( arg ) ) { - // case CONSTV: - // result = eval_cons( frame, frame_pointer, env); - // break; - case INTEGERTV: - case KEYTV: - case STRINGTV: - // self evaluating - result = nil; - break; - case SYMBOLTV: - arg = c_assoc( arg, fetch_env( frame_pointer ) ); - break; - // case LAMBDATV: - // result = eval_lambda( frame, frame_pointer, env); - // break; - // case NLAMBDATV: - // result = eval_nlambda( frame, frame_pointer, env); - // break; - // case SPECIALTV: - // result = eval_special( frame, frame_pointer, env); - // break; - default: - arg = - make_exception( make_frame( 1, frame_pointer, - make_cons( frame_pointer, - c_string_to_lisp_string - ( frame_pointer, - L"Can't yet evaluate things of this type: " ), - arg ), - make_cons( frame_pointer, - make_cons - ( frame_pointer, - c_string_to_lisp_keyword - ( frame_pointer, - L"tag" ), - get_tag_string - ( frame_pointer, - arg ) ), nil ), - nil ) ); + while ( consp( list ) ) { + struct pso_pointer next_pointer = + inc_ref( make_frame( 1, frame_pointer, c_car( list ) ) ); + result = push_local( frame_pointer, + make_cons( frame_pointer, + eval_form( next_pointer ), result ) ); + list = c_cdr( list ); + + dec_ref( next_pointer ); } - if ( exceptionp( arg ) ) { - struct pso3 *x = - ( struct pso3 * ) pointer_to_object_with_tag_value( arg, - EXCEPTIONTV ); + return c_reverse( result ); +} - if ( c_nilp( x->payload.exception.stack ) ) { +/** + * OK, the idea here (and I know this is less than perfect) is that the basic `try` + * special form in PSSE takes two arguments, the first, `body`, being a list of forms, + * and the second, `catch`, being a catch handler (which is also a list of forms). + * Forms from `body` are evaluated in turn until one returns an exception object, + * or until the list is exhausted. If the list was exhausted, then the value of + * evaluating the last form in `body` is returned. If an exception was encountered, + * then each of the forms in `catch` is evaluated and the value of the last of + * those is returned. + * + * This is experimental. It almost certainly WILL change. + */ +struct pso_pointer lisp_try( struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso_pointer body_frame = + inc_ref( make_frame( 1, frame_pointer, fetch_arg( frame, 0 ) ) ); + result = push_local( frame_pointer, progn( body_frame ) ); + + dec_ref( body_frame ); + + if ( exceptionp( result ) ) { + // TODO: need to put the exception into the environment! + struct pso_pointer catch_frame = + inc_ref( make_frame_with_env( 1, frame_pointer, + make_cons( frame_pointer, + make_cons( frame_pointer, + c_string_to_lisp_symbol + ( frame_pointer, + L"*exception*" ), + result ), + fetch_env + ( frame_pointer ) ), + frame->payload.stack_frame. + arg[1] ) ); + result = push_local( progn( catch_frame ) ); + + dec_ref( catch_frame ); + } + + return result; +} + + +/** + * Return the object list (root namespace). + * + * * (oblist) + * + * @param frame the stack frame in which the expression is to be interpreted; + * @param frame_pointer a pointer to my pso4. + * @param env my environment (ignored). + * @return the root namespace. + */ +struct pso_pointer +lisp_oblist( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + return oblist; +} + +/** + * Used to construct the body for `lambda` and `nlambda` expressions. + */ +struct pso_pointer compose_body( struct pso_pointer frame_pointer ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso_pointer body = frame->payload.stack_frame.more; + + for ( int i = args_in_frame - 1; i > 0; i-- ) { + if ( !c_nilp( body ) ) { + body = + make_cons( frame_pointer, frame->payload.stack_frame.arg[i], + body ); + } else if ( !c_nilp( frame->payload.stack_frame.arg[i] ) ) { + body = + make_cons( frame_pointer, frame->payload.stack_frame.arg[i], + body ); } } - return arg; + debug_print( L"compose_body returning ", DEBUG_LAMBDA, 0 ); + debug_dump_object( body, DEBUG_LAMBDA, 0 ); + + return body; +} + +/** + * Construct an interpretable function. *NOTE* that if `args` is a single symbol + * rather than a list, a varargs function will be created. + * + * (lambda args body) + * + * @param frame the stack frame in which the expression is to be interpreted; + * @param frame_pointer a pointer to my pso4. + * @param env the environment in which it is to be intepreted. + * @return an interpretable function with these `args` and this `body`. + */ +//struct pso_pointer +//lisp_lambda( struct pso_pointer frame_pointer ) { +// return make_lambda( frame_pointer, frame->payload.stack_frame.arg[0], compose_body( frame_pointer ) ); +//} + +/** + * Construct an interpretable special form. *NOTE* that if `args` is a single symbol + * rather than a list, a varargs special form will be created. + * + * (nlambda args body) + * + * @param frame the stack frame in which the expression is to be interpreted; + * @param frame_pointer a pointer to my pso4. + * @param env the environment in which it is to be intepreted. + * @return an interpretable special form with these `args` and this `body`. + */ +//struct pso_pointer +//lisp_nlambda( struct pso_pointer frame_pointer, +// struct pso_pointer env ) { +// return make_nlambda( frame->payload.stack_frame.arg[0], compose_body( frame_pointer ) ); +//} + + +/** + * Evaluate a lambda or nlambda expression. + */ +struct pso_pointer +eval_lambda( struct pso4 *frame, + struct pso_pointer frame_pointer, struct pso_pointer env ) { + struct pso_pointer result = nil; + struct pso2 *cell = + pointer_to_object( fetch_arg( pointer_to_pso4( frame_pointer ), 0 ) ); + struct pso_pointer new_env = fetch_env( frame_pointer ); + struct pso_pointer names = cell->payload.lambda.args; + struct pso_pointer body = cell->payload.lambda.body; +#ifdef DEBUG + debug_print( L"eval_lambda called\n", DEBUG_LAMBDA, 0 ); + debug_println( DEBUG_LAMBDA ); +#endif + + if ( consp( names ) ) { + /* if `names` is a list, bind successive items from that list + * to values of arguments */ + for ( int i = 0; i < frame->payload.stack_frame.args && consp( names ); + i++ ) { + struct pso_pointer name = c_car( names ); + struct pso_pointer val = frame->payload.stack_frame.arg[i]; + + new_env = + make_cons( frame_pointer, + make_cons( frame_pointer, name, val ), new_env ); + //debug_print_binding( name, val, false, DEBUG_BIND ); + + names = c_cdr( names ); + } + + /* \todo if there's more than `args_in_frame` arguments, bind those too. */ + } else if ( symbolp( names ) ) { + /* if `names` is a symbol, rather than a list of symbols, + * then bind a list of the values of args to that symbol. */ + /* \todo eval all the things in frame->payload.stack_frame.more */ +// struct pso_pointer vals = +// eval_forms( frame, frame_pointer, frame->payload.stack_frame.more, env ); + + for ( int i = args_in_frame - 1; i >= 0; i-- ) { + struct pso_pointer next = + make_frame( 1, frame_pointer, fetch_arg( frame, i ) ); + struct pso_pointer val = + push_local( frame_pointer, eval_form( next ) ); + + if ( c_nilp( val ) && c_nilp( vals ) ) { /* nothing */ + } else { + vals = make_cons( frame_pointer, val, vals ); + } + } + + new_env = + make_cons( frame_pointer, make_cons( frame_pointer, names, vals ), + new_env ); + } + + while ( !c_nilp( body ) ) { + struct pso_pointer sexpr = c_car( body ); + body = c_cdr( body ); + + debug_print( L"In lambda: evaluating ", DEBUG_LAMBDA, 0 ); + debug_print_object( sexpr, DEBUG_LAMBDA, 0 ); + // debug_print( L"\t env is: ", DEBUG_LAMBDA , 0); + // debug_print_object( new_env, DEBUG_LAMBDA ); + debug_println( DEBUG_LAMBDA ); + + struct pso_pointer lambda_frame = + inc_ref( make_frame_with_env( 1, frame_pointer, new_env, sexpr ) ); + + result = push_local( frame_pointer, eval_form( lambda_frame ) ); + + dec_ref( lambda_frame ); + + if ( exceptionp( result ) ) { + break; + } + } + + debug_print( L"eval_lambda returning: \n", DEBUG_LAMBDA, 0 ); + debug_print_object( result, DEBUG_LAMBDA, 0 ); + debug_println( DEBUG_LAMBDA ); + + return result; +} + +/** + * if `r` is an exception, and it doesn't have a location, fix up its location from + * the name associated with this fn_pointer, if any. + */ +struct pso_pointer maybe_fixup_exception_location( struct pso_pointer r, + struct pso_pointer + fn_pointer ) { + struct pso_pointer result = r; + + if ( exceptionp( result ) + && ( functionp( fn_pointer ) || specialp( fn_pointer ) ) ) { + struct pso2 **fn_cell = pointer_to_object( fn_pointer ); + + struct pso_pointer payload = + pointer_to_object( result ).payload.exception.payload; + + switch ( get_header.tag.bytes.value & 0xfffff( payload ) ) { + case nilTV: + case CONSTV: + case HASHTV: + { + if ( c_nilp( c_assoc( privileged_keyword_location, + payload ) ) ) { + pointer_to_object( result ).payload.exception.payload = + set( privileged_keyword_location, + c_assoc( privileged_keyword_name, + fn_cell->payload.function.meta ), + payload ); + } + } + break; + default: + pointer_to_object( result ).payload.exception.payload = + cons( cons( privileged_keyword_location, + c_assoc( privileged_keyword_name, + fn_cell->payload.function.meta ) ), + cons( cons + ( privileged_keyword_payload, + payload ), nil ) ); + } + } + + return result; +} + + +/** + * Internal guts of apply. + * @param frame the stack frame, expected to have only one argument, a list + * comprising something that evaluates to a function and its arguments. + * @param env The evaluation environment. + * @return the result of evaluating the function with its arguments. + */ +struct pso_pointer +c_apply( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + debug_print( L"Entering c_apply\n", DEBUG_EVAL, 0 ); + struct pso_pointer result = nil; + + struct pso_pointer fn_pointer = + eval_form( frame, frame_pointer, + c_car( frame->payload.stack_frame.arg[0] ), env ); + + if ( exceptionp( fn_pointer ) ) { + result = fn_pointer; + } else { + struct pso2 **fn_cell = pointer_to_object( fn_pointer ); + struct pso_pointer args = c_cdr( frame->payload.stack_frame.arg[0] ); + + switch ( get_header.tag.bytes.value & 0xfffff( fn_pointer ) ) { + case EXCEPTIONTV: + /* just pass exceptions straight back */ + result = fn_pointer; + break; + + case FUNCTIONTV: + { + struct pso_pointer exep = nil; + struct pso_pointer next_pointer = + make_pso4( frame_pointer, args, env ); + + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct pso4 *next = pointer_to_pso4( next_pointer ); + + result = maybe_fixup_exception_location( ( * + ( fn_cell-> + payload. + function. + executable ) ) + ( next, + next_pointer, + env ), + fn_pointer ); + dec_ref( next_pointer ); + } + } + break; + + case KEYTV: + result = c_assoc( fn_pointer, + eval_form( frame, + frame_pointer, + c_car( c_cdr + ( frame->payload. + stack_frame.arg[0] ) ), + env ) ); + break; + + case LAMBDATV: + { + struct pso_pointer exep = nil; + struct pso_pointer next_pointer = + make_pso4( frame_pointer, args, env ); + + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct pso4 *next = pointer_to_pso4( next_pointer ); + result = + eval_lambda( fn_cell, next, next_pointer, env ); + if ( !exceptionp( result ) ) { + dec_ref( next_pointer ); + } + } + } + break; + + case HASHTV: + /* \todo: if arg[0] is a CONS, treat it as a path */ + result = c_assoc( eval_form( frame, + frame_pointer, + c_car( c_cdr + ( frame->payload. + stack_frame.arg[0] ) ), + env ), fn_pointer ); + break; + + case NLAMBDATV: + { + struct pso_pointer next_pointer = + make_special_frame( frame_pointer, args, env ); + + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct pso4 *next = pointer_to_pso4( next_pointer ); + result = + eval_lambda( fn_cell, next, next_pointer, env ); + dec_ref( next_pointer ); + } + } + break; + + case SPECIALTV: + { + struct pso_pointer next_pointer = + make_special_frame( frame_pointer, args, env ); + + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + result = maybe_fixup_exception_location( ( * + ( fn_cell-> + payload. + special. + executable ) ) + ( pointer_to_pso4( next_pointer ), next_pointer, env ), fn_pointer ); + debug_print( L"Special form returning: ", DEBUG_EVAL, + 0 ); + debug_print_object( result, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL, 0 ); + dec_ref( next_pointer ); + } + } + break; + + default: + { + int bs = sizeof( wchar_t ) * 1024; + wchar_t *buffer = malloc( bs ); + memset( buffer, '\0', bs ); + swprintf( buffer, bs, + L"Unexpected cell with tag %d (%4.4s) in function position", + fn_cell->header.tag.bytes.value & 0xfffff, + &( fn_cell->tag.bytes[0] ) ); + struct pso_pointer message = + c_string_to_lisp_string( buffer ); + free( buffer ); + result = + throw_exception( c_string_to_lisp_symbol( L"apply" ), + message, frame_pointer ); + } + } + + } + + debug_print( L"c_apply: returning: ", DEBUG_EVAL, 0 ); + debug_print_object( result, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL, 0 ); + + return result; +} + +/** + * Function; evaluate the expression which is the first argument in the frame; + * further arguments are ignored. + * + * * (eval expression) + * + * @param frame my pso4. + * @param frame_pointer a pointer to my pso4. + * @param env my environment. + * @return + * * If `expression` is a number, string, `nil`, or `t`, returns `expression`. + * * If `expression` is a symbol, returns the value that expression is bound + * to in the evaluation environment (`env`). + * * If `expression` is a list, expects the car to be something that evaluates to a + * function or special form: + * * If a function, evaluates all the other top level elements in `expression` and + * passes them in a stack frame as arguments to the function; + * * 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`. + */ +struct pso_pointer +lisp_eval( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + debug_print( L"Eval: ", DEBUG_EVAL, 0 ); + debug_dump_object( frame_pointer, DEBUG_EVAL, 0 ); + + struct pso_pointer result = frame->payload.stack_frame.arg[0]; + struct pso2 **cell = + pointer_to_object( frame->payload.stack_frame.arg[0] ); + + switch ( cell->header.tag.bytes.value & 0xfffff ) { + case CONSTV: + result = c_apply( frame, frame_pointer, env ); + break; + + case SYMBOLTV: + { + struct pso_pointer canonical = + interned( frame->payload.stack_frame.arg[0], env ); + if ( c_nilp( canonical ) ) { + struct pso_pointer message = + cons( c_string_to_lisp_string + ( L"Attempt to take value of unbound symbol." ), + frame->payload.stack_frame.arg[0] ); + result = + throw_exception( c_string_to_lisp_symbol( L"eval" ), + message, frame_pointer ); + } else { + result = c_assoc( canonical, env ); +// inc_ref( result ); + } + } + break; + /* + * \todo + * the Clojure practice of having a map serve in the function place of + * an s-expression is a good one and I should adopt it; + * H'mmm... this is working, but it isn't here. Where is it? + */ + default: + result = frame->payload.stack_frame.arg[0]; + break; + } + + debug_print( L"Eval returning ", DEBUG_EVAL, 0 ); + debug_dump_object( result, DEBUG_EVAL, 0 ); + + return result; +} + + +/** + * Function; apply the function which is the result of evaluating the + * first argument to the list of values which is the result of evaluating + * the second argument + * + * * (apply fn args) + * + * @param frame my pso4. + * @param frame_pointer a pointer to my pso4. + * @param env my environment. + * @return the result of applying `fn` to `args`. + */ +struct pso_pointer +lisp_apply( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + debug_print( L"Apply: ", DEBUG_EVAL, 0 ); + debug_dump_object( frame_pointer, DEBUG_EVAL, 0 ); + + set_reg( frame, 0, + cons( frame->payload.stack_frame.arg[0], + frame->payload.stack_frame.arg[1] ) ); + set_reg( frame, 1, nil ); + + struct pso_pointer result = c_apply( frame, frame_pointer, env ); + + debug_print( L"Apply returning ", DEBUG_EVAL, 0 ); + debug_dump_object( result, DEBUG_EVAL, 0 ); + + return result; +} + + +/** + * Special form; + * returns its argument (strictly first argument - only one is expected but + * this isn't at this stage checked) unevaluated. + * + * * (quote a) + * + * @param frame my pso4. + * @param frame_pointer a pointer to my pso4. + * @param env my environment (ignored). + * @return `a`, unevaluated, + */ +struct pso_pointer +lisp_quote( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + return frame->payload.stack_frame.arg[0]; +} + + +/** + * Function; + * binds the value of `name` in the `namespace` to value of `value`, altering + * the namespace in so doing. Retuns `value`. + * `namespace` defaults to the oblist. + * \todo doesn't actually work yet for namespaces which are not the oblist. + * + * * (set name value) + * * (set name value namespace) + * + * @param frame my pso4. + * @param frame_pointer a pointer to my pso4. + * @param env my environment (ignored). + * @return `value` + */ +struct pso_pointer +lisp_set( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + struct pso_pointer namespace = + c_nilp( frame->payload.stack_frame.arg[2] ) ? oblist : frame->payload. + stack_frame.arg[2]; + + if ( symbolp( frame->payload.stack_frame.arg[0] ) ) { + deep_bind( frame->payload.stack_frame.arg[0], + frame->payload.stack_frame.arg[1] ); + result = frame->payload.stack_frame.arg[1]; + } else { + result = + throw_exception( c_string_to_lisp_symbol( L"set" ), + cons + ( c_string_to_lisp_string + ( L"The first argument to `set` is not a symbol: " ), + cons( frame->payload.stack_frame.arg[0], + nil ) ), frame_pointer ); + } + + return result; +} + + +/** + * Special form; + * binds `symbol` in the `namespace` to value of `value`, altering + * the namespace in so doing, and returns value. `namespace` defaults to + * the value of `oblist`. + * \todo doesn't actually work yet for namespaces which are not the oblist. + * + * * (set! symbol value) + * * (set! symbol value namespace) + * + * @param frame my pso4. + * @param frame_pointer a pointer to my pso4. + * @param env my environment (ignored). + * @return `value` + */ +struct pso_pointer +lisp_set_shriek( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + struct pso_pointer namespace = frame->payload.stack_frame.arg[2]; + + if ( symbolp( frame->payload.stack_frame.arg[0] ) ) { + struct pso_pointer val = + eval_form( frame, frame_pointer, frame->payload.stack_frame.arg[1], + env ); + deep_bind( frame->payload.stack_frame.arg[0], val ); + result = val; + } else { + result = + throw_exception( c_string_to_lisp_symbol( L"set!" ), + cons + ( c_string_to_lisp_string + ( L"The first argument to `set!` is not a symbol: " ), + cons( frame->payload.stack_frame.arg[0], + nil ) ), frame_pointer ); + } + + return result; +} + +/** + * @return t if `arg` represents an end of string, else false. + * \todo candidate for moving to a memory/string.c file + */ +bool end_of_stringp( struct pso_pointer arg ) { + return c_nilp( arg ) || + ( stringp( arg ) && + pointer_to_object( arg ).payload.string.character == + ( wint_t ) '\0' ); +} + +/** + * Function; look up the value of a `key` in a `store`. + * + * * (assoc key store) + * + * @param frame my pso4. + * @param frame_pointer a pointer to my pso4. + * @param env my environment (ignored). + * @return the value associated with `key` in `store`, or `nil` if not found. + */ +struct pso_pointer +lisp_assoc( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + return c_assoc( frame->payload.stack_frame.arg[0], + c_nilp( frame->payload.stack_frame. + arg[1] ) ? oblist : frame->payload.stack_frame. + arg[1] ); +} + +/** + * @brief `(interned? key store)`: Return `t` if the symbol or keyword `key` is bound in this `store`, else `nil`. + * + * @param frame + * @param frame_pointer + * @param env + * @return struct pso_pointer + */ +struct pso_pointer +lisp_internedp( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = internedp( frame->payload.stack_frame.arg[0], + c_nilp( frame->payload.stack_frame. + arg[1] ) ? oblist : frame-> + payload.stack_frame.arg[1] ); + + if ( exceptionp( result ) ) { + struct pso_pointer old = result; + struct pso2 **cell = &( pointer_to_object( result ) ); + result = + throw_exception( c_string_to_lisp_symbol( L"interned?" ), + cell->payload.exception.payload, frame_pointer ); + dec_ref( old ); + } + + return result; +} + +struct pso_pointer c_keys( struct pso_pointer store ) { + struct pso_pointer result = nil; + + if ( consp( store ) ) { + for ( struct pso_pointer pair = c_car( store ); !c_nilp( pair ); + pair = c_car( store ) ) { + if ( consp( pair ) ) { + result = cons( c_car( pair ), result ); + } else if ( hashmapp( pair ) ) { + result = c_append( hashmap_keys( pair ), result ); + } + + store = c_cdr( store ); + } + } else if ( hashmapp( store ) ) { + result = hashmap_keys( store ); + } + + return result; +} + + + +struct pso_pointer lisp_keys( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + return c_keys( frame->payload.stack_frame.arg[0] ); +} + +/** + * Function: return the number of top level forms in the object which is + * the first (and only) argument, if it is a sequence (which for current + * purposes means a list or a string) + * + * * (count l) + * + * @param frame my pso4. + * @param frame_pointer a pointer to my pso4. + * @param env my environment (ignored). + * @return the number of top level forms in a list, or characters in a + * string, else 0. + */ +struct pso_pointer +lisp_count( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + return acquire_integer( c_count( frame->payload.stack_frame.arg[0] ), + nil ); +} + + + + +/** + * Function; reverse the order of members in s sequence. + * + * * (reverse sequence) + * + * @param frame my pso4. + * @param frame_pointer a pointer to my pso4. + * @param env my environment (ignored). + * @return a sequence like this `sequence` but with the members in the reverse order. + */ +struct pso_pointer lisp_reverse( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + return c_reverse( frame->payload.stack_frame.arg[0] ); +} + + + +/** + * Function: get the Lisp type of the single argument. + * + * * (type expression) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my pso4. + * @param env my environment (ignored). + * @return As a Lisp string, the tag of `expression`. + */ +struct pso_pointer +lisp_type( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + return c_type( frame->payload.stack_frame.arg[0] ); +} + +/** + * Evaluate each of these expressions in this `env`ironment over this `frame`, + * returning only the value of the last. + */ +struct pso_pointer +c_progn( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer expressions, struct pso_pointer env ) { + struct pso_pointer result = nil; + + while ( consp( expressions ) ) { + struct pso_pointer r = result; + + result = eval_form( frame, frame_pointer, c_car( expressions ), env ); + dec_ref( r ); + + expressions = exceptionp( result ) ? nil : c_cdr( expressions ); + } + + return result; +} + + +/** + * Special form; evaluate the expressions which are listed in my arguments + * sequentially and return the value of the last. This function is called 'do' + * in some dialects of Lisp. + * + * * (progn expressions...) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my pso4. + * @param env the environment in which expressions are evaluated. + * @return the value of the last `expression` of the sequence which is my single + * argument. + */ +struct pso_pointer +lisp_progn( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + + for ( int i = 0; + i < args_in_frame && !c_nilp( frame->payload.stack_frame.arg[i] ); + i++ ) { + struct pso_pointer r = result; + + result = + eval_form( frame, frame_pointer, frame->payload.stack_frame.arg[i], + env ); + + dec_ref( r ); + } + + if ( consp( frame->payload.stack_frame.more ) ) { + result = + c_progn( frame, frame_pointer, frame->payload.stack_frame.more, + env ); + } + + return result; +} + +/** + * @brief evaluate a single cond clause; if the test part succeeds return a + * pair whose car is t and whose cdr is the value of the action part + */ +struct pso_pointer eval_cond_clause( struct pso_pointer clause, + struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + +#ifdef DEBUG + debug_print( L"\n\tCond clause: ", DEBUG_EVAL, 0 ); + debug_print_object( clause, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL, 0 ); +#endif + + if ( consp( clause ) ) { + struct pso_pointer val = + eval_form( frame, frame_pointer, c_car( clause ), + env ); + + if ( !c_nilp( val ) ) { + result = + cons( t, + c_progn( frame, frame_pointer, c_cdr( clause ), env ) ); + +#ifdef DEBUG + debug_print( L"\n\t\tCond clause ", DEBUG_EVAL, 0 ); + debug_print_object( clause, DEBUG_EVAL, 0 ); + debug_print( L" succeeded; returning: ", DEBUG_EVAL, 0 ); + debug_print_object( result, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL, 0 ); + } else { + debug_print( L"\n\t\tCond clause ", DEBUG_EVAL, 0 ); + debug_print_object( clause, DEBUG_EVAL, 0 ); + debug_print( L" failed.\n", DEBUG_EVAL, 0 ); +#endif + } + } else { + result = throw_exception( c_string_to_lisp_symbol( L"cond" ), + c_string_to_lisp_string + ( L"Arguments to `cond` must be lists" ), + frame_pointer ); + } + + return result; +} + +/** + * Special form: conditional. Each `clause` is expected to be a list; if the first + * item in such a list evaluates to non-nil, the remaining items in that list + * are evaluated in turn and the value of the last returned. If no arg `clause` + * has a first element which evaluates to non nil, then nil is returned. + * + * * (cond clauses...) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my pso4. + * @param env the environment in which arguments will be evaluated. + * @return the value of the last expression of the first successful `clause`. + */ +struct pso_pointer +lisp_cond( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + bool done = false; + + for ( int i = 0; ( i < frame->payload.stack_frame.args ) && !done; i++ ) { + struct pso_pointer clause_pointer = fetch_arg( frame, i ); + + result = eval_cond_clause( clause_pointer, frame, frame_pointer, env ); + + if ( !c_nilp( result ) && tp( c_car( result ) ) ) { + result = c_cdr( result ); + done = t; + break; + } + } +#ifdef DEBUG + debug_print( L"\tCond returning: ", DEBUG_EVAL, 0 ); + debug_print_object( result, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL, 0 ); +#endif + + return result; +} + +/** + * Throw an exception with a cause. + * `throw_exception` is a misnomer, because it doesn't obey the calling signature of a + * lisp function; but it is nevertheless to be preferred to make_exception. A + * real `throw_exception`, which does, will be needed. + * object pointing to it. Then this should become a normal lisp function + * which expects a normally bound frame and environment, such that + * frame->payload.stack_frame.arg[0] is the payload, frame->payload.stack_frame.arg[1] is the cause, and frame->payload.stack_frame.arg[2] is the cons-space + * pointer to the frame in which the exception occurred. + */ +struct pso_pointer throw_exception_with_cause( struct pso_pointer location, + struct pso_pointer message, + struct pso_pointer cause, + struct pso_pointer + frame_pointer ) { + struct pso_pointer result = nil; + +#ifdef DEBUG + debug_print( L"\nERROR: `", 511, 0 ); + debug_print_object( message, 511 ); + debug_print( L"` at `", 511, 0 ); + debug_print_object( location, 511 ); + debug_print( L"`\n", 511, 0 ); + if ( !c_nilp( cause ) ) { + debug_print( L"\tCaused by: ", 511, 0 ); + debug_print_object( cause, 511 ); + debug_print( L"`\n", 511, 0 ); + } +#endif + struct pso2 **cell = pointer_to_object( message ); + + if ( cell->header.tag.bytes.value & 0xfffff == EXCEPTIONTV ) { + result = message; + } else { + result = + make_exception( cons + ( cons( privileged_keyword_location, + location ), + cons( cons + ( privileged_keyword_payload, + message ), + ( c_nilp( cause ) ? nil : + cons( cons + ( privileged_keyword_cause, + cause ), nil ) ) ) ), + frame_pointer ); + } + + return result; + +} + +/** + * Throw an exception. + * `throw_exception` is a misnomer, because it doesn't obey the calling signature of a + * lisp function; but it is nevertheless to be preferred to make_exception. A + * real `throw_exception`, which does, will be needed. + * object pointing to it. Then this should become a normal lisp function + * which expects a normally bound frame and environment, such that + * frame->payload.stack_frame.arg[0] is the payload, frame->payload.stack_frame.arg[1] is the cause, and frame->payload.stack_frame.arg[2] is the cons-space + * pointer to the frame in which the exception occurred. + */ +struct pso_pointer +throw_exception( struct pso_pointer location, + struct pso_pointer payload, + struct pso_pointer frame_pointer ) { + return throw_exception_with_cause( location, payload, nil, frame_pointer ); +} + +/** + * Function; create an exception. Exceptions are special in as much as if an + * exception is created in the binding of the arguments of any function, the + * function will return the exception rather than whatever else it would + * normally return. A function which detects a problem it cannot resolve + * *should* return an exception. + * + * * (exception message location) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my pso4. + * @param env the environment in which arguments will be evaluated. + * @return areturns an exception whose message is this `message`, and whose + * stack frame is the parent stack frame when the function is invoked. + * `message` does not have to be a string but should be something intelligible + * which can be read. + * If `message` is itself an exception, returns that instead. + */ +struct pso_pointer +lisp_exception( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer message = frame->payload.stack_frame.arg[0]; + + return exceptionp( message ) ? message : + throw_exception_with_cause( message, frame->payload.stack_frame.arg[1], + frame->payload.stack_frame.arg[2], + frame->previous ); +} + +/** + * Function: the read/eval/print loop. + * + * * (repl) + * * (repl prompt) + * * (repl prompt input_stream output_stream) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my pso4. + * @param env the environment in which epressions will be evaluated. + * @return the value of the last expression read. + */ +struct pso_pointer lisp_repl( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer expr = nil; + +#ifdef DEBUG + debug_print( L"Entering new inner REPL\n\tenv is `", DEBUG_REPL, 0 ); + debug_print_object( env, DEBUG_REPL ); + debug_print( L"`\n", DEBUG_REPL, 0 ); +#endif + + struct pso_pointer input = get_default_stream( t, env ); + struct pso_pointer output = get_default_stream( false, env ); + struct pso_pointer old_oblist = oblist; + struct pso_pointer new_env = env; + + if ( tp( frame->payload.stack_frame.arg[0] ) ) { + new_env = + set( prompt_name, frame->payload.stack_frame.arg[0], new_env ); + } + if ( readp( frame->payload.stack_frame.arg[1] ) ) { + new_env = + set( c_string_to_lisp_symbol( L"*in*" ), + frame->payload.stack_frame.arg[1], new_env ); + input = frame->payload.stack_frame.arg[1]; + } + if ( writep( frame->payload.stack_frame.arg[2] ) ) { + new_env = + set( c_string_to_lisp_symbol( L"*out*" ), + frame->payload.stack_frame.arg[2], new_env ); + output = frame->payload.stack_frame.arg[2]; + } + + inc_ref( input ); + inc_ref( output ); + inc_ref( prompt_name ); + + /* output should NEVER BE nil; but during development it has happened. + * To allow debugging under such circumstances, we need an emergency + * default. */ + URL_FILE *os = + !writep( output ) ? file_to_url_file( stdout ) : + pointer_to_object( output ).payload.stream.stream; + if ( !writep( output ) ) { + debug_print( L"WARNING: invalid output; defaulting!\n", + DEBUG_IO | DEBUG_REPL ); + } + + /* \todo this is subtly wrong. If we were evaluating + * (print (eval (read))) + * then the stack frame for read would have the stack frame for + * eval as parent, and it in turn would have the stack frame for + * print as parent. + */ + while ( readp( input ) && writep( output ) + && !url_feof( pointer_to_object( input ).payload.stream.stream ) ) { + /* OK, here's a really subtle problem: because lists are immutable, anything + * bound in the oblist subsequent to this function being invoked isn't in the + * environment. So, for example, changes to *prompt* or *log* made in the oblist + * are not visible. So copy changes made in the oblist into the enviroment. + * \todo the whole process of resolving symbol values needs to be revisited + * when we get onto namespaces. */ + /* OK, there's something even more subtle here if the root namespace is a map. + * H'mmmm... + * I think that now the oblist is a hashmap masquerading as a namespace, + * we should no longer have to do this. TODO: test, and if so, delete this + * statement. */ + if ( !eq( oblist, old_oblist ) ) { + struct pso_pointer cursor = oblist; + + while ( !c_nilp( cursor ) && !eq( cursor, old_oblist ) ) { + struct pso_pointer old_new_env = new_env; + debug_print + ( L"lisp_repl: copying new oblist binding into REPL environment:\n", + DEBUG_REPL ); + debug_print_object( c_car( cursor ), DEBUG_REPL ); + debug_println( DEBUG_REPL ); + + new_env = cons( c_car( cursor ), new_env ); + inc_ref( new_env ); + dec_ref( old_new_env ); + cursor = c_cdr( cursor ); + } + old_oblist = oblist; + } + + println( os ); + + struct pso_pointer prompt = c_assoc( prompt_name, new_env ); + if ( !c_nilp( prompt ) ) { + print( os, prompt ); + } + + expr = lisp_read( pointer_to_pso4( frame_pointer ), frame_pointer, + new_env ); + + if ( exceptionp( expr ) + && url_feof( pointer_to_object( input ).payload.stream.stream ) ) { + /* suppress printing end of stream exception */ + dec_ref( expr ); + break; + } + + println( os ); + + print( os, eval_form( frame, frame_pointer, expr, new_env ) ); + + dec_ref( expr ); + } + + if ( c_nilp( output ) ) { + free( os ); + } + dec_ref( input ); + dec_ref( output ); + dec_ref( prompt_name ); + dec_ref( new_env ); + + debug_printf( DEBUG_REPL, L"Leaving inner repl\n" ); + + return expr; +} + +/** + * Function. return the source code of the object which is its first argument, + * if it is an executable and has source code. + * + * * (source object) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my pso4. + * @param env the environment (ignored). + * @return the source of the `object` indicated, if it is a function, a lambda, + * an nlambda, or a spcial form; else `nil`. + */ +struct pso_pointer lisp_source( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + struct pso2 **cell = + pointer_to_object( frame->payload.stack_frame.arg[0] ); + struct pso_pointer source_key = c_string_to_lisp_keyword( L"source" ); + switch ( cell->header.tag.bytes.value & 0xfffff ) { + case FUNCTIONTV: + result = c_assoc( source_key, cell->payload.function.meta ); + break; + case SPECIALTV: + result = c_assoc( source_key, cell->payload.special.meta ); + break; + case LAMBDATV: + result = cons( c_string_to_lisp_symbol( L"lambda" ), + cons( cell->payload.lambda.args, + cell->payload.lambda.body ) ); + break; + case NLAMBDATV: + result = cons( c_string_to_lisp_symbol( L"nlambda" ), + cons( cell->payload.lambda.args, + cell->payload.lambda.body ) ); + break; + } + // \todo suffers from premature GC, and I can't see why! + inc_ref( result ); + + return result; +} + +/** + * A version of append which can conveniently be called from C. + */ +struct pso_pointer c_append( struct pso_pointer l1, struct pso_pointer l2 ) { + switch ( pointer_to_object( l1 ).header.tag.bytes.value & 0xfffff ) { + case CONSTV: + if ( pointer_to_object( l1 ).header.tag.bytes.value & 0xfffff == + pointer_to_object( l2 ).header.tag.bytes.value & 0xfffff ) { + if ( c_nilp( c_cdr( l1 ) ) ) { + return cons( c_car( l1 ), l2 ); + } else { + return cons( c_car( l1 ), c_append( c_cdr( l1 ), l2 ) ); + } + } else { + throw_exception( c_string_to_lisp_symbol( L"append" ), + c_string_to_lisp_string + ( L"Can't append: not same type" ), nil ); + } + break; + case KEYTV: + case STRINGTV: + case SYMBOLTV: + if ( pointer_to_object( l1 ).header.tag.bytes.value & 0xfffff == + pointer_to_object( l2 ).header.tag.bytes.value & 0xfffff ) { + if ( c_nilp( c_cdr( l1 ) ) ) { + return + make_string_like_thing( ( pointer_to_object + ( l1 ).payload.string. + character ), l2, + pointer_to_object( l1 ).header. + tag.bytes.value & 0xfffff ); + } else { + return + make_string_like_thing( ( pointer_to_object + ( l1 ).payload.string. + character ), + c_append( c_cdr( l1 ), l2 ), + pointer_to_object( l1 ).header. + tag.bytes.value & 0xfffff ); + } + } else { + throw_exception( c_string_to_lisp_symbol( L"append" ), + c_string_to_lisp_string + ( L"Can't append: not same type" ), nil ); + } + break; + default: + throw_exception( c_string_to_lisp_symbol( L"append" ), + c_string_to_lisp_string + ( L"Can't append: not a sequence" ), nil ); + break; + } +} + +/** + * should really be overwritten with a version in Lisp, since this is much easier to write in Lisp + */ +struct pso_pointer lisp_append( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = + fetch_arg( frame, ( frame->payload.stack_frame.args - 1 ) ); + + for ( int a = frame->payload.stack_frame.args - 2; a >= 0; a-- ) { + result = c_append( fetch_arg( frame, a ), result ); + } + + return result; +} + +struct pso_pointer lisp_mapcar( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + debug_print( L"Mapcar: ", DEBUG_EVAL, 0 ); + debug_dump_object( frame_pointer, DEBUG_EVAL, 0 ); + int i = 0; + + for ( struct pso_pointer c = frame->payload.stack_frame.arg[1]; tp( c ); + c = c_cdr( c ) ) { + struct pso_pointer expr = + cons( frame->payload.stack_frame.arg[0], cons( c_car( c ), nil ) ); + + debug_printf( DEBUG_EVAL, L"Mapcar %d, evaluating ", i ); + debug_print_object( expr, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL, 0 ); + + struct pso_pointer r = eval_form( frame, frame_pointer, expr, env ); + + if ( exceptionp( r ) ) { + result = r; + inc_ref( expr ); // to protect exception from the later dec_ref + break; + } else { + result = cons( r, result ); + } + debug_printf( DEBUG_EVAL, L"Mapcar %d, result is ", i++ ); + debug_print_object( result, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL, 0 ); + + dec_ref( expr ); + } + + result = consp( result ) ? c_reverse( result ) : result; + + debug_print( L"Mapcar returning: ", DEBUG_EVAL, 0 ); + debug_print_object( result, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL, 0 ); + + return result; +} + +/** + * @brief construct and return a list of arbitrarily many arguments. + * + * @param frame The stack frame. + * @param frame_pointer A pointer to the stack frame. + * @param env The evaluation environment. + * @return struct pso_pointer a pointer to the result + */ +struct pso_pointer lisp_list( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = frame->payload.stack_frame.more; + + for ( int a = + c_nilp( result ) ? frame->payload.stack_frame.args - + 1 : args_in_frame - 1; a >= 0; a-- ) { + result = cons( fetch_arg( frame, a ), result ); + } + + return result; +} + + + +/** + * Special form: evaluate a series of forms in an environment in which + * these bindings are bound. + * This is `let*` in Common Lisp parlance; `let` in Clojure parlance. + */ +struct pso_pointer lisp_let( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer bindings = env; + struct pso_pointer result = nil; + + for ( struct pso_pointer cursor = frame->payload.stack_frame.arg[0]; + tp( cursor ); cursor = c_cdr( cursor ) ) { + struct pso_pointer pair = c_car( cursor ); + struct pso_pointer symbol = c_car( pair ); + + if ( symbolp( symbol ) ) { + struct pso_pointer val = + eval_form( frame, frame_pointer, c_cdr( pair ), + bindings ); + + debug_print_binding( symbol, val, false, DEBUG_BIND ); + + bindings = cons( cons( symbol, val ), bindings ); + } else { + result = + throw_exception( c_string_to_lisp_symbol( L"let" ), + c_string_to_lisp_string + ( L"Let: cannot bind, not a symbol" ), + frame_pointer ); + break; + } + } + + debug_print( L"\nlet: bindings complete.\n", DEBUG_BIND, 0 ); + + /* i.e., no exception yet */ + for ( int form = 1; + !exceptionp( result ) && form < frame->payload.stack_frame.args; + form++ ) { + result = + eval_form( frame, frame_pointer, fetch_arg( frame, form ), + bindings ); + } + + /* release the local bindings as they go out of scope! **BUT** + * bindings were consed onto the front of env, so caution... */ + // for (struct pso_pointer cursor = bindings; !eq( cursor, env); cursor = c_cdr(cursor)) { + // dec_ref( cursor); + // } + + return result; + +} + +/** + * @brief Boolean `and` of arbitrarily many arguments. + * + * @param frame The stack frame. + * @param frame_pointer A pointer to the stack frame. + * @param env The evaluation environment. + * @return struct pso_pointer a pointer to the result + */ +struct pso_pointer lisp_and( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + bool accumulator = t; + struct pso_pointer result = frame->payload.stack_frame.more; + + for ( int a = 0; accumulator == t && a < frame->payload.stack_frame.args; + a++ ) { + accumulator = truthy( fetch_arg( frame, a ) ); + } +# + return accumulator ? t : nil; +} + +/** + * @brief Boolean `or` of arbitrarily many arguments. + * + * @param frame The stack frame. + * @param frame_pointer A pointer to the stack frame. + * @param env The evaluation environment. + * @return struct pso_pointer a pointer to the result + */ +struct pso_pointer lisp_or( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + bool accumulator = false; + struct pso_pointer result = frame->payload.stack_frame.more; + + for ( int a = 0; + accumulator == false && a < frame->payload.stack_frame.args; a++ ) { + accumulator = truthy( fetch_arg( frame, a ) ); + } + + return accumulator ? t : nil; +} + +/** + * @brief Logical inverese: if the first argument is `nil`, return `t`, else `nil`. + * + * @param frame The stack frame. + * @param frame_pointer A pointer to the stack frame. + * @param env The evaluation environment. + * @return struct pso_pointer `t` if the first argument is `nil`, else `nil`. + */ +struct pso_pointer lisp_not( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + return c_nilp( frame->payload.stack_frame.arg[0] ) ? t : nil; } diff --git a/src/c/ops/repl.c b/src/c/ops/repl.c index a427a2b..4e8e5f1 100644 --- a/src/c/ops/repl.c +++ b/src/c/ops/repl.c @@ -72,10 +72,11 @@ void repl( struct pso_pointer frame_pointer ) { while ( readp( input_stream ) && !url_feof( stream_get_url_file( input_stream ) ) ) { - if ( show_prompt ) + if ( show_prompt ) { princ( make_frame( 2, frame_pointer, c_assoc( lisp_io_prompt, env ), output_stream ) ); + } /* the reason for initialising a new stack for each REPL input is to * be sure the old stack is fully torn down and reclaimed. Once I'm @@ -86,13 +87,21 @@ void repl( struct pso_pointer frame_pointer ) { consp( oblist ) ? oblist : make_cons( nil, oblist, nil ) ) ); - print( make_frame - ( 2, base_of_stack, - eval( make_frame - ( 1, base_of_stack, - read( make_frame - ( 1, base_of_stack, input_stream ) ) ) ), - output_stream ) ); + struct pso_pointer next = + inc_ref( make_frame( 1, base_of_stack, input_stream ) ); + struct pso_pointer read_value = inc_ref( read( next ) ); + dec_ref( next ); + + next = inc_ref( make_frame( 1, base_of_stack, read_value ) ); + struct pso_pointer eval_value = inc_ref( eval( next ) ); + dec_ref( next ); + dec_ref( read_value ); + + next = + inc_ref( make_frame + ( 2, base_of_stack, eval_value, output_stream ) ); + print( next ); + dec_ref( next ); dec_ref( base_of_stack ); } diff --git a/src/c/ops/reverse.c b/src/c/ops/reverse.c index 9bfe934..720d348 100644 --- a/src/c/ops/reverse.c +++ b/src/c/ops/reverse.c @@ -16,8 +16,10 @@ #include "memory/pointer.h" #include "memory/pso.h" #include "memory/pso2.h" +#include "memory/pso4.h" #include "memory/tags.h" +#include "ops/stack_ops.h" #include "payloads/cons.h" #include "payloads/exception.h" #include "payloads/psse_string.h" @@ -25,6 +27,63 @@ #include "ops/string_ops.h" #include "ops/truth.h" + +struct pso_pointer reverse( struct pso_pointer frame_pointer ) { + struct pso_pointer result = nil; + struct pso_pointer sequence = + fetch_arg( pointer_to_pso4( frame_pointer ), 0 ); + for ( struct pso_pointer cursor = sequence; !c_nilp( sequence ); + cursor = c_cdr( cursor ) ) { + struct pso2 *object = pointer_to_object( cursor ); + switch ( get_tag_value( cursor ) ) { + case CONSTV: + result = push_local( frame_pointer, + make_cons( frame_pointer, c_car( cursor ), + result ) ); + break; + case KEYTV: + result = push_local( frame_pointer, + make_string_like_thing( frame_pointer, + object->payload. + string.character, + result, + KEYTAG ) ); + break; + case STRINGTV: + result = push_local( frame_pointer, + make_string_like_thing( frame_pointer, + object->payload. + string.character, + result, + STRINGTAG ) ); + break; + case SYMBOLTV: + result = push_local( frame_pointer, + make_string_like_thing( frame_pointer, + object->payload. + string.character, + result, + SYMBOLTAG ) ); + break; + default: + result = push_local( frame_pointer, + make_exception( make_frame + ( 1, frame_pointer, + make_cons + ( frame_pointer, + c_string_to_lisp_string + ( frame_pointer, + L"Invalid object in sequence" ), + cursor ) ) ) ); + goto exit; + break; + } + } + exit: + + return result; +} + /** * @brief reverse a sequence. * @@ -37,49 +96,11 @@ */ struct pso_pointer c_reverse( struct pso_pointer frame_pointer, struct pso_pointer sequence ) { - // todo: issue #21: must have stack frame passed in. + struct pso_pointer result = nil; - for ( struct pso_pointer cursor = sequence; !c_nilp( sequence ); - cursor = c_cdr( cursor ) ) { - struct pso2 *object = pointer_to_object( cursor ); - switch ( get_tag_value( cursor ) ) { - case CONSTV: - result = make_cons( frame_pointer, c_car( cursor ), result ); - break; - case KEYTV: - // TODO: should you be able to reverse keywords and symbols? - result = - make_string_like_thing( frame_pointer, - object->payload.string.character, - result, KEYTAG ); - break; - case STRINGTV: - result = - make_string_like_thing( frame_pointer, - object->payload.string.character, - result, STRINGTAG ); - break; - case SYMBOLTV: - // TODO: should you be able to reverse keywords and symbols? - result = - make_string_like_thing( frame_pointer, - object->payload.string.character, - result, SYMBOLTAG ); - break; - default: - result = - make_exception( make_frame( 1, frame_pointer, - make_cons( frame_pointer, - c_string_to_lisp_string - ( frame_pointer, - L"Invalid object in sequence" ), - cursor ) ) ); - goto exit; - break; - } + if ( stackp( frame_pointer ) ) { + result = reverse( frame_pointer ); } - exit: - return result; } diff --git a/src/c/ops/stack_ops.c b/src/c/ops/stack_ops.c index 4d566cf..f1d14ea 100644 --- a/src/c/ops/stack_ops.c +++ b/src/c/ops/stack_ops.c @@ -8,9 +8,12 @@ */ #include "memory/node.h" +#include "memory/pointer.h" #include "memory/pso2.h" #include "memory/pso4.h" #include "memory/tags.h" + +#include "payloads/cons.h" #include "payloads/stack.h" /** @@ -54,3 +57,24 @@ struct pso_pointer fetch_env( struct pso_pointer frame_pointer ) { return stackp( frame_pointer ) ? pointer_to_pso4( frame_pointer )->payload.stack_frame.env : nil; } + +/** + * Push a binding (and therefore a reference) for this `local` onto the + * stack_frame indicated by this `frame_pointer`, thereby protecting the + * `local` from garbage collection until the frame itself is disposed of. + * + * This is a hack. For Lisp functions, where the stack frames are set up + * and torn down by eval/apply, it shouldn't be necessary. + */ +struct pso_pointer push_local( struct pso_pointer frame_pointer, + struct pso_pointer local ) { + if ( stackp( frame_pointer ) ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + + struct pso_pointer l = make_cons( frame_pointer, local, + frame->payload.stack_frame.locals ); + frame->payload.stack_frame.locals = l; + } + + return local; +} diff --git a/src/c/ops/stack_ops.h b/src/c/ops/stack_ops.h index fb1c4cc..059f61e 100644 --- a/src/c/ops/stack_ops.h +++ b/src/c/ops/stack_ops.h @@ -29,4 +29,7 @@ struct pso_pointer fetch_arg( struct pso4 *frame, unsigned int index ); struct pso_pointer fetch_env( struct pso_pointer frame_pointer ); +struct pso_pointer push_local( struct pso_pointer frame_pointer, + struct pso_pointer local ); + #endif diff --git a/src/c/ops/string_ops.c b/src/c/ops/string_ops.c index 74d0f47..8d5c345 100644 --- a/src/c/ops/string_ops.c +++ b/src/c/ops/string_ops.c @@ -181,8 +181,8 @@ char *lisp_string_to_c_string( struct pso_pointer s ) { int i = 0; for ( struct pso_pointer c = s; !c_nilp( c ); c = c_cdr( c ) ) { buffer[i++] = - ( wchar_t ) ( pointer_to_object( c )->payload.string. - character ); + ( wchar_t ) ( pointer_to_object( c )->payload. + string.character ); } mbstate_t ps; diff --git a/src/c/payloads/exception.c b/src/c/payloads/exception.c index 33a0e4b..729e1f9 100644 --- a/src/c/payloads/exception.c +++ b/src/c/payloads/exception.c @@ -56,15 +56,17 @@ struct pso_pointer make_exception( struct pso_pointer frame_pointer ) { struct pso_pointer result = allocate( frame_pointer, EXCEPTIONTAG, 3 ); - if ( !c_nilp( result ) && !exceptionp( result ) ) { + if ( exceptionp( result ) ) { struct pso3 *object = ( struct pso3 * ) pointer_to_object( result ); - object->payload.exception.message = inc_ref(message); + object->payload.exception.message = inc_ref( message ); object->payload.exception.stack = - stackp( frame_pointer ) ? inc_ref(frame_pointer) : nil; + stackp( frame_pointer ) ? inc_ref( frame_pointer ) : nil; object->payload.exception.meta = ( consp( meta ) - || hashtabp( meta ) ) ? inc_ref(meta) : nil; - object->payload.exception.cause = exceptionp( cause ) ? inc_ref(cause) : nil; + || hashtabp( meta ) ) ? + inc_ref( meta ) : nil; + object->payload.exception.cause = + exceptionp( cause ) ? inc_ref( cause ) : nil; } return result; diff --git a/src/c/payloads/integer.c b/src/c/payloads/integer.c index 9b85b5a..71ed2c1 100644 --- a/src/c/payloads/integer.c +++ b/src/c/payloads/integer.c @@ -22,8 +22,6 @@ /** * Allocate an integer cell representing this `value` and return a pso_pointer to it. * @param value an integer value; - * @param more `nil`, or a pointer to the more significant cell(s) of this number. - * *NOTE* that if `more` is not `nil`, `value` *must not* exceed `MAX_INTEGER`. */ struct pso_pointer make_integer( struct pso_pointer frame_pointer, int64_t value ) { @@ -34,8 +32,8 @@ struct pso_pointer make_integer( struct pso_pointer frame_pointer, struct pso2 *cell = pointer_to_object( result ); cell->payload.integer.value = value; - debug_print( L"make_integer: returning\n", DEBUG_ALLOC, 0 ); - debug_dump_object( result, DEBUG_ALLOC, 0 ); + debug_printf( DEBUG_ALLOC, 0, L"\nmake_integer returning %ld\n", + cell->payload.integer.value ); return result; } diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index ed65024..b0b2730 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -62,8 +62,8 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, } else { new_frame->payload.stack_frame.depth = 0; } - - new_frame->payload.stack_frame.previous = inc_ref( previous); + + new_frame->payload.stack_frame.previous = inc_ref( previous ); debug_printf( DEBUG_ALLOC, 1, L"depth is %d...\n", new_frame->payload.stack_frame.depth ); @@ -129,7 +129,7 @@ struct pso_pointer make_frame_with_env( int arg_count, arg_count, new_pointer.page, new_pointer.offset ); #endif - prev_frame->payload.stack_frame.previous = inc_ref(previous); + prev_frame->payload.stack_frame.previous = inc_ref( previous ); if ( stackp( previous ) ) { new_frame->payload.stack_frame.depth = @@ -194,8 +194,8 @@ struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer struct pso_pointer arg_length = length( make_frame( 1, previous, argvalues ) ); int arg_count = - integerp( arg_length ) ? pointer_to_object( arg_length )->payload. - integer.value : 0; + integerp( arg_length ) ? pointer_to_object( arg_length )-> + payload.integer.value : 0; #ifdef DEBUG debug_printf( DEBUG_ALLOC, 0, L"\nAllocating stack frame with %d arguments at page %d, " @@ -203,7 +203,7 @@ struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer arg_count, new_pointer.page, new_pointer.offset ); #endif - prev_frame->payload.stack_frame.previous = inc_ref( previous); + prev_frame->payload.stack_frame.previous = inc_ref( previous ); if ( stackp( previous ) ) { new_frame->payload.stack_frame.depth = @@ -253,8 +253,8 @@ struct pso_pointer make_frame_with_arglist( struct pso_pointer previous, struct pso_pointer argvalues ) { return make_frame_with_arglist_and_env( previous, argvalues, pointer_to_pso4 - ( previous )->payload. - stack_frame.env ); + ( previous )->payload.stack_frame. + env ); } @@ -279,12 +279,12 @@ struct pso_pointer destroy_stack_frame( struct pso_pointer fp, dec_ref( frame->payload.stack_frame.arg[i] ); } - frame->payload.stack_frame.previous = nil; - frame->payload.stack_frame.function = nil; - frame->payload.stack_frame.more = nil; - frame->payload.stack_frame.locals = nil; - frame->payload.stack_frame.env = nil; - + frame->payload.stack_frame.previous = nil; + frame->payload.stack_frame.function = nil; + frame->payload.stack_frame.more = nil; + frame->payload.stack_frame.locals = nil; + frame->payload.stack_frame.env = nil; + frame->payload.stack_frame.args = 0; frame->payload.stack_frame.depth = 0; } diff --git a/src/c/psse.c b/src/c/psse.c index 38f7d96..bf7c745 100644 --- a/src/c/psse.c +++ b/src/c/psse.c @@ -21,6 +21,7 @@ #include "psse.h" #include "io/print.h" + #include "memory/node.h" #include "memory/pso.h" #include "memory/tags.h" @@ -77,11 +78,11 @@ int main( int argc, char *argv[] ) { bool dump_at_end = false; bool show_prompt = false; char *infilename = NULL; - - if ( initialise_io( ) != 0 ) { - fputs( "Failed to initialise I/O subsystem\n", stderr ); - exit( 1 ); - } + + if ( initialise_io( ) != 0 ) { + fputs( "Failed to initialise I/O subsystem\n", stderr ); + exit( 1 ); + } while ( ( option = getopt( argc, argv, "dhi:ps:v:" ) ) != -1 ) { switch ( option ) { @@ -114,7 +115,7 @@ int main( int argc, char *argv[] ) { } setlocale( LC_ALL, "" ); - + oblist = initialise_node( 0 ); debug_print( L"Oblist: ", DEBUG_BOOTSTRAP, 0 ); debug_print_object( oblist, DEBUG_BOOTSTRAP, 0 ); @@ -134,18 +135,25 @@ int main( int argc, char *argv[] ) { stdout ); } - struct pso_pointer bootstrap_stack = inc_ref( - make_frame_with_env(1, nil, - consp - ( oblist ) ? oblist : make_cons(nil, oblist, nil), - show_prompt ? t : nil)); + struct pso_pointer bootstrap_stack = inc_ref( make_frame_with_env( 1, nil, + consp + ( oblist ) + ? oblist + : + make_cons + ( nil, + oblist, + nil ), + show_prompt + ? t : + nil ) ); repl( bootstrap_stack ); dec_ref( bootstrap_stack ); - dec_ref( oblist); + dec_ref( oblist ); #ifdef DEBUG - print_allocation_table(); + print_allocation_table( ); #endif diff --git a/src/sed/convert.sed b/src/sed/convert.sed index d7d681a..1ab02c8 100644 --- a/src/sed/convert.sed +++ b/src/sed/convert.sed @@ -1,17 +1,16 @@ # sed script to help converting snippets of code from 0.0.X to 0.1.X s?allocate_cell( *\([A-Z]*\) *)?allocate( \1, 2)?g -s?c_car(?car(?g -s?c_cdr(?cdr(?g s?cons_pointer?pso_pointer?g s?consspaceobject\.h?pso2\.h? -s?cons_space_object?pso2?g +s?cons_space_object?pso2*?g s?debug_print(\([^)]*\))?debug_print(\1, 0)?g s?frame->arg?frame->payload.stack_frame.arg?g s?make_cons?cons?g s?NIL?nil?g s?nilTAG?NILTAG?g -s?&pointer2cell?pointer_to_object?g +s?\&pointer2cell?pointer_to_object?g +s?pointer2cell?pointer_to_object?g s?stack_frame?pso4?g s?stack\.h?pso4\.h? s?tag.value?header.tag.bytes.value \& 0xfffff?g \ No newline at end of file