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

Right, I'm committing this session because I'm too cold and tired to go on.

Browse source 
It does not at present build (and it's going to take a good bit more work
before it does).
This commit is contained in:
Simon Brooke 2026-04-20 18:29:28 +01:00
parent f05d1af9d6
commit 6148d3699f
32 changed files with 364 additions and 309 deletions
Download patch file Download diff file Expand all files Collapse all files

4
src/c/debug.h
View file

@ -104,7 +104,7 @@
*/
extern int verbosity;
void debug_print( char32_t *message, int level, int indent );
void debug_print( char32_t * message, int level, int indent );
void debug_print_object( struct pso_pointer object, int level, int indent );
@ -114,6 +114,6 @@ void debug_print_128bit( __int128_t n, int level );
void debug_println( int level );
void debug_printf( int level, int indent, char32_t *format, ... );
void debug_printf( int level, int indent, char32_t * format, ... );
#endif

46
src/c/io/io.c
View file

@ -150,9 +150,9 @@ int initialise_io( ) {
}
struct pso_pointer initialise_default_streams( struct pso_pointer env ) {
// todo: issue #21: should this have stack frame passed in?
// It's called in initialisation before everything else is set
// up, so **possibly** not?
// todo: issue #21: should this have stack frame passed in?
// It's called in initialisation before everything else is set
// up, so **possibly** not?
lisp_io_in = c_string_to_lisp_symbol( C_IO_IN );
lisp_io_out = c_string_to_lisp_symbol( C_IO_OUT );
lisp_io_log = c_string_to_lisp_symbol( C_IO_LOG );
@ -168,11 +168,11 @@ struct pso_pointer initialise_default_streams( struct pso_pointer env ) {
lisp_stdin = lock_object( make_read_stream( file_to_url_file( stdin ),
make_cons( make_cons
( c_string_to_lisp_keyword
( L"url" ),
c_string_to_lisp_string
( L"::system:standard-input" ) ),
nil ) ) );
( c_string_to_lisp_keyword
( L"url" ),
c_string_to_lisp_string
( L"::system:standard-input" ) ),
nil ) ) );
env = c_bind( lisp_io_in, lisp_stdin, env );
@ -183,10 +183,10 @@ struct pso_pointer initialise_default_streams( struct pso_pointer env ) {
lock_object( make_write_stream
( file_to_url_file( stdout ),
make_cons( make_cons
( c_string_to_lisp_keyword( L"url" ),
c_string_to_lisp_string
( L"::system:standard-output" ) ),
nil ) ) );
( c_string_to_lisp_keyword( L"url" ),
c_string_to_lisp_string
( L"::system:standard-output" ) ),
nil ) ) );
env = c_bind( lisp_io_out, lisp_stdout, env );
}
@ -196,10 +196,10 @@ struct pso_pointer initialise_default_streams( struct pso_pointer env ) {
lock_object( make_write_stream
( file_to_url_file( stderr ),
make_cons( make_cons
( c_string_to_lisp_keyword( L"url" ),
c_string_to_lisp_string
( L"::system:standard-output" ) ),
nil ) ) );
( c_string_to_lisp_keyword( L"url" ),
c_string_to_lisp_string
( L"::system:standard-output" ) ),
nil ) ) );
env = c_bind( lisp_io_log, lisp_stderr, env );
}
@ -420,29 +420,29 @@ struct pso_pointer lisp_close( struct pso_pointer frame_pointer,
struct pso_pointer add_meta_integer( struct pso_pointer meta, char32_t *key,
long int value ) {
// todo: issue #21: must have stack frame passed in.
// todo: issue #21: must have stack frame passed in.
return
make_cons( make_cons
( c_string_to_lisp_keyword( key ), make_integer( value ) ),
meta );
( c_string_to_lisp_keyword( key ), make_integer( value ) ),
meta );
}
struct pso_pointer add_meta_string( struct pso_pointer meta, char32_t *key,
char *value ) {
// todo: issue #21: must have stack frame passed in.
// todo: issue #21: must have stack frame passed in.
value = trim( value );
char32_t buffer[strlen( value ) + 1];
mbstowcs( buffer, value, strlen( value ) + 1 );
return
make_cons( make_cons
( c_string_to_lisp_keyword( key ),
c_string_to_lisp_string( buffer ) ), meta );
( c_string_to_lisp_keyword( key ),
c_string_to_lisp_string( buffer ) ), meta );
}
struct pso_pointer add_meta_time( struct pso_pointer meta, char32_t *key,
time_t *value ) {
// todo: issue #21: must have stack frame passed in.
// todo: issue #21: must have stack frame passed in.
char datestring[256];
strftime( datestring, sizeof( datestring ), nl_langinfo( D_T_FMT ),

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

@ -21,7 +21,7 @@ extern CURLSH *io_share;
int initialise_io( );
struct pso_pointer initialise_default_streams( struct pso_pointer env );
#define C_IO_IN L"*in*"
#define C_IO_IN L"*in*"
#define C_IO_OUT L"*out*"
#define C_IO_LOG L"*log*"

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

@ -44,9 +44,9 @@
#include "ops/truth.h"
struct pso_pointer in_write(struct pso_pointer p, URL_FILE *output,
bool escape);
struct pso_pointer in_write( struct pso_pointer p, URL_FILE * output,
bool escape );
/**
* @brief write this character `wc` to this `output` stream, escaping it if
* 1. `escape` is true; and
@ -54,75 +54,77 @@ struct pso_pointer in_write(struct pso_pointer p, URL_FILE *output,
*
* TODO: this does not yet even nearly cope with all the possible special
* cases.
*/
void write_char( char32_t wc, URL_FILE * output, bool escape) {
if (escape && !iswprint(wc)) {
url_fwprintf(output, L"\\%04x", wc);
// url_fputwc(L'\\', output);
} else {
url_fputwc(wc, output);
}
*/
void write_char( char32_t wc, URL_FILE *output, bool escape ) {
if ( escape && !iswprint( wc ) ) {
url_fwprintf( output, L"\\%04x", wc );
// url_fputwc(L'\\', output);
} else {
url_fputwc( wc, output );
}
}
struct pso_pointer print_string_like_thing(struct pso_pointer p,
URL_FILE *output, bool escape) {
switch (get_tag_value(p)) {
case KEYTV:
url_fputwc(L':', output);
break;
case STRINGTV:
if (escape)
url_fputwc(L'"', output);
break;
}
struct pso_pointer print_string_like_thing( struct pso_pointer p,
URL_FILE *output, bool escape ) {
switch ( get_tag_value( p ) ) {
case KEYTV:
url_fputwc( L':', output );
break;
case STRINGTV:
if ( escape )
url_fputwc( L'"', output );
break;
}
if (keywordp(p) || stringp(p) || symbolp(p)) {
for (struct pso_pointer cursor = p; !nilp(cursor);
cursor = pointer_to_object(cursor)->payload.string.cdr) {
char32_t wc = pointer_to_object(cursor)->payload.string.character;
if ( keywordp( p ) || stringp( p ) || symbolp( p ) ) {
for ( struct pso_pointer cursor = p; !nilp( cursor );
cursor = pointer_to_object( cursor )->payload.string.cdr ) {
char32_t wc =
pointer_to_object( cursor )->payload.string.character;
write_char( wc, output, escape);
}
}
write_char( wc, output, escape );
}
}
if (stringp(p)) {
if (escape)
url_fputwc(L'"', output);
}
return p;
if ( stringp( p ) ) {
if ( escape )
url_fputwc( L'"', output );
}
return p;
}
struct pso_pointer write_list_content(struct pso_pointer p, URL_FILE *output,
bool escape) {
struct pso_pointer result = nil;
struct pso_pointer write_list_content( struct pso_pointer p, URL_FILE *output,
bool escape ) {
struct pso_pointer result = nil;
if (consp(p)) {
for (; consp(p); p = c_cdr(p)) {
struct pso2 *object = pointer_to_object(p);
if ( consp( p ) ) {
for ( ; consp( p ); p = c_cdr( p ) ) {
struct pso2 *object = pointer_to_object( p );
result = in_write(object->payload.cons.car, output, escape);
result = in_write( object->payload.cons.car, output, escape );
if (exceptionp(result))
break;
if ( exceptionp( result ) )
break;
switch (get_tag_value(object->payload.cons.cdr)) {
case NILTV:
break;
case CONSTV:
url_fputwc(L' ', output);
break;
default:
url_fputws(L" . ", output);
result = in_write(object->payload.cons.cdr, output, escape);
}
}
} else {
// TODO: return exception
}
switch ( get_tag_value( object->payload.cons.cdr ) ) {
case NILTV:
break;
case CONSTV:
url_fputwc( L' ', output );
break;
default:
url_fputws( L" . ", output );
result =
in_write( object->payload.cons.cdr, output, escape );
}
}
} else {
// TODO: return exception
}
return result;
return result;
}
/**
@ -135,52 +137,53 @@ struct pso_pointer write_list_content(struct pso_pointer p, URL_FILE *output,
* reader; otherwise, print it appropriately for human readers.
* @return p on success, exception on failure.
*/
struct pso_pointer in_write(struct pso_pointer p, URL_FILE *output,
bool escape) {
struct pso2 *object = pointer_to_object(p);
struct pso_pointer result = nil;
struct pso_pointer in_write( struct pso_pointer p, URL_FILE *output,
bool escape ) {
struct pso2 *object = pointer_to_object( p );
struct pso_pointer result = nil;
if (object != NULL) {
uint32_t v = get_tag_value(p);
switch (v) {
case CHARACTERTV:
write_char(object->payload.character.character, output, escape);
break;
case CONSTV:
url_fputwc(L'(', output);
result = write_list_content(p, output, escape);
url_fputwc(L')', output);
break;
case INTEGERTV:
url_fwprintf(output, L"%d",
(int64_t)(object->payload.integer.value));
break;
case KEYTV:
case STRINGTV:
case SYMBOLTV:
print_string_like_thing(p, output, escape);
break;
case NILTV:
url_fputws(L"nil", output);
break;
case READTV:
case WRITETV:
url_fwprintf(output, L"<%s stream: ",
v == READTV ? "read" : "write");
in_write(object->payload.stream.meta, output, escape);
url_fputwc(L'>', output);
break;
case TRUETV:
url_fputwc(L't', output);
break;
default:
// TODO: return exception
}
} else {
// TODO: return exception
}
if ( object != NULL ) {
uint32_t v = get_tag_value( p );
switch ( v ) {
case CHARACTERTV:
write_char( object->payload.character.character, output,
escape );
break;
case CONSTV:
url_fputwc( L'(', output );
result = write_list_content( p, output, escape );
url_fputwc( L')', output );
break;
case INTEGERTV:
url_fwprintf( output, L"%d",
( int64_t ) ( object->payload.integer.value ) );
break;
case KEYTV:
case STRINGTV:
case SYMBOLTV:
print_string_like_thing( p, output, escape );
break;
case NILTV:
url_fputws( L"nil", output );
break;
case READTV:
case WRITETV:
url_fwprintf( output, L"<%s stream: ",
v == READTV ? "read" : "write" );
in_write( object->payload.stream.meta, output, escape );
url_fputwc( L'>', output );
break;
case TRUETV:
url_fputwc( L't', output );
break;
default:
// TODO: return exception
}
} else {
// TODO: return exception
}
return result;
return result;
}
/**
@ -195,31 +198,32 @@ struct pso_pointer in_write(struct pso_pointer p, URL_FILE *output,
* @param nl_after if true, print a newline *after* printing `p`; else a space.
* @return p on success, exception on failure.
*/
struct pso_pointer write(struct pso_pointer p, struct pso_pointer stream,
bool escape, bool nl_before, bool nl_after) {
struct pso_pointer result = p;
URL_FILE *output = writep(stream)
? pointer_to_object(stream)->payload.stream.stream
: file_to_url_file(stdout);
struct pso_pointer write( struct pso_pointer p, struct pso_pointer stream,
bool escape, bool nl_before, bool nl_after ) {
struct pso_pointer result = p;
URL_FILE *output = writep( stream )
? pointer_to_object( stream )->payload.stream.stream
: file_to_url_file( stdout );
if (writep(stream)) {
inc_ref(stream);
if ( writep( stream ) ) {
inc_ref( stream );
if (nl_before)
url_fputwc(L'\n', output);
if ( nl_before )
url_fputwc( L'\n', output );
result = in_write(p, output, true);
result = in_write( p, output, true );
url_fputwc(nl_after ? L'\n' : L' ', output);
url_fputwc( nl_after ? L'\n' : L' ', output );
dec_ref(stream);
} else {
result = make_exception(
c_string_to_lisp_string(L"Bad write stream passed to write."), nil,
nil, nil);
}
dec_ref( stream );
} else {
result =
make_exception( c_string_to_lisp_string
( L"Bad write stream passed to write." ), nil, nil,
nil );
}
return result;
return result;
}
/**
@ -229,13 +233,13 @@ struct pso_pointer write(struct pso_pointer p, struct pso_pointer stream,
* @param stream if a pointer to an open write stream, print to there.
* @return struct pso_pointer `nil`, or an exception if some erroe occurred.
*/
struct pso_pointer c_print(struct pso_pointer p, struct pso_pointer stream) {
return write(p, stream, true, true, false);
struct pso_pointer c_print( struct pso_pointer p, struct pso_pointer stream ) {
return write( p, stream, true, true, false );
}
/**
* @brief princ is pretty much like print except things are printed `unescaped`
*/
struct pso_pointer c_princ(struct pso_pointer p, struct pso_pointer stream) {
return write(p, stream, false, true, false);
struct pso_pointer c_princ( struct pso_pointer p, struct pso_pointer stream ) {
return write( p, stream, false, true, false );
}

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

@ -77,60 +77,60 @@ struct pso_pointer initialise_memory( uint32_t node ) {
/**
* @brief Pop an object off the freelist for the specified `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;
if ( size_class <= MAX_SIZE_CLASS ) {
if ( nilp( freelists[size_class] ) ) {
result = allocate_page( 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;
if ( nilp( result ) ) {
fputws( L"FATAL: Page space exhausted\n", stderr );
exit( 1 ); // TODO: we don't want to do this! Somehow, we need to
// recover a workable environment, ideally by throwing a pre-made
// exception.
}
if ( size_class <= MAX_SIZE_CLASS ) {
if ( nilp( freelists[size_class] ) ) {
result = allocate_page( size_class );
}
if ( !exceptionp( result ) && !nilp( result ) ) {
pthread_mutex_lock( &freelists_mutices[size_class]);
result = freelists[size_class];
struct pso2 *object = pointer_to_object( result );
freelists[size_class] = object->payload.free.next;
pthread_mutex_unlock(&freelists_mutices[size_class]);
if ( nilp( result ) ) {
fputws( L"FATAL: Page space exhausted\n", stderr );
exit( 1 ); // TODO: we don't want to do this! Somehow, we need to
// recover a workable environment, ideally by throwing a pre-made
// exception.
}
/* 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?
}
/* 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: Request to allocate object of size class %d, which is not implemented",
size_class);
}
}
} // TODO: else throw exception
return result;
if ( !exceptionp( result ) && !nilp( result ) ) {
pthread_mutex_lock( &freelists_mutices[size_class] );
result = freelists[size_class];
struct pso2 *object = pointer_to_object( result );
freelists[size_class] = object->payload.free.next;
pthread_mutex_unlock( &freelists_mutices[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?
}
/* 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: Request to allocate object of size class %d, which is not implemented",
size_class );
}
}
} // TODO: else throw exception
return result;
}
void push_freelist( struct pso_pointer p) {
struct pso2 *obj = pointer_to_object( p );
uint8_t size_class = ( obj->header.tag.bytes.size_class );
void push_freelist( struct pso_pointer p ) {
struct pso2 *obj = pointer_to_object( p );
uint8_t size_class = ( obj->header.tag.bytes.size_class );
strncpy( ( char * ) ( obj->header.tag.bytes.mnemonic ), FREETAG,
TAGLENGTH );
pthread_mutex_lock( &freelists_mutices[size_class]);
strncpy( ( char * ) ( obj->header.tag.bytes.mnemonic ), FREETAG,
TAGLENGTH );
if ( size_class <= MAX_SIZE_CLASS ) {
obj->payload.free.next = freelists[size_class];
freelists[size_class] = p;
}
pthread_mutex_unlock(&freelists_mutices[size_class]);
pthread_mutex_lock( &freelists_mutices[size_class] );
if ( size_class <= MAX_SIZE_CLASS ) {
obj->payload.free.next = freelists[size_class];
freelists[size_class] = p;
}
pthread_mutex_unlock( &freelists_mutices[size_class] );
}

6
src/c/memory/memory.h
View file

@ -10,6 +10,7 @@
#ifndef __psse_memory_memory_h
#define __psse_memory_memory_h
#include <pthread.h>
#include <stdbool.h>
#include "memory/pointer.h"
@ -26,10 +27,11 @@
struct pso_pointer initialise_memory( );
struct pso_pointer pop_freelist( uint8_t size_class);
void push_freelist( struct pso_pointer p);
struct pso_pointer pop_freelist( uint8_t size_class );
void push_freelist( struct pso_pointer p );
extern struct pso_pointer out_of_memory_exception;
extern struct pso_pointer freelists[];
extern pthread_mutex_t freelists_mutices[];
extern bool memory_initialised;
#endif

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

@ -319,11 +319,11 @@ struct pso_pointer allocate_page( uint8_t size_class ) {
L"\nAllocated page %d for objects of size class %x.\n",
npages_allocated, size_class );
pthread_mutex_lock( &freelists_mutices[size_class]);
pthread_mutex_lock( &freelists_mutices[size_class] );
freelists[size_class] =
initialise_page( ( union page * ) pg, npages_allocated,
size_class, freelists[size_class] );
pthread_mutex_unlock( &freelists_mutices[size_class]);
pthread_mutex_unlock( &freelists_mutices[size_class] );
debug_printf( DEBUG_ALLOC, 0,
L"Initialised page %d; freelist for size class %x updated with head at page %d, offset %d.\n",

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

@ -35,16 +35,20 @@
#include "ops/truth.h"
/**
* @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
* onto the `locals` slot on a stack frame. This guarantees
* 1. that they get `inc_ref`ed; and that,
* 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
* audited carefully.
*
* The stack frame pointer is DELIBERATELY a C pointer, not a Lisp pointer,
* because you are definitely not supposed to be calling this function from
* Lisp. Please do not!
*
* @param stack_pointer C (NOT Lisp!) pointer to an active stack frame (or
* NULL, but only during initialisation).
@ -52,8 +56,9 @@
* @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 pso4 * stack_pointer,*/ char *tag, uint8_t size_class ) {
// todo: issue #21: must have stack frame passed in.
struct pso_pointer allocate( struct pso4 *stack_pointer, char *tag,
uint8_t size_class ) {
// todo: issue #21: must have stack frame passed in.
#ifdef DEBUG
debug_printf( DEBUG_ALLOC, 0,
@ -61,26 +66,29 @@ struct pso_pointer allocate( /* struct pso4 * stack_pointer,*/ char *tag, uint8_
size_class, tag );
#endif
struct pso_pointer result = pop_freelist(size_class);
struct pso_pointer result = pop_freelist( size_class );
if (!nilp( result)) {
strncpy( ( char * ) ( pointer_to_object(result)->header.tag.bytes.mnemonic ), tag,
TAGLENGTH );
debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ",
result.page, result.offset );
// if ( stack_pointer != NULL &&
// (stack_pointer->header.tag.value & 0xffffff) == STACKTV) {
// struct pso_pointer locals = make_cons(result,
// stack_pointer->payload.stack_frame.locals);
// stack_pointer->payload.stack_frame.locals = locals;
//
// } else {
// fputws( L"WARNING: No stack frame passed to `allocate`.\n", stderr);
// }
} else {
// TODO: throw exception
}
if ( !nilp( result ) ) {
strncpy( ( char * ) ( pointer_to_object( result )->header.tag.bytes.
mnemonic ), tag, TAGLENGTH );
debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ",
result.page, result.offset );
if ( stack_pointer != NULL &&
( stack_pointer->header.tag.value & 0xffffff ) == STACKTV ) {
struct pso_pointer locals = make_cons( result,
stack_pointer->
payload.stack_frame.
locals );
stack_pointer->payload.stack_frame.locals = locals;
} else if ( memory_initialised ) {
fputws( L"WARNING: No stack frame passed to `allocate`.\n",
stderr );
}
} else {
// TODO: throw exception
}
#ifdef DEBUG
debug_print( exceptionp( result ) ? L"fail\n" : L"success\n", DEBUG_ALLOC,
@ -203,7 +211,7 @@ struct pso_pointer free_object( struct pso_pointer p ) {
obj->payload.words[i] = 0;
}
push_freelist(p);
push_freelist( p );
return result;
}

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

@ -14,9 +14,10 @@
#include "memory/header.h"
#include "memory/pointer.h"
#include "memory/pso4.h"
// todo: issue #21: must have stack frame passed in.
struct pso_pointer allocate( char *tag, uint8_t size_class );
struct pso_pointer allocate( struct pso4 *stack_pointer, char *tag,
uint8_t size_class );
struct pso_pointer dec_ref( struct pso_pointer pointer );

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

@ -41,6 +41,6 @@ struct pso_pointer lisp_bind(
struct pso_pointer c_bind( struct pso_pointer key,
struct pso_pointer value,
struct pso_pointer store ) {
// todo: issue #21: must have stack frame passed in.
// todo: issue #21: must have stack frame passed in.
return make_cons( make_cons( key, value ), store );
}

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

@ -85,12 +85,18 @@ struct pso_pointer eval(
default:
result =
make_exception( make_cons
( c_string_to_lisp_string
( L"Can't yet evaluate things of this type: " ),
result ), frame_pointer,
make_cons( make_cons
( c_string_to_lisp_keyword( L"tag" ),
get_tag_string( result ) ), nil ),
( frame, c_string_to_lisp_string
( frame,
L"Can't yet evaluate things of this type: " ),
result ), frame_pointer, make_cons( frame,
make_cons
( frame,
c_string_to_lisp_keyword
( frame,
L"tag" ),
get_tag_string
( result ) ),
nil ),
nil );
}

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

@ -44,7 +44,7 @@ struct pso_pointer cdr(
#ifdef MANAGED_POINTER_ONLY
struct pso4 *frame = pointer_to_pso4( frame_pointer );
#endif
return c_cdr( fetch_arg( frame, 0 ) );
return c_cdr( frame, fetch_arg( frame, 0 ) );
}
/**
@ -66,7 +66,7 @@ struct pso_pointer cons(
struct pso4 *frame = pointer_to_pso4( frame_pointer );
#endif
return make_cons( fetch_arg( frame, 0 ), fetch_arg( frame, 1 ) );
return make_cons( frame, fetch_arg( frame, 0 ), fetch_arg( frame, 1 ) );
}
#endif

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

@ -48,11 +48,13 @@ void int_handler( int dummy ) {
* Very simple read/eval/print loop for bootstrapping.
*/
void c_repl( bool show_prompt ) {
// todo: issue #21: must have stack frame passed in.
// todo: issue #21: must have stack frame passed in.
signal( SIGINT, int_handler );
debug_print( L"Entered repl\n", DEBUG_REPL, 0 );
struct pso_pointer env = consp( oblist ) ? oblist : make_cons( oblist, nil );
// TODO: NULL is not OK here, but will do until we have a REPL in Lisp.
struct pso_pointer env =
consp( oblist ) ? oblist : make_cons( NULL, oblist, nil );
struct pso_pointer input_stream = c_assoc( lisp_io_in, env );
struct pso_pointer output_stream = c_assoc( lisp_io_out, env );

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

@ -13,7 +13,7 @@
#define SRC_C_OPS_REPL_H_
// todo: issue #21: must have stack frame passed in.
// todo: issue #21: must have stack frame passed in.
void c_repl( );

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

@ -36,7 +36,7 @@
* the argument was not a sequence.
*/
struct pso_pointer c_reverse( struct pso_pointer sequence ) {
// todo: issue #21: must have stack frame passed in.
// todo: issue #21: must have stack frame passed in.
struct pso_pointer result = nil;
for ( struct pso_pointer cursor = sequence; !nilp( sequence );
@ -66,8 +66,8 @@ struct pso_pointer c_reverse( struct pso_pointer sequence ) {
default:
result =
make_exception( make_cons( c_string_to_lisp_string
( L"Invalid object in sequence" ),
cursor ), nil, nil, nil );
( L"Invalid object in sequence" ),
cursor ), nil, nil, nil );
goto exit;
break;
}

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

@ -69,12 +69,13 @@ uint32_t calculate_hash( wint_t c, struct pso_pointer ptr ) {
* char32_t in larger pso classes, so this function may be only for strings
* (and thus simpler).
*/
struct pso_pointer make_string_like_thing( wint_t c, struct pso_pointer tail,
struct pso_pointer make_string_like_thing( struct pso4 *frame_pointer,
wint_t c, struct pso_pointer tail,
char *tag ) {
struct pso_pointer pointer = tail;
if ( check_type( tail, tag ) || nilp( tail ) ) {
pointer = allocate( tag, CONS_SIZE_CLASS );
pointer = allocate( frame_pointer, tag, CONS_SIZE_CLASS );
struct pso2 *cell = pointer_to_object( pointer );
cell->payload.string.character = c;
@ -106,8 +107,9 @@ struct pso_pointer make_string_like_thing( wint_t c, struct pso_pointer tail,
* @param c the character to add (prepend);
* @param tail the string which is being built.
*/
struct pso_pointer make_string( wint_t c, struct pso_pointer tail ) {
return make_string_like_thing( c, tail, STRINGTAG );
struct pso_pointer make_string( struct pso4 *frame_pointer, wint_t c,
struct pso_pointer tail ) {
return make_string_like_thing( frame_pointer, c, tail, STRINGTAG );
}
/**
@ -118,8 +120,9 @@ struct pso_pointer make_string( wint_t c, struct pso_pointer tail ) {
* @param c the character to add (prepend);
* @param tail the keyword which is being built.
*/
struct pso_pointer make_keyword( wint_t c, struct pso_pointer tail ) {
return make_string_like_thing( c, tail, KEYTAG );
struct pso_pointer make_keyword( struct pso4 *frame_pointer, wint_t c,
struct pso_pointer tail ) {
return make_string_like_thing( frame_pointer, c, tail, KEYTAG );
}
/**
@ -130,22 +133,26 @@ struct pso_pointer make_keyword( wint_t c, struct pso_pointer tail ) {
* @param c the character to add (prepend);
* @param tail the symbol which is being built.
*/
struct pso_pointer make_symbol( wint_t c, struct pso_pointer tail ) {
return make_string_like_thing( c, tail, SYMBOLTAG );
struct pso_pointer make_symbol( struct pso4 *frame_pointer, wint_t c,
struct pso_pointer tail ) {
return make_string_like_thing( frame_pointer, c, tail, SYMBOLTAG );
}
/**
* Return a lisp string representation of this wide character string.
*/
struct pso_pointer c_string_to_lisp_string( char32_t *string ) {
struct pso_pointer c_string_to_lisp_string( struct pso4 *frame_pointer,
char32_t *string ) {
struct pso_pointer result = nil;
for ( int i = wcslen( string ) - 1; i >= 0; i-- ) {
if ( string[i] != '"' ) {
result = make_string( string[i], result );
result = make_string( frame_pointer, string[i], result );
} else {
result = make_string( L'\\', make_string( string[i], result ) );
result = make_string( frame_pointer, L'\\',
make_string( frame_pointer, string[i],
result ) );
}
}
@ -157,14 +164,15 @@ struct pso_pointer c_string_to_lisp_string( char32_t *string ) {
* Return a lisp symbol representation of this wide character string. In
* symbols, I am accepting only lower case characters.
*/
struct pso_pointer c_string_to_lisp_symbol( char32_t *symbol ) {
struct pso_pointer c_string_to_lisp_symbol( struct pso4 *frame_pointer,
char32_t *symbol ) {
struct pso_pointer result = nil;
for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) {
char32_t c = towlower( symbol[i] );
if ( iswalpha( c ) || c == L'-' || c == L'*' ) {
result = make_symbol( c, result );
result = make_symbol( frame_pointer, c, result );
}
}
@ -175,14 +183,15 @@ struct pso_pointer c_string_to_lisp_symbol( char32_t *symbol ) {
* Return a lisp keyword representation of this wide character string. In
* keywords, I am accepting only lower case characters and numbers.
*/
struct pso_pointer c_string_to_lisp_keyword( char32_t *symbol ) {
struct pso_pointer c_string_to_lisp_keyword( struct pso4 *frame_pointer,
char32_t *symbol ) {
struct pso_pointer result = nil;
for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) {
char32_t c = towlower( symbol[i] );
if ( iswalnum( c ) || c == L'-' ) {
result = make_keyword( c, result );
result = make_keyword( frame_pointer, c, result );
}
}

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

@ -17,19 +17,26 @@
#include <wchar.h>
#include <wctype.h>
struct pso_pointer make_string_like_thing( wint_t c, struct pso_pointer tail,
struct pso_pointer make_string_like_thing( struct pso4 *frame_pointer,
wint_t c, struct pso_pointer tail,
char *tag );
struct pso_pointer make_string( wint_t c, struct pso_pointer tail );
struct pso_pointer make_string( struct pso4 *frame_pointer, wint_t c,
struct pso_pointer tail );
struct pso_pointer make_keyword( wint_t c, struct pso_pointer tail );
struct pso_pointer make_keyword( struct pso4 *frame_pointer, wint_t c,
struct pso_pointer tail );
struct pso_pointer make_symbol( wint_t c, struct pso_pointer tail );
struct pso_pointer make_symbol( struct pso4 *frame_pointer, wint_t c,
struct pso_pointer tail );
struct pso_pointer c_string_to_lisp_string( char32_t *string );
struct pso_pointer c_string_to_lisp_string( struct pso4 *frame_pointer,
char32_t * string );
struct pso_pointer c_string_to_lisp_keyword( char32_t *symbol );
struct pso_pointer c_string_to_lisp_keyword( struct pso4 *frame_pointer,
char32_t * symbol );
struct pso_pointer c_string_to_lisp_symbol( char32_t *symbol );
struct pso_pointer c_string_to_lisp_symbol( struct pso4 *frame_pointer,
char32_t * symbol );
#endif

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

@ -24,8 +24,8 @@
#include "payloads/character.h"
struct pso_pointer make_character( wint_t c ) {
struct pso_pointer result = allocate( CHARACTERTAG, 2 );
struct pso_pointer make_character( struct pso4 *frame_pointer, wint_t c ) {
struct pso_pointer result = allocate( frame_pointer, CHARACTERTAG, 2 );
if ( !nilp( result ) ) {
pointer_to_object( result )->payload.character.character =

3
src/c/payloads/character.h
View file

@ -26,6 +26,7 @@
#include <wchar.h>
#include <wctype.h>
#include "memory/pso4.h"
#define CHARTAG "CHR"
#define CHARTV 5392451
@ -37,5 +38,5 @@ struct character_payload {
char32_t character;
};
struct pso_pointer make_character( wint_t c );
struct pso_pointer make_character( struct pso4 *frame_pointer, wint_t c );
#endif

18
src/c/payloads/cons.c
View file

@ -30,9 +30,11 @@
* @param cdr the pointer which should form the cdr of this cons cell.
* @return struct pso_pointer a pointer to the newly allocated cons cell.
*/
struct pso_pointer make_cons(struct pso_pointer car, struct pso_pointer cdr) {
// todo: issue #21: must have stack frame passed in.
struct pso_pointer result = allocate( CONSTAG, 2 );
struct pso_pointer make_cons( struct pso4 *frame_pointer,
struct pso_pointer car,
struct pso_pointer cdr ) {
// todo: issue #21: must have stack frame passed in.
struct pso_pointer result = allocate( frame_pointer, CONSTAG, 2 );
struct pso2 *object = pointer_to_object( result );
object->payload.cons.car = inc_ref( car );
@ -68,8 +70,8 @@ struct pso_pointer c_car( struct pso_pointer cons ) {
* @return the cdr of the indicated cell.
* @exception if the pointer does not indicate a cons cell.
*/
struct pso_pointer c_cdr(struct pso_pointer p) {
// todo: issue #21: must have stack frame passed in.
struct pso_pointer c_cdr( struct pso4 *stack_pointer, struct pso_pointer p ) {
// todo: issue #21: must have stack frame passed in.
struct pso_pointer result = nil;
struct pso2 *object = pointer_to_object( p );
@ -85,8 +87,8 @@ struct pso_pointer c_cdr(struct pso_pointer p) {
default:
result =
make_exception( make_cons
( c_string_to_lisp_string
( L"Invalid type for cdr" ),
( stack_pointer, c_string_to_lisp_string
( stack_pointer, L"Invalid type for cdr" ),
get_tag_string( p ) ), nil, nil, nil );
break;
}
@ -109,6 +111,6 @@ struct pso_pointer destroy_cons( struct pso_pointer fp,
struct pso4 *frame = pointer_to_pso4( fp );
struct pso_pointer p = frame->payload.stack_frame.arg[0];
dec_ref( c_car( p ) );
dec_ref( c_cdr( p ) );
dec_ref( c_cdr( frame, p ) );
}
}

7
src/c/payloads/cons.h
View file

@ -12,6 +12,7 @@
#include <stdbool.h>
#include "memory/pointer.h"
#include "memory/pso4.h"
#define CONS_SIZE_CLASS 2
@ -28,10 +29,12 @@ struct cons_payload {
struct pso_pointer c_car( struct pso_pointer cons );
struct pso_pointer c_cdr( struct pso_pointer cons );
struct pso_pointer c_cdr( struct pso4 *stack_pointer,
struct pso_pointer cons );
// todo: issue #21: must have stack frame passed in.
struct pso_pointer make_cons( struct pso_pointer car, struct pso_pointer cdr );
struct pso_pointer make_cons( struct pso4 *stack_pointer,
struct pso_pointer car, struct pso_pointer cdr );
struct pso_pointer destroy_cons( struct pso_pointer fp,
struct pso_pointer env );

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

@ -38,7 +38,8 @@ struct pso_pointer make_exception( struct pso_pointer message,
struct pso_pointer frame,
struct pso_pointer meta,
struct pso_pointer cause ) {
struct pso_pointer result = allocate( EXCEPTIONTAG, 3 );
struct pso_pointer result =
allocate( pointer_to_pso4( frame ), EXCEPTIONTAG, 3 );
if ( !nilp( result ) && !exceptionp( result ) ) {
struct pso3 *object = ( struct pso3 * ) pointer_to_object( result );

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

@ -14,6 +14,7 @@
#include "memory/pointer.h"
#include "memory/pso.h"
#include "memory/pso2.h"
#include "memory/pso4.h"
#include "memory/tags.h"
#include "debug.h"
@ -24,11 +25,11 @@
* @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( int64_t value ) {
struct pso_pointer make_integer( struct pso4 *frame_pointer, int64_t value ) {
struct pso_pointer result = nil;
debug_print( L"Entering make_integer\n", DEBUG_ALLOC, 0 );
result = allocate( INTEGERTAG, 2 );
result = allocate( frame_pointer, INTEGERTAG, 2 );
struct pso2 *cell = pointer_to_object( result );
cell->payload.integer.value = value;

4
src/c/payloads/integer.h
View file

@ -12,6 +12,8 @@
#include <stdint.h>
#include "memory/pso4.h"
/**
* @brief An integer .
*
@ -23,6 +25,6 @@ struct integer_payload {
__int128_t value;
};
struct pso_pointer make_integer( int64_t value );
struct pso_pointer make_integer( struct pso4 *frame_pointer, int64_t value );
#endif

10
src/c/payloads/psse_string.c
View file

@ -8,23 +8,19 @@
*/
#include <stdint.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include "memory/node.h"
#include "memory/pointer.h"
#include "memory/pso.h"
#include "memory/pso2.h"
#include "memory/pso4.h"
#include "memory/tags.h"
#include "ops/string_ops.h"
#include "ops/truth.h"
#include "payloads/cons.h"
/**
* @brief When an string is freed, its cdr pointer must be decremented.
@ -38,7 +34,7 @@ struct pso_pointer destroy_string( struct pso_pointer fp,
struct pso4 *frame = pointer_to_pso4( fp );
struct pso_pointer p = frame->payload.stack_frame.arg[0];
dec_ref( c_cdr( p ) );
dec_ref( c_cdr( frame, p ) );
}
return nil;

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

@ -15,6 +15,7 @@
#include "memory/pointer.h"
#include "memory/pso.h"
#include "memory/pso2.h"
#include "memory/pso4.h"
#include "memory/tags.h"
@ -24,9 +25,10 @@
* @param metadata a pointer to an associaton containing metadata on the stream.
* @return a pointer to the new read stream.
*/
struct pso_pointer make_read_stream( URL_FILE *input,
struct pso_pointer make_read_stream( struct pso4 *frame_pointer,
URL_FILE *input,
struct pso_pointer metadata ) {
struct pso_pointer pointer = allocate( READTAG, 2 );
struct pso_pointer pointer = allocate( frame_pointer, READTAG, 2 );
struct pso2 *cell = pointer_to_object( pointer );
cell->payload.stream.stream = input;

3
src/c/payloads/read_stream.h
View file

@ -29,7 +29,8 @@ struct stream_payload {
struct pso_pointer meta;
};
struct pso_pointer make_read_stream( URL_FILE * input,
struct pso_pointer make_read_stream( struct pso4 *frame_pointer,
URL_FILE * input,
struct pso_pointer metadata );
#endif

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

@ -33,12 +33,13 @@
*/
struct pso_pointer make_frame( int arg_count, struct pso_pointer previous,
... ) {
// todo: issue #21: must have stack frame passed in.
// todo: issue #21: must have stack frame passed in.
va_list args;
va_start( args, previous );
struct pso_pointer frame_pointer = allocate( STACKTAG, 4 );
struct pso4 *frame = ( struct pso4 * ) pointer_to_object( frame_pointer );
struct pso4 *frame = pointer_to_pso4( previous );
struct pso_pointer frame_pointer =
allocate( pointer_to_pso4( previous ), STACKTAG, 4 );
#ifdef DEBUG
debug_printf( DEBUG_ALLOC, 0,
@ -72,7 +73,8 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous,
for ( ; cursor < arg_count; cursor++ ) {
more_args =
make_cons( va_arg( args, struct pso_pointer ), more_args );
make_cons( frame, va_arg( args, struct pso_pointer ),
more_args );
}
frame->payload.stack_frame.more = c_reverse( more_args );
@ -103,6 +105,8 @@ struct pso_pointer destroy_stack_frame( struct pso_pointer fp,
dec_ref( frame->payload.stack_frame.previous );
dec_ref( frame->payload.stack_frame.function );
dec_ref( frame->payload.stack_frame.more );
dec_ref( frame->payload.stack_frame.locals );
dec_ref( frame->payload.stack_frame.env );
for ( int i = 0; i < args_in_frame; i++ ) {
dec_ref( frame->payload.stack_frame.arg[i] );

8
src/c/payloads/stack.h
View file

@ -31,10 +31,10 @@ struct stack_frame_payload {
struct pso_pointer more;
/** the function to be called. */
struct pso_pointer function;
/** the execute-time environment */
struct pso_pointer env;
/** a list of objects created in the context of this frame */
struct pso_pointer locals;
/** the execute-time environment */
struct pso_pointer env;
/** a list of objects created in the context of this frame */
struct pso_pointer locals;
/** the number of arguments provided. */
uint32_t args;
/** the depth of the stack below this frame */

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

@ -15,6 +15,7 @@
#include "memory/pointer.h"
#include "memory/pso.h"
#include "memory/pso2.h"
#include "memory/pso4.h"
#include "memory/tags.h"
@ -24,9 +25,10 @@
* @param metadata a pointer to an associaton containing metadata on the stream.
* @return a pointer to the new read stream.
*/
struct pso_pointer make_write_stream( URL_FILE *output,
struct pso_pointer make_write_stream( struct pso4 *frame_pointer,
URL_FILE *output,
struct pso_pointer metadata ) {
struct pso_pointer pointer = allocate( WRITETAG, 2 );
struct pso_pointer pointer = allocate( frame_pointer, WRITETAG, 2 );
struct pso2 *cell = pointer_to_object( pointer );
cell->payload.stream.stream = output;

3
src/c/payloads/write_stream.h
View file

@ -13,6 +13,7 @@
/* write stream shares a payload with /see read_streem.h */
#include "io/fopen.h"
struct pso_pointer make_write_stream( URL_FILE * output,
struct pso_pointer make_write_stream( struct pso4 *frame_pointer,
URL_FILE * output,
struct pso_pointer metadata );
#endif