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

Print is less badly broken. Read is less badly broken. GC is too aggressive.

Browse source
This commit is contained in:
Simon Brooke 2026-04-24 21:20:23 +01:00
parent 22b0160a26
commit 63906fe817
19 changed files with 489 additions and 303 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -1,5 +1,68 @@
# 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.
## 20260421
### 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/print.h"
#include "memory/dump.h"
// #include "memory/dump.h"
int verbosity = 0;

32
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
*/
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 =
@ -451,15 +452,15 @@ 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) ) {
if ( readp( stream ) || writep( stream ) ) {
int offset = index_of( ':', s );
if ( offset != -1 ) {
s[offset] = ( char ) 0;
@ -468,23 +469,26 @@ static size_t write_meta_callback( struct pso_pointer frame_pointer, char *strin
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 );
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 );
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 ) );
( 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 );
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 );
L"write_meta_callback: header passed with no colon: '%s'\n",
s );
}
} else {
debug_print

32
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:
url_fputws( L" . ", output );
result =
in_write( object->payload.cons.cdr, output, escape, 0 );
in_write( object->payload.cons.cdr, output, escape,
0 );
}
}
} else {
@ -164,21 +165,31 @@ struct pso_pointer in_write( struct pso_pointer p, URL_FILE *output,
result = write_list_content( p, output, escape );
write_char( L')', output, escape );
break;
case EXCEPTIONTV :
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);
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);
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);
in_write( exception->payload.exception.cause,
output, escape, indent );
}
write_char( L'>', output, escape );
} else {
url_fputws( L"<broken exception :-( >", output );
}
}
break;
case INTEGERTV:
url_fwprintf( output, L"%d",
@ -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:
@ -242,7 +254,7 @@ struct pso_pointer write( struct pso_pointer frame_pointer ) {
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,7 +279,8 @@ 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,
fetch_arg( frame, 0 ),
fetch_arg( frame, 1 ), t,
t, nil ) );
struct pso_pointer result = write( next );
@ -284,7 +297,8 @@ 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 ),
fetch_arg( frame, 0 ),
fetch_arg( frame, 1 ),
nil, t, nil ) );
struct pso_pointer result = write( next );

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

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

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`.
*
* 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;
}
}

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

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

@ -44,8 +44,10 @@ int allocation_table_freed = 1;
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 );
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];
@ -53,7 +55,8 @@ void print_allocation_table() {
long int r = a - d;
fwprintf( stderr, L"| %12d | %12ld | %12ld | %12ld |\n", s, a, d, r );
}
fputws( L"| ============ | ============ | ============ | ============ |\n", stderr );
fputws( L"| ============ | ============ | ============ | ============ |\n",
stderr );
}
#endif
@ -97,44 +100,33 @@ struct pso_pointer cheaty_make_cons( struct pso_pointer car,
*/
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 );
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 );
strncpy( ( char * ) ( obj->header.tag.bytes.mnemonic ), tag, TAGLENGTH );
debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ",
result.page, result.offset );
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 );
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
debug_print( exceptionp( result ) ? L"fail\n" : L"success\n", DEBUG_ALLOC,
@ -164,14 +156,28 @@ int payload_size( struct pso2 *object ) {
* Returns the `pointer`.
*/
struct pso_pointer inc_ref( struct pso_pointer 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++;
#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] )),
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 ) ) {
@ -184,6 +190,7 @@ struct pso_pointer inc_ref( struct pso_pointer pointer ) {
}
#endif
}
}
return pointer;
}
@ -197,18 +204,23 @@ 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 ) {
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 (freep(pointer)) {
fputws( L"WARNING: SHOULDN'T: Decrementing free object?\n", stderr);
}
if ( !c_nilp( pointer ) && object->header.count > 0
&& object->header.count != MAXREFERENCE ) {
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",
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 );
@ -226,6 +238,7 @@ struct pso_pointer dec_ref( struct pso_pointer pointer ) {
free_object( pointer );
pointer = nil;
}
}
return pointer;
}
@ -257,24 +270,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",
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
);
( 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 );
strncpy( ( char * ) ( object->header.tag.bytes.mnemonic ), FREETAG,
TAGLENGTH );
object->header.count = ( uint8_t ) 0;
object->header.access = nil;
push_freelist( pointer );
return result;

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

@ -11,6 +11,7 @@
#include <stdbool.h>
#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
}
}

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

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

@ -10,9 +10,11 @@
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#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"
@ -48,18 +50,20 @@ struct pso_pointer eval( struct pso_pointer frame_pointer ) {
struct pso_pointer arg = fetch_arg( frame, 0 );
struct pso_pointer result = nil;
if ( !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:
arg = c_assoc( arg, fetch_env( frame_pointer ) );
result = c_assoc( arg, fetch_env( frame_pointer ) );
break;
// case LAMBDATV:
// result = eval_lambda( frame, frame_pointer, env);
@ -71,8 +75,15 @@ struct pso_pointer eval( struct pso_pointer frame_pointer ) {
// result = eval_special( frame, frame_pointer, env);
// break;
default:
arg =
make_exception( make_frame( 1, frame_pointer,
#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 );
#endif
result = make_exception( make_frame( 1, frame_pointer,
make_cons( frame_pointer,
c_string_to_lisp_string
( frame_pointer,
@ -86,19 +97,20 @@ struct pso_pointer eval( struct pso_pointer frame_pointer ) {
L"tag" ),
get_tag_string
( frame_pointer,
arg ) ), nil ),
nil ) );
arg ) ),
nil ), nil ) );
}
}
if ( exceptionp( arg ) ) {
if ( exceptionp( result ) ) {
struct pso3 *x =
( struct pso3 * ) pointer_to_object_with_tag_value( arg,
( struct pso3 * ) pointer_to_object_with_tag_value( result,
EXCEPTIONTV );
if ( c_nilp( x->payload.exception.stack ) ) {
x->payload.exception.stack = frame_pointer;
}
}
return arg;
return result;
}

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

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

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

@ -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,25 @@ 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;
}

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

8
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 );
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.stack =
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;

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.
* @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;
}

16
src/c/psse.c
View file

@ -21,6 +21,7 @@
#include "psse.h"
#include "io/print.h"
#include "memory/node.h"
#include "memory/pso.h"
#include "memory/tags.h"
@ -134,11 +135,18 @@ int main( int argc, char *argv[] ) {
stdout );
}
struct pso_pointer bootstrap_stack = inc_ref(
make_frame_with_env(1, 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));
( oblist )
? oblist
:
make_cons
( nil,
oblist,
nil ),
show_prompt
? t :
nil ) );
repl( bootstrap_stack );