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

Merge branch 'feature/reengineering-17-21' of ssh://git.journeyman.cc:4022/simon/post-scarcity into feature/reengineering-17-21

Browse source
This commit is contained in:
Simon Brooke 2026-04-26 09:44:59 +01:00
commit dbeb99759a
22 changed files with 2154 additions and 372 deletions
Download patch file Download diff file Expand all files Collapse all files

83
docs/State-of-play.md
View file

@ -1,5 +1,88 @@
# State of Play # 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 <simon@journeyman.cc>
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 <simon@journeyman.cc>
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 ## 20260421
### To have `c_` functions or not to have `c_` functions? ### To have `c_` functions or not to have `c_` functions?

2
src/c/debug.c
View file

@ -19,7 +19,7 @@
#include "io/io.h" #include "io/io.h"
#include "io/print.h" #include "io/print.h"
#include "memory/dump.h" // #include "memory/dump.h"
int verbosity = 0; int verbosity = 0;

94
src/c/io/io.c
View file

@ -114,7 +114,8 @@ struct pso_pointer lisp_io_readbase;
/** /**
* @brief bound to the Lisp symbol representing C_IO_READTABLE in initialisation * @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 * 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_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_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_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 ); c_string_to_lisp_symbol( frame_pointer, C_IO_READTABLE );
debug_print( L"In initialise_default_streams; environment is: ", DEBUG_IO, 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 ), 10 ),
lisp_bind( make_frame lisp_bind( make_frame
( 3, frame_pointer, ( 3, frame_pointer,
lisp_io_readtable, lisp_io_read_table,
nil, env ) ) ) ) ) ); nil, env ) ) ) ) ) );
lisp_stdin = lisp_stdin =
@ -370,8 +371,8 @@ struct pso_pointer push_back_character( struct pso_pointer c,
struct pso_pointer result = nil; struct pso_pointer result = nil;
if ( characterp( c ) && readp( r ) ) { if ( characterp( c ) && readp( r ) ) {
if ( url_ungetwc( ( wint_t ) if ( url_ungetwc( ( wint_t )
( pointer_to_object( c )->payload. ( pointer_to_object( c )->payload.character.
character.character ), character ),
pointer_to_object( r )->payload.stream.stream ) >= pointer_to_object( r )->payload.stream.stream ) >=
0 ) { 0 ) {
result = t; result = t;
@ -398,8 +399,8 @@ struct pso_pointer lisp_close( struct pso_pointer frame_pointer,
struct pso_pointer result = nil; struct pso_pointer result = nil;
if ( readp( fetch_arg( frame, 0 ) ) || writep( fetch_arg( frame, 0 ) ) ) { if ( readp( fetch_arg( frame, 0 ) ) || writep( fetch_arg( frame, 0 ) ) ) {
if ( url_fclose if ( url_fclose
( pointer_to_object( fetch_arg( frame, 0 ) )->payload. ( pointer_to_object( fetch_arg( frame, 0 ) )->payload.stream.
stream.stream ) stream )
== 0 ) { == 0 ) {
result = t; 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 * 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. * 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 pso_pointer stream ) {
struct pso2 *object = pointer_to_object( stream ); struct pso2 *object = pointer_to_object( stream );
// TODO: reimplement // TODO: reimplement
/* make a copy of the string that we can destructively change */ /* make a copy of the string that we can destructively change */
char *s = calloc( strlen( string ), sizeof( char ) ); char *s = calloc( strlen( string ), sizeof( char ) );
strcpy( s, string ); strcpy( s, string );
if ( readp(stream) || if ( readp( stream ) || writep( stream ) ) {
writep(stream) ) { int offset = index_of( ':', s );
int offset = index_of( ':', s ); if ( offset != -1 ) {
if ( offset != -1 ) { s[offset] = ( char ) 0;
s[offset] = ( char ) 0; char *name = trim( s );
char *name = trim( s ); char *value = trim( &s[++offset] );
char *value = trim( &s[++offset] ); char32_t wname[strlen( name )];
char32_t wname[strlen( name )]; mbstowcs( wname, name, strlen( name ) + 1 );
mbstowcs( wname, name, strlen( name ) + 1 ); object->payload.stream.meta =
object->payload.stream.meta = add_meta_string( frame_pointer, object->payload.stream.meta,
add_meta_string( frame_pointer, object->payload.stream.meta, wname, value ); wname, value );
debug_printf( DEBUG_IO, 0, debug_printf( DEBUG_IO, 0,
L"write_meta_callback: added header '%s': value '%s'\n", name, value ); L"write_meta_callback: added header '%s': value '%s'\n",
} else if ( strncmp( "HTTP", s, 4 ) == 0 ) { name, value );
int offset = index_of( ' ', s ); } else if ( strncmp( "HTTP", s, 4 ) == 0 ) {
char *value = trim( &s[offset] ); int offset = index_of( ' ', s );
object->payload.stream.meta = char *value = trim( &s[offset] );
add_meta_integer( frame_pointer, add_meta_string object->payload.stream.meta =
(frame_pointer, object->payload.stream.meta, L"status", add_meta_integer( frame_pointer, add_meta_string
value ), L"status-code", strtol( value, ( frame_pointer, object->payload.stream.meta,
NULL, L"status", value ), L"status-code",
10 ) ); strtol( value, NULL, 10 ) );
debug_printf( DEBUG_IO, 0, debug_printf( DEBUG_IO, 0,
L"write_meta_callback: added header 'status': value '%s'\n", value ); L"write_meta_callback: added header 'status': value '%s'\n",
} else { value );
debug_printf( DEBUG_IO, 0, } else {
L"write_meta_callback: header passed with no colon: '%s'\n", s ); debug_printf( DEBUG_IO, 0,
} L"write_meta_callback: header passed with no colon: '%s'\n",
} else { s );
debug_print }
( L"Pointer passed to write_meta_callback did not point to a stream: ", } else {
DEBUG_IO, 0 ); debug_print
debug_dump_object( stream, DEBUG_IO, 0 ); ( L"Pointer passed to write_meta_callback did not point to a stream: ",
} DEBUG_IO, 0 );
free( s ); debug_dump_object( stream, DEBUG_IO, 0 );
}
free( s );
return 0; // strlen( string ); return 0; // strlen( string );
} }

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

@ -120,7 +120,8 @@ struct pso_pointer write_list_content( struct pso_pointer p, URL_FILE *output,
default: default:
url_fputws( L" . ", output ); url_fputws( L" . ", output );
result = result =
in_write( object->payload.cons.cdr, output, escape, 0 ); in_write( object->payload.cons.cdr, output, escape,
0 );
} }
} }
} else { } else {
@ -130,11 +131,11 @@ struct pso_pointer write_list_content( struct pso_pointer p, URL_FILE *output,
return result; return result;
} }
void in_write_nl (URL_FILE *output, int indent) { void in_write_nl( URL_FILE *output, int indent ) {
write_char( L'\n', output, false); write_char( L'\n', output, false );
for (int i = 0; i < indent; i++) { for ( int i = 0; i < indent; i++ ) {
write_char( L'\t', output, false); write_char( L'\t', output, false );
} }
} }
/** /**
@ -160,26 +161,36 @@ struct pso_pointer in_write( struct pso_pointer p, URL_FILE *output,
escape ); escape );
break; break;
case CONSTV: case CONSTV:
write_char( L'(', output, escape); write_char( L'(', output, escape );
result = write_list_content( p, 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"<exception: ", output );
in_write( exception->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"<broken exception :-( >", output );
}
}
break; break;
case EXCEPTIONTV :
struct pso3* exception = pointer_to_pso3(p);
url_fputws( L"<exception: ", output);
in_write( exception->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: case INTEGERTV:
url_fwprintf( output, L"%d", url_fwprintf( output, L"%d",
( int64_t ) ( object->payload.integer.value ) ); ( int64_t ) ( object->payload.integer.value ) );
@ -196,7 +207,8 @@ struct pso_pointer in_write( struct pso_pointer p, URL_FILE *output,
case WRITETV: case WRITETV:
url_fwprintf( output, L"<%s stream: ", url_fwprintf( output, L"<%s stream: ",
v == READTV ? "read" : "write" ); 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 ); write_char( L'>', output, escape );
break; break;
case TRUETV: 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_before = c_truep( fetch_arg( frame, 3 ) );
bool nl_after = c_truep( fetch_arg( frame, 4 ) ); bool nl_after = c_truep( fetch_arg( frame, 4 ) );
struct pso_pointer result = object; struct pso_pointer result = object;
struct pso2* stream_obj = pointer_to_object( stream ); struct pso2 *stream_obj = pointer_to_object( stream );
if ( writep( stream ) ) { if ( writep( stream ) ) {
URL_FILE *output = stream_obj->payload.stream.stream; URL_FILE *output = stream_obj->payload.stream.stream;
if ( nl_before ) if ( nl_before )
url_fputwc( L'\n', output ); 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 ); url_fputwc( nl_after ? L'\n' : L' ', output );
} else { } else {
@ -267,12 +279,13 @@ struct pso_pointer print( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer next = inc_ref( make_frame( 5, frame_pointer, struct pso_pointer next = inc_ref( make_frame( 5, frame_pointer,
fetch_arg( frame, 0 ), fetch_arg( frame, 1 ), t, fetch_arg( frame, 0 ),
t, nil )); fetch_arg( frame, 1 ), t,
t, nil ) );
struct pso_pointer result = write( next ); struct pso_pointer result = write( next );
dec_ref( next); dec_ref( next );
return result; return result;
} }
@ -284,12 +297,13 @@ struct pso_pointer princ( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer next = inc_ref( make_frame( 5, frame_pointer, struct pso_pointer next = inc_ref( make_frame( 5, frame_pointer,
fetch_arg( frame, 0 ), fetch_arg( frame, 1 ), fetch_arg( frame, 0 ),
nil, t, nil )); 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; return result;
} }

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

@ -32,6 +32,7 @@
#include "memory/pso2.h" #include "memory/pso2.h"
#include "memory/tags.h" #include "memory/tags.h"
#include "payloads/character.h"
#include "payloads/exception.h" #include "payloads/exception.h"
#include "payloads/function.h" #include "payloads/function.h"
#include "payloads/integer.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 result = nil;
struct pso_pointer stream_pointer = fetch_arg( frame, 0 ); struct pso_pointer stream_pointer = fetch_arg( frame, 0 );
if ( readp( stream_pointer ) ) { if ( readp( stream_pointer ) ) {
result = make_string( frame_pointer, wint_t chr = url_fgetwc( stream_get_url_file( stream_pointer ) );
url_fgetwc( stream_get_url_file result = make_character( frame_pointer, chr );
( stream_pointer ) ), nil );
#ifdef DEBUG
debug_printf( DEBUG_IO, 0, L"\nRead character %lc\n", chr );
#endif
} }
return result; return result;
@ -204,8 +208,7 @@ struct pso_pointer read( struct pso_pointer frame_pointer ) {
} }
if ( c_nilp( readtable ) ) { if ( c_nilp( readtable ) ) {
// TODO: check for the value of `*read-table*` in the environment and readtable = c_assoc( lisp_io_read_table, fetch_env( frame_pointer ) );
// use that.
} }
if ( c_nilp( character ) ) { if ( c_nilp( character ) ) {
@ -240,9 +243,9 @@ struct pso_pointer read( struct pso_pointer frame_pointer ) {
( frame_pointer, c ) ); ( frame_pointer, c ) );
inc_ref( next ); inc_ref( next );
if ( iswdigit( c ) ) { if ( iswdigit( c ) ) {
result = read_number( next ); result = push_local( frame_pointer, read_number( next ) );
} else if ( iswalpha( c ) ) { } else if ( iswalpha( c ) ) {
result = read_symbol( next ); result = push_local( frame_pointer, read_symbol( next ) );
} else { } else {
// result = // result =
// throw_exception( // throw_exception(
@ -260,10 +263,15 @@ struct pso_pointer read( struct pso_pointer frame_pointer ) {
// ), // ),
// frame_pointer ); // frame_pointer );
} }
dec_ref( next ); // dec_ref( next );
break; 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; return result;
} }

17
src/c/memory/memory.c
View file

@ -76,9 +76,14 @@ struct pso_pointer initialise_memory( uint32_t node ) {
/** /**
* @brief Pop an object off the freelist for the specified `size_class`. * @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 ) { 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; struct pso_pointer result = t;
if ( size_class <= MAX_SIZE_CLASS ) { 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 /* the object ought already to have the right size class in its tag
* because it was popped off the freelist for that size class. */ * because it was popped off the freelist for that size class. */
if ( object->header.tag.bytes.size_class != 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 /* the objext ought to have a reference count ot zero, because it's
* on the freelist, but again we should sanity check. */ * on the freelist, but again we should sanity check. */
if ( object->header.count != 0 ) { if ( object->header.count != 0 ) {
fwprintf( stderr, fwprintf( stderr,
L"WARNING: Count of %d in newly allocated object at %d, %d, should be 0\n", L"\nWARNING: Count of %u in newly allocated object at %u, %u, should be 0\n",
result.page, object->header.count, result.page, result.offset );
result.offset,
object->header.count );
object->header.count = 0; object->header.count = 0;
} }
} }

7
src/c/memory/page.c
View file

@ -286,8 +286,9 @@ struct pso_pointer initialise_page( union page *page_addr, uint16_t page_index,
result = nil; result = nil;
} }
debug_print( (c_nilp( result ) && (page_index != 0)) ? L"fail.\n" : L"success.\n", DEBUG_ALLOC, debug_print( ( c_nilp( result )
0 ); && ( page_index != 0 ) ) ? L"fail.\n" : L"success.\n",
DEBUG_ALLOC, 0 );
return result; return result;
} }
@ -311,7 +312,7 @@ struct pso_pointer allocate_page( uint8_t size_class ) {
if ( npages_allocated < NPAGES ) { if ( npages_allocated < NPAGES ) {
if ( size_class >= 2 && size_class <= MAX_SIZE_CLASS ) { 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 ) { if ( pg != NULL ) {
memset( pg, 0, sizeof( union page ) ); memset( pg, 0, sizeof( union page ) );

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

@ -4,9 +4,9 @@
* Paged space objects. * Paged space objects.
* *
* Broadly, it should be save to cast any paged space object to a pso2, since * 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 * 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 * 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 * 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 * 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. * 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_allocated = 0;
int allocation_table_freed = 1; 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() { void print_allocation_table( ) {
fputws( L"| Size class | Allocated | Deallocated | Remaining |\n", stderr); fputws( L"| Size class | Allocated | Deallocated | Remaining |\n",
fputws( L"| ============ | ============ | ============ | ============ |\n", stderr ); stderr );
fputws( L"| ============ | ============ | ============ | ============ |\n",
for ( int s = 2; s<= MAX_SIZE_CLASS; s++) { stderr );
long int a = allocation_table[s][allocation_table_allocated];
long int d = allocation_table[s][allocation_table_freed]; for ( int s = 2; s <= MAX_SIZE_CLASS; s++ ) {
long int r = a - d; long int a = allocation_table[s][allocation_table_allocated];
fwprintf( stderr, L"| %12d | %12ld | %12ld | %12ld |\n", s, a, d, r); long int d = allocation_table[s][allocation_table_freed];
} long int r = a - d;
fputws( L"| ============ | ============ | ============ | ============ |\n", stderr ); fwprintf( stderr, L"| %12d | %12ld | %12ld | %12ld |\n", s, a, d, r );
}
fputws( L"| ============ | ============ | ============ | ============ |\n",
stderr );
} }
#endif #endif
@ -77,64 +80,53 @@ struct pso_pointer cheaty_make_cons( struct pso_pointer car,
return result; return result;
} }
/** /**
* @brief Allocate an object of this `size_class` with this `tag`. * @brief Allocate an object of this `size_class` with this `tag`.
* *
* All objects that are allocated (after completion of init)) should be linked * All objects that are allocated (after completion of init)) should be linked
* onto the `locals` slot of a stack frame. This guarantees * onto the `locals` slot of a stack frame. This guarantees
* 1. that they do get `inc_ref`ed; and that, * 1. that they do get `inc_ref`ed; and that,
* 2. if nothing else hangs onto them they will be reclaimed when that stack * 2. if nothing else hangs onto them they will be reclaimed when that stack
* frame is reclaimed. * frame is reclaimed.
* for some objects (e.g. those cons cells on the locals list) this isn't * 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 * possible due to infinite recursion, but those special cases need to be
* audited carefully. * audited carefully.
* *
* @param frame_pointer pointer to an active stack frame (or * @param frame_pointer pointer to an active stack frame (or
* nil, but only during initialisation). * nil, but only during initialisation).
* @param tag The tag. Only the first three bytes will be used; * @param tag The tag. Only the first three bytes will be used;
* @param size_class The size class for the object to be allocated; * @param size_class The size class for the object to be allocated;
* @return struct pso_pointer a pointer to the newly allocated object * @return struct pso_pointer a pointer to the newly allocated object
*/ */
struct pso_pointer allocate( struct pso_pointer frame_pointer, char *tag, struct pso_pointer allocate( struct pso_pointer frame_pointer, char *tag,
uint8_t size_class ) { 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 #ifdef DEBUG
debug_printf( DEBUG_ALLOC, 0, 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 ); size_class, tag );
#endif #endif
struct pso_pointer result = pop_freelist( size_class ); struct pso2 *obj = pointer_to_object( result );
struct pso4 *frame = pointer_to_pso4( frame_pointer ); strncpy( ( char * ) ( obj->header.tag.bytes.mnemonic ), tag, TAGLENGTH );
if ( memory_initialised && c_nilp(frame_pointer)) { debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ", result.page,
fputws( L"WARNING: No stack frame passed to `allocate`.\n", result.offset );
stderr ); 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
if ( !c_nilp( result ) ) { // frame. Infinite recursion. So we have to cheat.
struct pso2 *obj = pointer_to_object(result); struct pso_pointer locals =
strncpy((char*) (obj->header.tag.bytes. cheaty_make_cons( result, frame->payload.stack_frame.locals );
mnemonic ), tag, TAGLENGTH ); frame->payload.stack_frame.locals = locals;
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
} }
#ifdef DEBUG
allocation_table[size_class][allocation_table_allocated]++;
#endif
#ifdef DEBUG #ifdef DEBUG
debug_print( exceptionp( result ) ? L"fail\n" : L"success\n", DEBUG_ALLOC, 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`. * Returns the `pointer`.
*/ */
struct pso_pointer inc_ref( struct pso_pointer 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 ) { if ( object->header.count < MAXREFERENCE ) {
object->header.count++; object->header.count++;
#ifdef DEBUG #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, debug_printf( DEBUG_ALLOC, 0,
L"; pointer to vector object of type %3.3s.\n", L"\nIncremented object of type %3.3s, size class %d, "
( ( char * ) L"at page %u, offset %u to count %u", ( ( char * )
&( object->payload.vectorp.tag.bytes[0] ) ) ); &
} else { ( object->header.tag.
debug_println( DEBUG_ALLOC ); 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 #endif
}
} }
return pointer; 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`. * Returns the `pointer`, or, if the object has been freed, a pointer to `nil`.
*/ */
struct pso_pointer dec_ref( struct pso_pointer pointer ) { struct pso_pointer dec_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
if (freep(pointer)) { logs. */
fputws( L"WARNING: SHOULDN'T: Decrementing free object?\n", stderr); 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 if ( object->header.count > 0 && object->header.count != MAXREFERENCE ) {
&& object->header.count != MAXREFERENCE ) { object->header.count--;
object->header.count--;
#ifdef DEBUG #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, debug_printf( DEBUG_ALLOC, 0,
L"; pointer to vector object of type %3.3s.\n", L"\nDecremented object of type %3.3s, size class %d, "
( ( char * ) L"at page %d, offset %d to count %d",
&( object->payload.vectorp.tag.bytes ) ) ); ( ( char * ) ( object->header.tag.bytes.mnemonic ) ),
} else { ( int ) object->header.tag.bytes.size_class,
debug_println( DEBUG_ALLOC ); 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 #endif
}
if ( object->header.count == 0 ) {
free_object( pointer );
pointer = nil;
}
} }
if ( object->header.count == 0 ) {
free_object( pointer );
pointer = nil;
}
return pointer; return pointer;
} }
/** /**
* @brief Prevent an object ever being dereferenced. * @brief Prevent an object ever being dereferenced.
* *
* @param pointer pointer to an object to lock. * @param pointer pointer to an object to lock.
* *
* @return the `pointer` * @return the `pointer`
@ -257,24 +269,27 @@ struct pso_pointer free_object( struct pso_pointer pointer ) {
result = destroy( 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++ ) { for ( int i = 0; i < array_size; i++ ) {
object->payload.words[i] = 0; object->payload.words[i] = 0;
} }
#ifdef DEBUG #ifdef DEBUG
debug_printf( DEBUG_ALLOC, 0, debug_printf( DEBUG_ALLOC, 0,
L"Freeing object of type %3.3s, size class %d, at page %d, offset %d.\n", L"Freeing object of type %3.3s, size class %d, at page %d, "
( ( char * ) ( object->header.tag.bytes.mnemonic ) ), L"offset %d.\n",
(int)object->header.tag.bytes.size_class, ( ( char * ) ( object->header.tag.bytes.mnemonic ) ),
pointer.page, pointer.offset, object->header.count ( int ) object->header.tag.bytes.size_class, pointer.page,
); pointer.offset, object->header.count );
allocation_table[size_class][allocation_table_freed]++; allocation_table[size_class][allocation_table_freed]++;
#endif #endif
strncpy((char*) (object->header.tag.bytes. strncpy( ( char * ) ( object->header.tag.bytes.mnemonic ), FREETAG,
mnemonic ), FREETAG, TAGLENGTH ); TAGLENGTH );
object->header.count = ( uint8_t ) 0;
object->header.access = nil;
push_freelist( pointer ); push_freelist( pointer );
return result; return result;

2
src/c/memory/pso.h
View file

@ -28,6 +28,6 @@ struct pso_pointer lock_object( struct pso_pointer pointer );
struct pso_pointer free_object( struct pso_pointer p ); struct pso_pointer free_object( struct pso_pointer p );
#ifdef DEBUG #ifdef DEBUG
void print_allocation_table(); void print_allocation_table( );
#endif #endif
#endif #endif

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

@ -11,6 +11,7 @@
#include <stdbool.h> #include <stdbool.h>
#include "debug.h"
#include "memory/node.h" #include "memory/node.h"
#include "memory/pointer.h" #include "memory/pointer.h"
#include "memory/pso2.h" #include "memory/pso2.h"
@ -40,15 +41,31 @@ struct pso_pointer search( struct pso_pointer key,
struct pso_pointer result = nil; struct pso_pointer result = nil;
bool found = false; 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 ) ) { if ( consp( store ) ) {
for ( struct pso_pointer cursor = store; for ( struct pso_pointer cursor = store;
consp( cursor ) && found == false; cursor = c_cdr( cursor ) ) { consp( cursor ) && found == false; cursor = c_cdr( cursor ) ) {
struct pso_pointer pair = c_car( 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 ) ) { if ( consp( pair ) && c_equal( c_car( pair ), key ) ) {
found = true; found = true;
result = return_key ? c_car( pair ) : c_cdr( pair ); 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 key = fetch_arg( frame, 0 );
struct pso_pointer store = or( make_frame( 2, frame_pointer, struct pso_pointer store = or( make_frame( 2, frame_pointer,
fetch_arg( frame, 1 ), fetch_arg( frame, 1 ),
frame->payload.stack_frame. frame->payload.
env ) ); stack_frame.env ) );
return c_assoc( key, store ); return c_assoc( key, store );
} }
@ -130,8 +147,8 @@ struct pso_pointer interned(
struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer key = fetch_arg( frame, 0 );
struct pso_pointer store = or( make_frame( 2, frame_pointer, struct pso_pointer store = or( make_frame( 2, frame_pointer,
fetch_arg( frame, 1 ), fetch_arg( frame, 1 ),
frame->payload.stack_frame. frame->payload.
env ) ); stack_frame.env ) );
return c_interned( key, store ); return c_interned( key, store );
} }
@ -152,8 +169,8 @@ struct pso_pointer internedp(
struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer key = fetch_arg( frame, 0 );
struct pso_pointer store = or( make_frame( 2, frame_pointer, struct pso_pointer store = or( make_frame( 2, frame_pointer,
fetch_arg( frame, 1 ), fetch_arg( frame, 1 ),
frame->payload.stack_frame. frame->payload.
env ) ); stack_frame.env ) );
return c_internedp( key, store ) ? t : nil; return c_internedp( key, store ) ? t : nil;
} }

3
src/c/ops/eq.c
View file

@ -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 c_equal( struct pso_pointer a, struct pso_pointer b ) {
bool result = true; bool result = false;
if ( c_eq( a, b ) ) { if ( c_eq( a, b ) ) {
result = true; result = true;
@ -73,6 +73,7 @@ bool c_equal( struct pso_pointer a, struct pso_pointer b ) {
b = c_cdr( b ); b = c_cdr( b );
} else { } else {
result = false; result = false;
break;
} }
} }
result = result && c_nilp( a ) && c_nilp( b ); result = result && c_nilp( a ) && c_nilp( b );

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

File diff suppressed because it is too large Load diff

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

@ -72,10 +72,11 @@ void repl( struct pso_pointer frame_pointer ) {
while ( readp( input_stream ) && while ( readp( input_stream ) &&
!url_feof( stream_get_url_file( input_stream ) ) ) { !url_feof( stream_get_url_file( input_stream ) ) ) {
if ( show_prompt ) if ( show_prompt ) {
princ( make_frame( 2, frame_pointer, princ( make_frame( 2, frame_pointer,
c_assoc( lisp_io_prompt, env ), c_assoc( lisp_io_prompt, env ),
output_stream ) ); output_stream ) );
}
/* the reason for initialising a new stack for each REPL input is to /* 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 * 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 : consp( oblist ) ? oblist :
make_cons( nil, oblist, nil ) ) ); make_cons( nil, oblist, nil ) ) );
print( make_frame struct pso_pointer next =
( 2, base_of_stack, inc_ref( make_frame( 1, base_of_stack, input_stream ) );
eval( make_frame struct pso_pointer read_value = inc_ref( read( next ) );
( 1, base_of_stack, dec_ref( next );
read( make_frame
( 1, base_of_stack, input_stream ) ) ) ), next = inc_ref( make_frame( 1, base_of_stack, read_value ) );
output_stream ) ); 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 ); dec_ref( base_of_stack );
} }

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

@ -16,8 +16,10 @@
#include "memory/pointer.h" #include "memory/pointer.h"
#include "memory/pso.h" #include "memory/pso.h"
#include "memory/pso2.h" #include "memory/pso2.h"
#include "memory/pso4.h"
#include "memory/tags.h" #include "memory/tags.h"
#include "ops/stack_ops.h"
#include "payloads/cons.h" #include "payloads/cons.h"
#include "payloads/exception.h" #include "payloads/exception.h"
#include "payloads/psse_string.h" #include "payloads/psse_string.h"
@ -25,6 +27,63 @@
#include "ops/string_ops.h" #include "ops/string_ops.h"
#include "ops/truth.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. * @brief reverse a sequence.
* *
@ -37,49 +96,11 @@
*/ */
struct pso_pointer c_reverse( struct pso_pointer frame_pointer, struct pso_pointer c_reverse( struct pso_pointer frame_pointer,
struct pso_pointer sequence ) { struct pso_pointer sequence ) {
// todo: issue #21: must have stack frame passed in.
struct pso_pointer result = nil; struct pso_pointer result = nil;
for ( struct pso_pointer cursor = sequence; !c_nilp( sequence ); if ( stackp( frame_pointer ) ) {
cursor = c_cdr( cursor ) ) { result = reverse( frame_pointer );
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;
}
} }
exit:
return result; return result;
} }

24
src/c/ops/stack_ops.c
View file

@ -8,9 +8,12 @@
*/ */
#include "memory/node.h" #include "memory/node.h"
#include "memory/pointer.h"
#include "memory/pso2.h" #include "memory/pso2.h"
#include "memory/pso4.h" #include "memory/pso4.h"
#include "memory/tags.h" #include "memory/tags.h"
#include "payloads/cons.h"
#include "payloads/stack.h" #include "payloads/stack.h"
/** /**
@ -54,3 +57,24 @@ struct pso_pointer fetch_env( struct pso_pointer frame_pointer ) {
return stackp( frame_pointer ) ? return stackp( frame_pointer ) ?
pointer_to_pso4( frame_pointer )->payload.stack_frame.env : nil; 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;
}

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

@ -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 fetch_env( struct pso_pointer frame_pointer );
struct pso_pointer push_local( struct pso_pointer frame_pointer,
struct pso_pointer local );
#endif #endif

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

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

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

@ -56,15 +56,17 @@ struct pso_pointer make_exception( struct pso_pointer frame_pointer ) {
struct pso_pointer result = allocate( frame_pointer, EXCEPTIONTAG, 3 ); 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 ); 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 = 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 ) object->payload.exception.meta = ( consp( meta )
|| hashtabp( meta ) ) ? inc_ref(meta) : nil; || hashtabp( meta ) ) ?
object->payload.exception.cause = exceptionp( cause ) ? inc_ref(cause) : nil; inc_ref( meta ) : nil;
object->payload.exception.cause =
exceptionp( cause ) ? inc_ref( cause ) : nil;
} }
return result; return result;

6
src/c/payloads/integer.c
View file

@ -22,8 +22,6 @@
/** /**
* Allocate an integer cell representing this `value` and return a pso_pointer to it. * Allocate an integer cell representing this `value` and return a pso_pointer to it.
* @param value an integer value; * @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, struct pso_pointer make_integer( struct pso_pointer frame_pointer,
int64_t value ) { int64_t value ) {
@ -34,8 +32,8 @@ struct pso_pointer make_integer( struct pso_pointer frame_pointer,
struct pso2 *cell = pointer_to_object( result ); struct pso2 *cell = pointer_to_object( result );
cell->payload.integer.value = value; cell->payload.integer.value = value;
debug_print( L"make_integer: returning\n", DEBUG_ALLOC, 0 ); debug_printf( DEBUG_ALLOC, 0, L"\nmake_integer returning %ld\n",
debug_dump_object( result, DEBUG_ALLOC, 0 ); cell->payload.integer.value );
return result; return result;
} }

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

@ -62,8 +62,8 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous,
} else { } else {
new_frame->payload.stack_frame.depth = 0; 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", debug_printf( DEBUG_ALLOC, 1, L"depth is %d...\n",
new_frame->payload.stack_frame.depth ); 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 ); arg_count, new_pointer.page, new_pointer.offset );
#endif #endif
prev_frame->payload.stack_frame.previous = inc_ref(previous); prev_frame->payload.stack_frame.previous = inc_ref( previous );
if ( stackp( previous ) ) { if ( stackp( previous ) ) {
new_frame->payload.stack_frame.depth = 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 = struct pso_pointer arg_length =
length( make_frame( 1, previous, argvalues ) ); length( make_frame( 1, previous, argvalues ) );
int arg_count = int arg_count =
integerp( arg_length ) ? pointer_to_object( arg_length )->payload. integerp( arg_length ) ? pointer_to_object( arg_length )->
integer.value : 0; payload.integer.value : 0;
#ifdef DEBUG #ifdef DEBUG
debug_printf( DEBUG_ALLOC, 0, debug_printf( DEBUG_ALLOC, 0,
L"\nAllocating stack frame with %d arguments at page %d, " L"\nAllocating stack frame with %d arguments at page %d, "
@ -203,7 +203,7 @@ struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer
arg_count, new_pointer.page, new_pointer.offset ); arg_count, new_pointer.page, new_pointer.offset );
#endif #endif
prev_frame->payload.stack_frame.previous = inc_ref( previous); prev_frame->payload.stack_frame.previous = inc_ref( previous );
if ( stackp( previous ) ) { if ( stackp( previous ) ) {
new_frame->payload.stack_frame.depth = 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 ) { struct pso_pointer argvalues ) {
return make_frame_with_arglist_and_env( previous, argvalues, return make_frame_with_arglist_and_env( previous, argvalues,
pointer_to_pso4 pointer_to_pso4
( previous )->payload. ( previous )->payload.stack_frame.
stack_frame.env ); env );
} }
@ -279,12 +279,12 @@ struct pso_pointer destroy_stack_frame( struct pso_pointer fp,
dec_ref( frame->payload.stack_frame.arg[i] ); dec_ref( frame->payload.stack_frame.arg[i] );
} }
frame->payload.stack_frame.previous = nil; frame->payload.stack_frame.previous = nil;
frame->payload.stack_frame.function = nil; frame->payload.stack_frame.function = nil;
frame->payload.stack_frame.more = nil; frame->payload.stack_frame.more = nil;
frame->payload.stack_frame.locals = nil; frame->payload.stack_frame.locals = nil;
frame->payload.stack_frame.env = nil; frame->payload.stack_frame.env = nil;
frame->payload.stack_frame.args = 0; frame->payload.stack_frame.args = 0;
frame->payload.stack_frame.depth = 0; frame->payload.stack_frame.depth = 0;
} }

34
src/c/psse.c
View file

@ -21,6 +21,7 @@
#include "psse.h" #include "psse.h"
#include "io/print.h" #include "io/print.h"
#include "memory/node.h" #include "memory/node.h"
#include "memory/pso.h" #include "memory/pso.h"
#include "memory/tags.h" #include "memory/tags.h"
@ -77,11 +78,11 @@ int main( int argc, char *argv[] ) {
bool dump_at_end = false; bool dump_at_end = false;
bool show_prompt = false; bool show_prompt = false;
char *infilename = NULL; char *infilename = NULL;
if ( initialise_io( ) != 0 ) { if ( initialise_io( ) != 0 ) {
fputs( "Failed to initialise I/O subsystem\n", stderr ); fputs( "Failed to initialise I/O subsystem\n", stderr );
exit( 1 ); exit( 1 );
} }
while ( ( option = getopt( argc, argv, "dhi:ps:v:" ) ) != -1 ) { while ( ( option = getopt( argc, argv, "dhi:ps:v:" ) ) != -1 ) {
switch ( option ) { switch ( option ) {
@ -114,7 +115,7 @@ int main( int argc, char *argv[] ) {
} }
setlocale( LC_ALL, "" ); setlocale( LC_ALL, "" );
oblist = initialise_node( 0 ); oblist = initialise_node( 0 );
debug_print( L"Oblist: ", DEBUG_BOOTSTRAP, 0 ); debug_print( L"Oblist: ", DEBUG_BOOTSTRAP, 0 );
debug_print_object( oblist, DEBUG_BOOTSTRAP, 0 ); debug_print_object( oblist, DEBUG_BOOTSTRAP, 0 );
@ -134,18 +135,25 @@ int main( int argc, char *argv[] ) {
stdout ); stdout );
} }
struct pso_pointer bootstrap_stack = inc_ref( struct pso_pointer bootstrap_stack = inc_ref( make_frame_with_env( 1, nil,
make_frame_with_env(1, nil, consp
consp ( oblist )
( oblist ) ? oblist : make_cons(nil, oblist, nil), ? oblist
show_prompt ? t : nil)); :
make_cons
( nil,
oblist,
nil ),
show_prompt
? t :
nil ) );
repl( bootstrap_stack ); repl( bootstrap_stack );
dec_ref( bootstrap_stack ); dec_ref( bootstrap_stack );
dec_ref( oblist); dec_ref( oblist );
#ifdef DEBUG #ifdef DEBUG
print_allocation_table(); print_allocation_table( );
#endif #endif

7
src/sed/convert.sed
View file

@ -1,17 +1,16 @@
# sed script to help converting snippets of code from 0.0.X to 0.1.X # 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?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?cons_pointer?pso_pointer?g
s?consspaceobject\.h?pso2\.h? 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?debug_print(\([^)]*\))?debug_print(\1, 0)?g
s?frame->arg?frame->payload.stack_frame.arg?g s?frame->arg?frame->payload.stack_frame.arg?g
s?make_cons?cons?g s?make_cons?cons?g
s?NIL?nil?g s?NIL?nil?g
s?nilTAG?NILTAG?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_frame?pso4?g
s?stack\.h?pso4\.h? s?stack\.h?pso4\.h?
s?tag.value?header.tag.bytes.value \& 0xfffff?g s?tag.value?header.tag.bytes.value \& 0xfffff?g