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

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;

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

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:
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"<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;
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:
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;
}

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

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

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

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 );
#ifdef DEBUG
void print_allocation_table();
void print_allocation_table( );
#endif
#endif

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

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

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

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

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

24
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,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;
}

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

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

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

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

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

34
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"
@ -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