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

It compiles. It runs. Nothing works, but it also doesn't crash. Victory!

Browse source
This commit is contained in:
Simon Brooke 2026-04-23 11:50:30 +01:00
parent 8d2acbeb0f
commit aa0d60bbed
20 changed files with 390 additions and 244 deletions
Download patch file Download diff file Expand all files Collapse all files

18
src/c/debug.c
View file

@ -118,15 +118,15 @@ 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, ... ) {
#ifdef DEBUG #ifdef DEBUG
if ( level & verbosity ) { // if ( level & verbosity ) {
fwide( stderr, 1 ); // fwide( stderr, 1 );
for ( int i = 0; i < indent; i++ ) { // for ( int i = 0; i < indent; i++ ) {
fputws( L" ", stderr ); // fputws( L" ", stderr );
} // }
va_list( args ); // va_list( args );
va_start( args, format ); // va_start( args, format );
vfwprintf( stderr, format, args ); // vfwprintf( stderr, format, args );
} // }
#endif #endif
} }

2
src/c/environment/environment.c
View file

@ -41,7 +41,7 @@ bool environment_initialised = false;
struct pso_pointer initialise_environment( uint32_t node ) { struct pso_pointer initialise_environment( uint32_t node ) {
struct pso_pointer result = initialise_memory( node ); struct pso_pointer result = initialise_memory( node );
struct pso_pointer frame_pointer = make_frame( 0, nil ); struct pso_pointer frame_pointer = nil; // can't have a frame pointer before we've initialised nil and t
if ( c_truep( result ) ) { if ( c_truep( result ) ) {
debug_print( L"Initialising `nil`... ", DEBUG_BOOTSTRAP, 0 ); debug_print( L"Initialising `nil`... ", DEBUG_BOOTSTRAP, 0 );

338
src/c/io/io.c
View file

@ -106,6 +106,16 @@ struct pso_pointer lisp_stderr;
*/ */
struct pso_pointer lisp_io_prompt; struct pso_pointer lisp_io_prompt;
/**
* @brief bound to the Lisp symbol representing C_IO_READBASE in initialisation
*/
struct pso_pointer lisp_io_readbase;
/**
* @brief bound to the Lisp symbol representing C_IO_READTABLE in initialisation
*/
struct pso_pointer lisp_io_readtable;
/** /**
* Allow a one-character unget facility. This may not be enough - we may need * Allow a one-character unget facility. This may not be enough - we may need
* to allocate a buffer. * to allocate a buffer.
@ -134,6 +144,10 @@ URL_FILE *file_to_url_file( FILE *f ) {
* @return 0 on success; any other value means failure. * @return 0 on success; any other value means failure.
*/ */
int initialise_io( ) { int initialise_io( ) {
fwide( stdin, 1 );
fwide( stdout, 1 );
fwide( stderr, 1 );
int result = curl_global_init( CURL_GLOBAL_SSL ); int result = curl_global_init( CURL_GLOBAL_SSL );
io_share = curl_share_init( ); io_share = curl_share_init( );
@ -150,75 +164,100 @@ int initialise_io( ) {
return result; return result;
} }
struct pso_pointer initialise_default_streams( struct pso_pointer stack_frame, struct pso_pointer initialise_default_streams( struct pso_pointer
frame_pointer,
struct pso_pointer env ) { struct pso_pointer env ) {
// todo: issue #21: should this have stack frame passed in? // todo: issue #21: should this have stack frame passed in?
// It's called in initialisation before everything else is set // It's called in initialisation before everything else is set
// up, so **possibly** not? // up, so **possibly** not?
lisp_io_in = c_string_to_lisp_symbol( stack_frame, C_IO_IN ); lisp_io_in = c_string_to_lisp_symbol( frame_pointer, C_IO_IN );
lisp_io_out = c_string_to_lisp_symbol( stack_frame, C_IO_OUT ); lisp_io_out = c_string_to_lisp_symbol( frame_pointer, C_IO_OUT );
lisp_io_log = c_string_to_lisp_symbol( stack_frame, C_IO_LOG ); lisp_io_log = c_string_to_lisp_symbol( frame_pointer, C_IO_LOG );
lisp_io_prompt = c_string_to_lisp_symbol( stack_frame, C_IO_PROMPT ); lisp_io_prompt = c_string_to_lisp_symbol( frame_pointer, C_IO_PROMPT );
lisp_io_readbase = c_string_to_lisp_symbol( frame_pointer, C_IO_READBASE );
lisp_io_readtable =
c_string_to_lisp_symbol( frame_pointer, C_IO_READTABLE );
debug_print( L"In initialise_default_streams; environment is: ", DEBUG_IO, debug_print( L"In initialise_default_streams; environment is: ", DEBUG_IO,
0 ); 0 );
debug_print_object( env, DEBUG_IO, 0 ); debug_print_object( env, DEBUG_IO, 0 );
env = env =
lisp_bind( make_frame lisp_bind( make_frame( 3, frame_pointer, lisp_io_prompt,
( 3, stack_frame, lisp_io_prompt, c_string_to_lisp_string( frame_pointer,
c_string_to_lisp_string( stack_frame, INITIAL_PROMPT ), INITIAL_PROMPT ),
env ) ); lisp_bind( make_frame
( 3, frame_pointer, lisp_io_readbase,
acquire_integer( frame_pointer,
10 ),
lisp_bind( make_frame
( 3, frame_pointer,
lisp_io_readtable,
nil, env ) ) ) ) ) );
lisp_stdin = lisp_stdin =
lock_object( make_read_stream lock_object( make_read_stream
( stack_frame, file_to_url_file( stdin ), ( frame_pointer, file_to_url_file( stdin ),
make_cons( stack_frame, make_cons( frame_pointer,
make_cons( stack_frame, make_cons( frame_pointer,
c_string_to_lisp_keyword c_string_to_lisp_keyword
( stack_frame, L"url" ), ( frame_pointer, L"url" ),
c_string_to_lisp_string c_string_to_lisp_string
( stack_frame, ( frame_pointer,
L"::system:standard-input" ) ), L"::system:standard-input" ) ),
stack_frame ) ) ); frame_pointer ) ) );
env = env =
lisp_bind( make_frame( 3, stack_frame, lisp_io_in, lisp_stdin, env ) ); lisp_bind( make_frame
( 3, frame_pointer, lisp_io_in, lisp_stdin, env ) );
debug_print_object( env, DEBUG_IO, 0 ); debug_print_object( env, DEBUG_IO, 0 );
if ( !c_nilp( env ) && !exceptionp( env ) ) { if ( !c_nilp( env ) && !exceptionp( env ) ) {
lisp_stdout = lisp_stdout =
lock_object( make_write_stream( stack_frame, lock_object( make_write_stream( frame_pointer,
file_to_url_file( stdout ), file_to_url_file( stdout ),
make_cons( stack_frame, make_cons( frame_pointer,
make_cons( stack_frame, make_cons
c_string_to_lisp_keyword ( frame_pointer,
( stack_frame, c_string_to_lisp_keyword
L"url" ), ( frame_pointer,
c_string_to_lisp_string L"url" ),
( stack_frame, c_string_to_lisp_string
L"::system:standard-output" ) ), ( frame_pointer,
L"::system:standard-output" ) ),
nil ) ) ); nil ) ) );
env = env =
lisp_bind( make_frame lisp_bind( make_frame
( 3, stack_frame, lisp_io_out, lisp_stdout, env ) ); ( 3, frame_pointer, lisp_io_out, lisp_stdout, env ) );
} }
if ( !c_nilp( env ) && !exceptionp( env ) ) { if ( !c_nilp( env ) && !exceptionp( env ) ) {
lisp_stderr = lisp_stderr =
lock_object( make_write_stream lock_object( make_write_stream
( stack_frame, file_to_url_file( stderr ), ( frame_pointer, file_to_url_file( stderr ),
make_cons( stack_frame, make_cons( frame_pointer,
make_cons( stack_frame, make_cons( frame_pointer,
c_string_to_lisp_keyword c_string_to_lisp_keyword
( stack_frame, L"url" ), ( frame_pointer, L"url" ),
c_string_to_lisp_string c_string_to_lisp_string
( stack_frame, ( frame_pointer,
L"::system:standard-output" ) ), L"::system:standard-output" ) ),
nil ) ) ); nil ) ) );
env = env =
lisp_bind( make_frame lisp_bind( make_frame
( 3, frame_pointer, lisp_io_log, lisp_stderr, env ) ); ( 3, frame_pointer, lisp_io_log, lisp_stderr, env ) );
} }
// TODO: create the sink stream. Something like:
// URL_FILE *sink = url_fopen( "/dev/null", "w" );
// fwide( sink->handle.file, 1 );
// bind_value( L"*sink*",
// make_write_stream( sink,
// make_cons( make_cons
// ( c_string_to_lisp_keyword
// ( L"url" ),
// c_string_to_lisp_string
// ( L"system:standard sink" ) ),
// NIL ) ), false );
debug_print( L"Leaving initialise_default_streams; environment is: ", debug_print( L"Leaving initialise_default_streams; environment is: ",
DEBUG_IO, 0 ); DEBUG_IO, 0 );
@ -226,40 +265,6 @@ struct pso_pointer initialise_default_streams( struct pso_pointer stack_frame,
return env; return env;
} }
/**
* Convert this lisp string-like-thing (also works for symbols, and, later
* keywords) into a UTF-8 string. NOTE that the returned value has been
* malloced and must be freed. TODO: candidate to moving into a utilities
* file.
*
* @param s the lisp string or symbol;
* @return the c string.
*/
char *lisp_string_to_c_string( struct pso_pointer s ) {
char *result = NULL;
if ( stringp( s ) || symbolp( s ) ) {
int len = 0;
for ( struct pso_pointer c = s; !c_nilp( c ); c = c_cdr( c ) ) {
len++;
}
char32_t *buffer = calloc( len + 1, sizeof( char32_t ) );
/* worst case, one wide char = four utf bytes */
result = calloc( ( len * 4 ) + 1, sizeof( char ) );
int i = 0;
for ( struct pso_pointer c = s; !c_nilp( c ); c = c_cdr( c ) ) {
buffer[i++] = pointer_to_object( c )->payload.string.character;
}
wcstombs( result, buffer, len );
free( buffer );
}
debug_print( L"lisp_string_to_c_string( ", DEBUG_IO, 0 );
debug_print_object( s, DEBUG_IO, 0 );
debug_printf( DEBUG_IO, 0, L") => '%s'\n", result );
return result;
}
/** /**
* get one wide character from the buffer. * get one wide character from the buffer.
@ -351,25 +356,6 @@ wint_t url_ungetwc( wint_t wc, URL_FILE *input ) {
return result; return result;
} }
/**
* @brief Read one character object from this `read_stream`.
*
* @param read_stream a pointer to an object which should be a read stream
* object,
*
* @return a pointer to a character object on success, or `nil` on failure.
*/
struct pso_pointer get_character( struct pso_pointer read_stream ) {
struct pso_pointer result = nil;
if ( readp( read_stream ) ) {
result =
make_character( url_fgetwc
( pointer_to_object_of_size_class
( read_stream, 2 )->payload.stream.stream ) );
}
return result;
}
/** /**
* @brief Push back this character `c` onto this read stream `r`. * @brief Push back this character `c` onto this read stream `r`.
@ -384,8 +370,8 @@ struct pso_pointer push_back_character( struct pso_pointer c,
struct pso_pointer result = nil; struct pso_pointer result = nil;
if ( characterp( c ) && readp( r ) ) { if ( characterp( c ) && readp( r ) ) {
if ( url_ungetwc( ( wint_t ) if ( url_ungetwc( ( wint_t )
( pointer_to_object( c )->payload.character. ( pointer_to_object( c )->payload.
character ), character.character ),
pointer_to_object( r )->payload.stream.stream ) >= pointer_to_object( r )->payload.stream.stream ) >=
0 ) { 0 ) {
result = t; result = t;
@ -412,8 +398,8 @@ struct pso_pointer lisp_close( struct pso_pointer frame_pointer,
struct pso_pointer result = nil; struct pso_pointer result = nil;
if ( readp( fetch_arg( frame, 0 ) ) || writep( fetch_arg( frame, 0 ) ) ) { if ( readp( fetch_arg( frame, 0 ) ) || writep( fetch_arg( frame, 0 ) ) ) {
if ( url_fclose if ( url_fclose
( pointer_to_object( fetch_arg( frame, 0 ) )->payload.stream. ( pointer_to_object( fetch_arg( frame, 0 ) )->payload.
stream ) stream.stream )
== 0 ) { == 0 ) {
result = t; result = t;
} }
@ -422,34 +408,43 @@ struct pso_pointer lisp_close( struct pso_pointer frame_pointer,
return result; return result;
} }
struct pso_pointer add_meta_integer( struct pso_pointer meta, char32_t *key, struct pso_pointer add_meta_integer( struct pso_pointer frame_pointer,
struct pso_pointer meta, char32_t *key,
long int value ) { long int value ) {
// todo: issue #21: must have stack frame passed in. return make_cons( frame_pointer,
return make_cons( frame_pointer,
make_cons( make_cons c_string_to_lisp_keyword( frame_pointer,
( c_string_to_lisp_keyword( key ), make_integer( value ) ), key ),
meta ); make_integer( frame_pointer, value ) ),
meta );
} }
struct pso_pointer add_meta_string( struct pso_pointer meta, char32_t *key, struct pso_pointer add_meta_string( struct pso_pointer frame_pointer,
struct pso_pointer meta, char32_t *key,
char *value ) { char *value ) {
// todo: issue #21: must have stack frame passed in.
value = trim( value ); value = trim( value );
char32_t buffer[strlen( value ) + 1]; char32_t buffer[strlen( value ) + 1];
mbstowcs( buffer, value, strlen( value ) + 1 ); mbstowcs( buffer, value, strlen( value ) + 1 );
return return make_cons( frame_pointer,
make_cons( make_cons make_cons( frame_pointer,
( c_string_to_lisp_keyword( frame_pointer, key ), c_string_to_lisp_keyword( frame_pointer,
c_string_to_lisp_string( buffer ) ), meta ); key ),
c_string_to_lisp_string( frame_pointer,
buffer ) ), meta );
} }
struct pso_pointer add_meta_time( struct pso_pointer meta, char32_t *key, struct pso_pointer add_meta_time( struct pso_pointer frame_pointer,
struct pso_pointer meta, char32_t *key,
time_t *value ) { time_t *value ) {
// todo: issue #21: must have stack frame passed in. return make_cons( frame_pointer,
char datestring[256]; make_cons( frame_pointer,
strftime( datestring, sizeof( datestring ), nl_langinfo( D_T_FMT ), c_string_to_lisp_keyword( frame_pointer,
localtime( value ) ); key ),
return add_meta_string( meta, key, datestring ); make_time( frame_pointer,
( value ==
NULL ) ? nil :
make_integer( frame_pointer,
*value ) ) ), meta );
} }
/** /**
@ -505,11 +500,12 @@ static size_t write_meta_callback( char *string, size_t size, size_t nmemb,
return 0; // strlen( string ); return 0; // strlen( string );
} }
void collect_meta( struct pso_pointer stream, char *url ) { void collect_meta( struct pso_pointer frame_pointer, struct pso_pointer stream,
char *url ) {
struct pso2 *cell = pointer_to_object( stream ); struct pso2 *cell = pointer_to_object( stream );
URL_FILE *s = pointer_to_object( stream )->payload.stream.stream; URL_FILE *s = pointer_to_object( stream )->payload.stream.stream;
struct pso_pointer meta = struct pso_pointer meta =
add_meta_string( cell->payload.stream.meta, L"url", add_meta_string( frame_pointer, cell->payload.stream.meta, L"url",
url ); url );
struct stat statbuf; struct stat statbuf;
int result = stat( url, &statbuf ); int result = stat( url, &statbuf );
@ -521,21 +517,31 @@ void collect_meta( struct pso_pointer stream, char *url ) {
case CFTYPE_FILE: case CFTYPE_FILE:
if ( result == 0 ) { if ( result == 0 ) {
if ( ( pwd = getpwuid( statbuf.st_uid ) ) != NULL ) { if ( ( pwd = getpwuid( statbuf.st_uid ) ) != NULL ) {
meta = add_meta_string( meta, L"owner", pwd->pw_name ); meta =
add_meta_string( frame_pointer, meta, L"owner",
pwd->pw_name );
} else { } else {
meta = add_meta_integer( meta, L"owner", statbuf.st_uid ); meta =
add_meta_integer( frame_pointer, meta, L"owner",
statbuf.st_uid );
} }
if ( ( grp = getgrgid( statbuf.st_gid ) ) != NULL ) { if ( ( grp = getgrgid( statbuf.st_gid ) ) != NULL ) {
meta = add_meta_string( meta, L"group", grp->gr_name ); meta =
add_meta_string( frame_pointer, meta, L"group",
grp->gr_name );
} else { } else {
meta = add_meta_integer( meta, L"group", statbuf.st_gid ); meta =
add_meta_integer( frame_pointer, meta, L"group",
statbuf.st_gid );
} }
meta = meta =
add_meta_integer( meta, L"size", add_meta_integer( frame_pointer, meta, L"size",
( intmax_t ) statbuf.st_size ); ( intmax_t ) statbuf.st_size );
meta = add_meta_time( meta, L"modified", &statbuf.st_mtime ); meta =
add_meta_time( frame_pointer, meta, L"modified",
&statbuf.st_mtime );
} }
break; break;
case CFTYPE_CURL: case CFTYPE_CURL:
@ -595,75 +601,51 @@ struct pso_pointer lisp_open( struct pso_pointer frame_pointer,
struct pso_pointer env ) { struct pso_pointer env ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer result = nil; struct pso_pointer result = nil;
// if ( stringp( fetch_arg( frame, 0) ) ) { if ( stringp( fetch_arg( frame, 0 ) ) ) {
// char *url = lisp_string_to_c_string( fetch_arg( frame, 0) ); char *url = lisp_string_to_c_string( fetch_arg( frame, 0 ) );
// if ( c_nilp( fetch_arg( frame, 1) ) ) { if ( c_nilp( fetch_arg( frame, 1 ) ) ) {
// URL_FILE *stream = url_fopen( url, "r" ); URL_FILE *stream = url_fopen( url, "r" );
// debug_printf( DEBUG_IO, 0, debug_printf( DEBUG_IO, 0,
// L"lisp_open: stream @ %ld, stream type = %d, stream L"lisp_open: stream @ %ld, stream type = %d, stream handle = %ld\n",
// handle = %ld\n", ( long int ) &stream, ( int ) ( long int ) &stream, ( int ) stream->type,
// stream->type, ( long int ) stream->handle.file ); ( long int ) stream->handle.file );
// switch ( stream->type ) { switch ( stream->type ) {
// case CFTYPE_NONE: case CFTYPE_NONE:
// return return make_exception( make_frame( 1, frame_pointer,
// make_exception( c_string_to_lisp_string c_string_to_lisp_string
// ( L"Could not open stream" ), ( frame_pointer,
// frame_pointer , nil ); L"Could not open stream" ) ) );
// break; break;
// case CFTYPE_FILE: case CFTYPE_FILE:
// if ( stream->handle.file == NULL ) { if ( stream->handle.file == NULL ) {
// return return make_exception( make_frame( 1, frame_pointer,
// make_exception( c_string_to_lisp_string c_string_to_lisp_string
// ( L"Could not open file" ), ( frame_pointer,
// frame_pointer , nil); L"Could not open file" ) ) );
// } }
// break; break;
// case CFTYPE_CURL: case CFTYPE_CURL:
// /* can't tell whether a URL is bad without reading it */ /* can't tell whether a URL is bad without reading it */
// break; break;
// } }
// result = make_read_stream( stream, nil ); result = make_read_stream( frame_pointer, stream, nil );
// } else { } else {
// // TODO: anything more complex is a problem for another day. // TODO: anything more complex is a problem for another day.
// URL_FILE *stream = url_fopen( url, "w" ); URL_FILE *stream = url_fopen( url, "w" );
// result = make_write_stream( stream, nil ); result = make_write_stream( frame_pointer, stream, nil );
// } }
// if ( pointer_to_object( result )->payload.stream.stream == NULL ) { if ( pointer_to_object( result )->payload.stream.stream == NULL ) {
// result = nil; result = nil;
// } else { } else {
// collect_meta( result, url ); collect_meta( frame_pointer, result, url );
// } }
// free( url ); free( url );
// }
return result;
}
/**
* Function: return the next character from the stream indicated by arg 0;
* further arguments are ignored.
*
* * (read-char stream)
*
* @param frame my stack frame.
* @param frame_pointer a pointer to my stack frame.
* @param env my environment.
* @return a string of one character, namely the next available character
* on my stream, if any, else nil.
*/
struct pso_pointer lisp_read_char( struct pso_pointer frame_pointer,
struct pso_pointer env ) {
struct pso4 *frame = pointer_to_pso4( 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 );
} }
return result; return result;
} }
/** /**
* Function: return a string representing all characters from the stream * Function: return a string representing all characters from the stream
* indicated by arg 0; further arguments are ignored. * indicated by arg 0; further arguments are ignored.

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

@ -33,10 +33,14 @@ struct pso_pointer initialise_default_streams( struct pso_pointer
#define C_IO_IN L"*in*" #define C_IO_IN L"*in*"
#define C_IO_OUT L"*out*" #define C_IO_OUT L"*out*"
#define C_IO_LOG L"*log*" #define C_IO_LOG L"*log*"
#define C_IO_READBASE L"*read_base*"
#define C_IO_READTABLE L"*read_table*"
extern struct pso_pointer lisp_io_in; extern struct pso_pointer lisp_io_in;
extern struct pso_pointer lisp_io_out; extern struct pso_pointer lisp_io_out;
extern struct pso_pointer lisp_io_log; extern struct pso_pointer lisp_io_log;
extern struct pso_pointer lisp_io_readbase;
extern struct pso_pointer lisp_io_read_table;
extern struct pso_pointer lisp_stdin; extern struct pso_pointer lisp_stdin;
extern struct pso_pointer lisp_stdout; extern struct pso_pointer lisp_stdout;
@ -47,11 +51,12 @@ extern struct pso_pointer lisp_stderr;
extern struct pso_pointer lisp_io_prompt; extern struct pso_pointer lisp_io_prompt;
URL_FILE *file_to_url_file( FILE * f ); URL_FILE *file_to_url_file( FILE * f );
wint_t url_fgetwc( URL_FILE * input ); wint_t url_fgetwc( URL_FILE * input );
wint_t url_ungetwc( wint_t wc, URL_FILE * input ); wint_t url_ungetwc( wint_t wc, URL_FILE * input );
struct pso_pointer get_character( struct pso_pointer read_stream );
struct pso_pointer push_back_character( struct pso_pointer c, struct pso_pointer push_back_character( struct pso_pointer c,
struct pso_pointer r ); struct pso_pointer r );
@ -65,9 +70,6 @@ lisp_close( struct pso_pointer frame_pointer, struct pso_pointer env );
struct pso_pointer struct pso_pointer
lisp_open( struct pso_pointer frame_pointer, struct pso_pointer env ); lisp_open( struct pso_pointer frame_pointer, struct pso_pointer env );
struct pso_pointer struct pso_pointer
lisp_read_char( struct pso_pointer frame_pointer, struct pso_pointer env );
struct pso_pointer
lisp_slurp( struct pso_pointer frame_pointer, struct pso_pointer env ); lisp_slurp( struct pso_pointer frame_pointer, struct pso_pointer env );
char *lisp_string_to_c_string( struct pso_pointer s );
#endif #endif

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

@ -32,6 +32,7 @@
#include "memory/pso2.h" #include "memory/pso2.h"
#include "memory/tags.h" #include "memory/tags.h"
#include "payloads/exception.h"
#include "payloads/function.h" #include "payloads/function.h"
#include "payloads/integer.h" #include "payloads/integer.h"
#include "payloads/read_stream.h" #include "payloads/read_stream.h"
@ -73,12 +74,7 @@
* 1. The read table currently in use; * 1. The read table currently in use;
* 2. The character most recently read from that stream. * 2. The character most recently read from that stream.
*/ */
struct pso_pointer read_example( struct pso_pointer read_example( struct pso_pointer frame_pointer ) {
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer,
struct pso_pointer env ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer stream = fetch_arg( frame, 0 ); struct pso_pointer stream = fetch_arg( frame, 0 );
struct pso_pointer readtable = fetch_arg( frame, 1 ); struct pso_pointer readtable = fetch_arg( frame, 1 );
@ -88,6 +84,31 @@ struct pso_pointer read_example(
return result; return result;
} }
/**
* Function: return the next character from the stream indicated by arg 0;
* further arguments are ignored.
*
* * (read-char stream)
*
* @param frame my stack frame.
* @param frame_pointer a pointer to my stack frame.
* @param env my environment.
* @return a string of one character, namely the next available character
* on my stream, if any, else nil.
*/
struct pso_pointer read_character( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( 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 );
}
return result;
}
/** /**
* @brief Read one integer from the stream and return it. * @brief Read one integer from the stream and return it.
* *
@ -111,7 +132,8 @@ struct pso_pointer read_number( struct pso_pointer frame_pointer ) {
if ( readp( stream ) ) { if ( readp( stream ) ) {
if ( c_nilp( character ) ) { if ( c_nilp( character ) ) {
character = get_character( stream ); character =
read_character( make_frame( 1, frame_pointer, stream ) );
} }
char32_t c = c_nilp( character ) char32_t c = c_nilp( character )
? 0 : pointer_to_object( character )->payload.character.character; ? 0 : pointer_to_object( character )->payload.character.character;
@ -137,7 +159,8 @@ struct pso_pointer read_symbol( struct pso_pointer frame_pointer ) {
if ( readp( stream ) ) { if ( readp( stream ) ) {
if ( c_nilp( character ) ) { if ( c_nilp( character ) ) {
character = get_character( stream ); character =
read_character( make_frame( 1, frame_pointer, stream ) );
} }
char32_t c = c_nilp( character ) char32_t c = c_nilp( character )
@ -186,7 +209,7 @@ struct pso_pointer read( struct pso_pointer frame_pointer ) {
} }
if ( c_nilp( character ) ) { if ( c_nilp( character ) ) {
character = get_character( stream ); character = read_character( make_frame( 1, frame_pointer, stream ) );
} }
struct pso_pointer readmacro = c_assoc( character, readtable ); struct pso_pointer readmacro = c_assoc( character, readtable );
@ -205,12 +228,10 @@ struct pso_pointer read( struct pso_pointer frame_pointer ) {
/* skip all characters from semi-colon to the end of the line */ /* skip all characters from semi-colon to the end of the line */
break; break;
case EOF: case EOF:
// result = throw_exception( c_string_to_lisp_symbol( result = make_exception( make_frame( 1, frame_pointer,
// L"read" ), c_string_to_lisp_string
// c_string_to_lisp_string ( frame_pointer,
// ( L"End of input while L"Read: end of input while reading" ) ) );
// reading" ),
// frame_pointer );
break; break;
default: default:
struct pso_pointer next = make_frame( 3, frame_pointer, stream, struct pso_pointer next = make_frame( 3, frame_pointer, stream,

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

@ -13,6 +13,8 @@
#ifndef __psse_io_read_h #ifndef __psse_io_read_h
#define __psse_io_read_h #define __psse_io_read_h
struct pso_pointer read_character( struct pso_pointer frame_pointer );
struct pso_pointer read_number( struct pso_pointer frame_pointer ); struct pso_pointer read_number( struct pso_pointer frame_pointer );
struct pso_pointer read_symbol( struct pso_pointer frame_pointer ); struct pso_pointer read_symbol( struct pso_pointer frame_pointer );

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

@ -35,6 +35,26 @@
#include "ops/truth.h" #include "ops/truth.h"
/**
* @brief a means of creating a cons cell without using a stack frame, to
* prevent runaway recursion.
*
* @param car
* @param cdr
*
* return cons
*/
struct pso_pointer cheaty_make_cons( struct pso_pointer car,
struct pso_pointer cdr ) {
struct pso_pointer result = allocate( nil, CONSTAG, 2 );
struct pso2 *obj = pointer_to_object( result );
obj->payload.cons.car = car;
obj->payload.cons.cdr = cdr;
return result;
}
/** /**
* @brief Allocate an object of this `size_class` with this `tag`. * @brief Allocate an object of this `size_class` with this `tag`.
* *
@ -67,15 +87,18 @@ struct pso_pointer allocate( struct pso_pointer frame_pointer, char *tag,
struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso4 *frame = pointer_to_pso4( frame_pointer );
if ( !c_nilp( result ) ) { if ( !c_nilp( result ) ) {
strncpy( ( char * ) ( pointer_to_object( result )->header.tag. strncpy( ( char * ) ( pointer_to_object( result )->header.tag.bytes.
bytes.mnemonic ), tag, TAGLENGTH ); mnemonic ), tag, TAGLENGTH );
debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ", debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ",
result.page, result.offset ); result.page, result.offset );
if ( stackp( frame_pointer ) ) { if ( stackp( frame_pointer ) ) {
struct pso_pointer locals = make_cons( frame_pointer, result, // You can't make a stack frame in the middle of making a stack
frame->payload. // frame. Infinite recursion. So we have to cheat.
stack_frame.locals ); struct pso_pointer locals = cheaty_make_cons( result,
frame->
payload.stack_frame.
locals );
frame->payload.stack_frame.locals = locals; frame->payload.stack_frame.locals = locals;
} else if ( memory_initialised ) { } else if ( memory_initialised ) {

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

@ -48,7 +48,7 @@ struct pso2 {
struct stream_payload stream; struct stream_payload stream;
struct string_payload string; struct string_payload string;
// TODO: this isn't working and I don't know why (error: field ‘time’ has incomplete type) // TODO: this isn't working and I don't know why (error: field ‘time’ has incomplete type)
// struct time_payload time; struct time_payload time;
struct vectorp_payload vectorp; struct vectorp_payload vectorp;
} payload; } payload;
}; };

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

@ -1,5 +1,5 @@
/** /**
* memory/pso4.h * memory/pso4.c
* *
* Paged space object of size class 4, 16 words total, 14 words payload. * Paged space object of size class 4, 16 words total, 14 words payload.
* *
@ -11,5 +11,3 @@
#include "memory/pso.h" #include "memory/pso.h"
#include "memory/pso2.h" #include "memory/pso2.h"
#include "memory/pso4.h" #include "memory/pso4.h"
struct pso4 *pointer_to_pso4( struct pso_pointer p );

4
src/c/memory/pso4.h
View file

@ -13,6 +13,7 @@
#include <stdint.h> #include <stdint.h>
#include "memory/header.h" #include "memory/header.h"
#include "payloads/free.h" #include "payloads/free.h"
#include "payloads/stack.h" #include "payloads/stack.h"
@ -31,6 +32,7 @@ struct pso4 {
} payload; } payload;
}; };
struct pso4 *pointer_to_pso4( struct pso_pointer p ); // struct pso4 *pointer_to_pso4( struct pso_pointer p );
#define pointer_to_pso4(p)((struct pso4*)pointer_to_object(p))
#endif #endif

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

@ -108,8 +108,8 @@ struct pso_pointer assoc(
struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer key = fetch_arg( frame, 0 );
struct pso_pointer store = or( make_frame( 2, frame_pointer, struct pso_pointer store = or( make_frame( 2, frame_pointer,
fetch_arg( frame, 1 ), fetch_arg( frame, 1 ),
frame->payload. frame->payload.stack_frame.
stack_frame.env ) ); env ) );
return c_assoc( key, store ); return c_assoc( key, store );
} }
@ -130,8 +130,8 @@ struct pso_pointer interned(
struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer key = fetch_arg( frame, 0 );
struct pso_pointer store = or( make_frame( 2, frame_pointer, struct pso_pointer store = or( make_frame( 2, frame_pointer,
fetch_arg( frame, 1 ), fetch_arg( frame, 1 ),
frame->payload. frame->payload.stack_frame.
stack_frame.env ) ); env ) );
return c_interned( key, store ); return c_interned( key, store );
} }
@ -152,8 +152,8 @@ struct pso_pointer internedp(
struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer key = fetch_arg( frame, 0 );
struct pso_pointer store = or( make_frame( 2, frame_pointer, struct pso_pointer store = or( make_frame( 2, frame_pointer,
fetch_arg( frame, 1 ), fetch_arg( frame, 1 ),
frame->payload. frame->payload.stack_frame.
stack_frame.env ) ); env ) );
return c_internedp( key, store ) ? t : nil; return c_internedp( key, store ) ? t : nil;
} }

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

@ -41,7 +41,7 @@
* *
* @param dummy * @param dummy
*/ */
void int_handler( int dummy ) { void interrupt_handler( int dummy ) {
wprintf( L"TODO: handle ctrl-C in a more interesting way\n" ); wprintf( L"TODO: handle ctrl-C in a more interesting way\n" );
} }
@ -52,7 +52,7 @@ void repl( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso4 *frame = pointer_to_pso4( frame_pointer );
bool show_prompt = c_truep( fetch_arg( frame, 0 ) ); bool show_prompt = c_truep( fetch_arg( frame, 0 ) );
// todo: issue #21: must have stack frame passed in. // todo: issue #21: must have stack frame passed in.
signal( SIGINT, int_handler ); signal( SIGINT, interrupt_handler );
debug_print( L"Entered repl\n", DEBUG_REPL, 0 ); debug_print( L"Entered repl\n", DEBUG_REPL, 0 );
struct pso_pointer env = fetch_env( frame_pointer ); struct pso_pointer env = fetch_env( frame_pointer );

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

@ -8,7 +8,8 @@
*/ */
#include <stdint.h> #include <stdint.h>
#include <stdlib.h>
#include <string.h>
/* /*
* wide characters * wide characters
*/ */
@ -143,7 +144,7 @@ struct pso_pointer make_symbol( struct pso_pointer frame_pointer, wint_t c,
* Return a lisp string representation of this wide character string. * Return a lisp string representation of this wide character string.
*/ */
struct pso_pointer c_string_to_lisp_string( struct pso_pointer frame_pointer, struct pso_pointer c_string_to_lisp_string( struct pso_pointer frame_pointer,
char32_t *string ) { wchar_t *string ) {
struct pso_pointer result = nil; struct pso_pointer result = nil;
for ( int i = wcslen( string ) - 1; i >= 0; i-- ) { for ( int i = wcslen( string ) - 1; i >= 0; i-- ) {
@ -159,6 +160,53 @@ struct pso_pointer c_string_to_lisp_string( struct pso_pointer frame_pointer,
return result; return result;
} }
/**
* Convert this lisp string-like-thing (also works for symbols, and, later
* keywords) into a UTF-8 string. NOTE that the returned value has been
* malloced and must be freed. TODO: candidate to moving into a utilities
* file.
*
* @param s the lisp string or symbol;
* @return the c string.
*/
char *lisp_string_to_c_string( struct pso_pointer s ) {
char *result = NULL;
if ( stringp( s ) || symbolp( s ) ) {
int len = 1;
for ( struct pso_pointer c = s; !c_nilp( c ); c = c_cdr( c ) ) {
len++;
}
wchar_t *buffer = calloc( len, sizeof( char32_t ) );
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 );
}
mbstate_t ps;
const wchar_t *src = buffer;
memset( &ps, 0, sizeof( ps ) );
result =
calloc( wcsrtombs( NULL, &src, len, &ps ) + 1, sizeof( char ) );
src = buffer;
memset( &ps, 0, sizeof( ps ) );
wcsrtombs( result, &src, len, &ps );
free( buffer );
// mbstate_t ps = mbstate_t();
//
// result = calloc( wcsrtombs( NULL, &buffer, len, &ps) + 1 );
// wcsrtombs( result, &buffer, len, &ps);
// free( buffer );
}
debug_print( L"lisp_string_to_c_string( ", DEBUG_IO, 0 );
debug_print_object( s, DEBUG_IO, 0 );
debug_printf( DEBUG_IO, 0, L") => '%s'\n", result );
return result;
}
/** /**
* Return a lisp symbol representation of this wide character string. In * Return a lisp symbol representation of this wide character string. In

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

@ -31,7 +31,9 @@ struct pso_pointer make_symbol( struct pso_pointer frame_pointer, wint_t c,
struct pso_pointer tail ); struct pso_pointer tail );
struct pso_pointer c_string_to_lisp_string( struct pso_pointer frame_pointer, struct pso_pointer c_string_to_lisp_string( struct pso_pointer frame_pointer,
char32_t * string ); wchar_t *string );
char *lisp_string_to_c_string( struct pso_pointer s );
struct pso_pointer c_string_to_lisp_keyword( struct pso_pointer frame_pointer, struct pso_pointer c_string_to_lisp_keyword( struct pso_pointer frame_pointer,
char32_t * symbol ); char32_t * symbol );

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

@ -39,3 +39,8 @@ struct pso_pointer make_integer( struct pso_pointer frame_pointer,
return result; return result;
} }
struct pso_pointer acquire_integer( struct pso_pointer frame_pointer,
int64_t value ) {
return make_integer( frame_pointer, value );
}

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

@ -27,5 +27,7 @@ struct integer_payload {
struct pso_pointer make_integer( struct pso_pointer frame_pointer, struct pso_pointer make_integer( struct pso_pointer frame_pointer,
int64_t value ); int64_t value );
struct pso_pointer acquire_integer( struct pso_pointer frame_pointer,
int64_t value );
#endif #endif

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

@ -42,7 +42,6 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous,
va_list args; va_list args;
va_start( args, previous ); va_start( args, previous );
struct pso4 *prev_frame = pointer_to_pso4( previous );
struct pso_pointer new_pointer = allocate( previous, STACKTAG, 4 ); struct pso_pointer new_pointer = allocate( previous, STACKTAG, 4 );
struct pso4 *new_frame = pointer_to_pso4( new_pointer ); struct pso4 *new_frame = pointer_to_pso4( new_pointer );
@ -53,9 +52,9 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous,
arg_count, new_pointer.page, new_pointer.offset ); arg_count, new_pointer.page, new_pointer.offset );
#endif #endif
prev_frame->payload.stack_frame.previous = previous;
if ( stackp( previous ) ) { if ( stackp( previous ) ) {
struct pso4 *prev_frame = pointer_to_pso4( previous );
new_frame->payload.stack_frame.depth = new_frame->payload.stack_frame.depth =
prev_frame->payload.stack_frame.depth + 1; prev_frame->payload.stack_frame.depth + 1;
new_frame->payload.stack_frame.env = new_frame->payload.stack_frame.env =
@ -193,8 +192,8 @@ struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer
struct pso_pointer arg_length = struct pso_pointer arg_length =
length( make_frame( 1, previous, argvalues ) ); length( make_frame( 1, previous, argvalues ) );
int arg_count = int arg_count =
integerp( arg_length ) ? pointer_to_object( arg_length )-> integerp( arg_length ) ? pointer_to_object( arg_length )->payload.
payload.integer.value : 0; integer.value : 0;
#ifdef DEBUG #ifdef DEBUG
debug_printf( DEBUG_ALLOC, 0, debug_printf( DEBUG_ALLOC, 0,
L"\nAllocating stack frame with %d arguments at page %d, " L"\nAllocating stack frame with %d arguments at page %d, "
@ -252,8 +251,8 @@ struct pso_pointer make_frame_with_arglist( struct pso_pointer previous,
struct pso_pointer argvalues ) { struct pso_pointer argvalues ) {
return make_frame_with_arglist_and_env( previous, argvalues, return make_frame_with_arglist_and_env( previous, argvalues,
pointer_to_pso4 pointer_to_pso4
( previous )->payload.stack_frame. ( previous )->payload.
env ); stack_frame.env );
} }

57
src/c/payloads/time.c Normal file
View file

@ -0,0 +1,57 @@
/**
* payloads/time.c
*
* A time record.
*
* (c) 2026 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdlib.h>
#include <time.h>
#include "memory/tags.h"
#include "memory/pointer.h"
#include "memory/pso.h"
#include "memory/pso2.h"
#include "memory/tags.h"
#include "payloads/integer.h"
#include "payloads/stack.h"
#include "payloads/time.h"
#define _GNU_SOURCE
#define seconds_per_year 31557600L
/**
* PSSE Lisp epoch is 14 Bn years, or 441,806,400,000,000,000 seconds, before
* the UNIX epoch; the value in microseconds will break the C reader.
*/
unsigned __int128 epoch_offset =
( ( __int128 ) ( seconds_per_year * 1000000000L ) *
( __int128 ) ( 14L * 1000000000L ) );
unsigned __int128 unix_time_to_lisp_time( time_t t ) {
unsigned __int128 result = epoch_offset + ( t * 1000000000 );
return result;
}
struct pso_pointer make_time( struct pso_pointer frame_pointer,
struct pso_pointer specification ) {
struct pso_pointer result = allocate( frame_pointer, TIMETAG, 2 );
struct pso2 *cell = pointer_to_object( result );
if ( integerp( specification ) ) {
cell->payload.time.value =
pointer_to_object( specification )->payload.integer.value;
} else {
cell->payload.time.value = unix_time_to_lisp_time( time( NULL ) );
}
return result;
}

11
src/c/payloads/time.h
View file

@ -1,14 +1,14 @@
/** /**
* payloads/cons.h * payloads/time.h
* *
* A cons cell. * A timee record.
* *
* (c) 2026 Simon Brooke <simon@journeyman.cc> * (c) 2026 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version. * Licensed under GPL version 2.0, or, at your option, any later version.
*/ */
#ifndef __psse_payloads_cons_h #ifndef __psse_payloads_time_h
#define __psse_payloads_cons_h #define __psse_payloads_time_h
#include <ctype.h> #include <ctype.h>
#include <stdint.h> #include <stdint.h>
@ -31,4 +31,7 @@ struct time_payload {
unsigned __int128 value; unsigned __int128 value;
}; };
struct pso_pointer make_time( struct pso_pointer stack_frame,
struct pso_pointer time );
#endif #endif

12
src/c/psse.c
View file

@ -78,12 +78,6 @@ int main( int argc, char *argv[] ) {
bool show_prompt = false; bool show_prompt = false;
char *infilename = NULL; char *infilename = NULL;
setlocale( LC_ALL, "" );
if ( initialise_io( ) != 0 ) {
fputs( "Failed to initialise I/O subsystem\n", stderr );
exit( 1 );
}
while ( ( option = getopt( argc, argv, "dhi:ps:v:" ) ) != -1 ) { while ( ( option = getopt( argc, argv, "dhi:ps:v:" ) ) != -1 ) {
switch ( option ) { switch ( option ) {
case 'd': case 'd':
@ -114,6 +108,12 @@ int main( int argc, char *argv[] ) {
} }
} }
setlocale( LC_ALL, "" );
if ( initialise_io( ) != 0 ) {
fputs( "Failed to initialise I/O subsystem\n", stderr );
exit( 1 );
}
oblist = initialise_node( 0 ); oblist = initialise_node( 0 );
debug_print( L"Oblist: ", DEBUG_BOOTSTRAP, 0 ); debug_print( L"Oblist: ", DEBUG_BOOTSTRAP, 0 );
debug_print_object( oblist, DEBUG_BOOTSTRAP, 0 ); debug_print_object( oblist, DEBUG_BOOTSTRAP, 0 );