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

324
src/c/io/io.c
View file

@ -106,6 +106,16 @@ struct pso_pointer lisp_stderr;
*/
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
* 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.
*/
int initialise_io( ) {
fwide( stdin, 1 );
fwide( stdout, 1 );
fwide( stderr, 1 );
int result = curl_global_init( CURL_GLOBAL_SSL );
io_share = curl_share_init( );
@ -150,75 +164,100 @@ int initialise_io( ) {
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 ) {
// 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( stack_frame, C_IO_IN );
lisp_io_out = c_string_to_lisp_symbol( stack_frame, C_IO_OUT );
lisp_io_log = c_string_to_lisp_symbol( stack_frame, C_IO_LOG );
lisp_io_prompt = c_string_to_lisp_symbol( stack_frame, C_IO_PROMPT );
lisp_io_in = c_string_to_lisp_symbol( frame_pointer, C_IO_IN );
lisp_io_out = c_string_to_lisp_symbol( frame_pointer, C_IO_OUT );
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 =
c_string_to_lisp_symbol( frame_pointer, C_IO_READTABLE );
debug_print( L"In initialise_default_streams; environment is: ", DEBUG_IO,
0 );
debug_print_object( env, DEBUG_IO, 0 );
env =
lisp_bind( make_frame( 3, frame_pointer, lisp_io_prompt,
c_string_to_lisp_string( frame_pointer,
INITIAL_PROMPT ),
lisp_bind( make_frame
( 3, stack_frame, lisp_io_prompt,
c_string_to_lisp_string( stack_frame, INITIAL_PROMPT ),
env ) );
( 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 =
lock_object( make_read_stream
( stack_frame, file_to_url_file( stdin ),
make_cons( stack_frame,
make_cons( stack_frame,
( frame_pointer, file_to_url_file( stdin ),
make_cons( frame_pointer,
make_cons( frame_pointer,
c_string_to_lisp_keyword
( stack_frame, L"url" ),
( frame_pointer, L"url" ),
c_string_to_lisp_string
( stack_frame,
( frame_pointer,
L"::system:standard-input" ) ),
stack_frame ) ) );
frame_pointer ) ) );
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 );
if ( !c_nilp( env ) && !exceptionp( env ) ) {
lisp_stdout =
lock_object( make_write_stream( stack_frame,
lock_object( make_write_stream( frame_pointer,
file_to_url_file( stdout ),
make_cons( stack_frame,
make_cons( stack_frame,
make_cons( frame_pointer,
make_cons
( frame_pointer,
c_string_to_lisp_keyword
( stack_frame,
( frame_pointer,
L"url" ),
c_string_to_lisp_string
( stack_frame,
( frame_pointer,
L"::system:standard-output" ) ),
nil ) ) );
env =
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 ) ) {
lisp_stderr =
lock_object( make_write_stream
( stack_frame, file_to_url_file( stderr ),
make_cons( stack_frame,
make_cons( stack_frame,
( frame_pointer, file_to_url_file( stderr ),
make_cons( frame_pointer,
make_cons( frame_pointer,
c_string_to_lisp_keyword
( stack_frame, L"url" ),
( frame_pointer, L"url" ),
c_string_to_lisp_string
( stack_frame,
( frame_pointer,
L"::system:standard-output" ) ),
nil ) ) );
env =
lisp_bind( make_frame
( 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_IO, 0 );
@ -226,40 +265,6 @@ struct pso_pointer initialise_default_streams( struct pso_pointer stack_frame,
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.
@ -351,25 +356,6 @@ wint_t url_ungetwc( wint_t wc, URL_FILE *input ) {
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`.
@ -384,8 +370,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;
@ -412,8 +398,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;
}
@ -422,34 +408,43 @@ struct pso_pointer lisp_close( struct pso_pointer frame_pointer,
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 ) {
// todo: issue #21: must have stack frame passed in.
return
make_cons( make_cons
( c_string_to_lisp_keyword( key ), make_integer( value ) ),
return make_cons( frame_pointer,
make_cons( frame_pointer,
c_string_to_lisp_keyword( frame_pointer,
key ),
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 ) {
// 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( frame_pointer, key ),
c_string_to_lisp_string( buffer ) ), meta );
return make_cons( frame_pointer,
make_cons( frame_pointer,
c_string_to_lisp_keyword( frame_pointer,
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 ) {
// todo: issue #21: must have stack frame passed in.
char datestring[256];
strftime( datestring, sizeof( datestring ), nl_langinfo( D_T_FMT ),
localtime( value ) );
return add_meta_string( meta, key, datestring );
return make_cons( frame_pointer,
make_cons( frame_pointer,
c_string_to_lisp_keyword( frame_pointer,
key ),
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 );
}
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 );
URL_FILE *s = pointer_to_object( stream )->payload.stream.stream;
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 );
struct stat statbuf;
int result = stat( url, &statbuf );
@ -521,21 +517,31 @@ void collect_meta( struct pso_pointer stream, char *url ) {
case CFTYPE_FILE:
if ( result == 0 ) {
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 {
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 ) {
meta = add_meta_string( meta, L"group", grp->gr_name );
meta =
add_meta_string( frame_pointer, meta, L"group",
grp->gr_name );
} else {
meta = add_meta_integer( meta, L"group", statbuf.st_gid );
meta =
add_meta_integer( frame_pointer, meta, L"group",
statbuf.st_gid );
}
meta =
add_meta_integer( meta, L"size",
add_meta_integer( frame_pointer, meta, L"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;
case CFTYPE_CURL:
@ -595,75 +601,51 @@ struct pso_pointer lisp_open( struct pso_pointer frame_pointer,
struct pso_pointer env ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer result = nil;
// if ( stringp( fetch_arg( frame, 0) ) ) {
// char *url = lisp_string_to_c_string( fetch_arg( frame, 0) );
// if ( c_nilp( fetch_arg( frame, 1) ) ) {
// URL_FILE *stream = url_fopen( url, "r" );
// debug_printf( DEBUG_IO, 0,
// L"lisp_open: stream @ %ld, stream type = %d, stream
// handle = %ld\n", ( long int ) &stream, ( int )
// stream->type, ( long int ) stream->handle.file );
// switch ( stream->type ) {
// case CFTYPE_NONE:
// return
// make_exception( c_string_to_lisp_string
// ( L"Could not open stream" ),
// frame_pointer , nil );
// break;
// case CFTYPE_FILE:
// if ( stream->handle.file == NULL ) {
// return
// make_exception( c_string_to_lisp_string
// ( L"Could not open file" ),
// frame_pointer , nil);
// }
// break;
// case CFTYPE_CURL:
// /* can't tell whether a URL is bad without reading it */
// break;
// }
// result = make_read_stream( stream, nil );
// } else {
// // TODO: anything more complex is a problem for another day.
// URL_FILE *stream = url_fopen( url, "w" );
// result = make_write_stream( stream, nil );
// }
// if ( pointer_to_object( result )->payload.stream.stream == NULL ) {
// result = nil;
// } else {
// collect_meta( result, url );
// }
// free( url );
// }
return result;
if ( stringp( fetch_arg( frame, 0 ) ) ) {
char *url = lisp_string_to_c_string( fetch_arg( frame, 0 ) );
if ( c_nilp( fetch_arg( frame, 1 ) ) ) {
URL_FILE *stream = url_fopen( url, "r" );
debug_printf( DEBUG_IO, 0,
L"lisp_open: stream @ %ld, stream type = %d, stream handle = %ld\n",
( long int ) &stream, ( int ) stream->type,
( long int ) stream->handle.file );
switch ( stream->type ) {
case CFTYPE_NONE:
return make_exception( make_frame( 1, frame_pointer,
c_string_to_lisp_string
( frame_pointer,
L"Could not open stream" ) ) );
break;
case CFTYPE_FILE:
if ( stream->handle.file == NULL ) {
return make_exception( make_frame( 1, frame_pointer,
c_string_to_lisp_string
( frame_pointer,
L"Could not open file" ) ) );
}
/**
* 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 );
break;
case CFTYPE_CURL:
/* can't tell whether a URL is bad without reading it */
break;
}
result = make_read_stream( frame_pointer, stream, nil );
} else {
// TODO: anything more complex is a problem for another day.
URL_FILE *stream = url_fopen( url, "w" );
result = make_write_stream( frame_pointer, stream, nil );
}
if ( pointer_to_object( result )->payload.stream.stream == NULL ) {
result = nil;
} else {
collect_meta( frame_pointer, result, url );
}
free( url );
}
return result;
}
/**
* Function: return a string representing all characters from the stream
* 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_OUT L"*out*"
#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_out;
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_stdout;
@ -47,11 +51,12 @@ extern struct pso_pointer lisp_stderr;
extern struct pso_pointer lisp_io_prompt;
URL_FILE *file_to_url_file( FILE * f );
wint_t url_fgetwc( 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 r );
@ -65,9 +70,6 @@ lisp_close( struct pso_pointer frame_pointer, struct pso_pointer env );
struct pso_pointer
lisp_open( struct pso_pointer frame_pointer, struct pso_pointer env );
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 );
char *lisp_string_to_c_string( struct pso_pointer s );
#endif

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

@ -32,6 +32,7 @@
#include "memory/pso2.h"
#include "memory/tags.h"
#include "payloads/exception.h"
#include "payloads/function.h"
#include "payloads/integer.h"
#include "payloads/read_stream.h"
@ -73,12 +74,7 @@
* 1. The read table currently in use;
* 2. The character most recently read from that stream.
*/
struct pso_pointer read_example(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer,
struct pso_pointer env ) {
struct pso_pointer read_example( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer stream = fetch_arg( frame, 0 );
struct pso_pointer readtable = fetch_arg( frame, 1 );
@ -88,6 +84,31 @@ struct pso_pointer read_example(
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.
*
@ -111,7 +132,8 @@ struct pso_pointer read_number( struct pso_pointer frame_pointer ) {
if ( readp( stream ) ) {
if ( c_nilp( character ) ) {
character = get_character( stream );
character =
read_character( make_frame( 1, frame_pointer, stream ) );
}
char32_t c = c_nilp( 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 ( c_nilp( character ) ) {
character = get_character( stream );
character =
read_character( make_frame( 1, frame_pointer, stream ) );
}
char32_t c = c_nilp( character )
@ -186,7 +209,7 @@ struct pso_pointer read( struct pso_pointer frame_pointer ) {
}
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 );
@ -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 */
break;
case EOF:
// result = throw_exception( c_string_to_lisp_symbol(
// L"read" ),
// c_string_to_lisp_string
// ( L"End of input while
// reading" ),
// frame_pointer );
result = make_exception( make_frame( 1, frame_pointer,
c_string_to_lisp_string
( frame_pointer,
L"Read: end of input while reading" ) ) );
break;
default:
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
#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_symbol( struct pso_pointer frame_pointer );

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

@ -35,6 +35,26 @@
#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`.
*
@ -67,15 +87,18 @@ struct pso_pointer allocate( struct pso_pointer frame_pointer, char *tag,
struct pso4 *frame = pointer_to_pso4( frame_pointer );
if ( !c_nilp( result ) ) {
strncpy( ( char * ) ( pointer_to_object( result )->header.tag.
bytes.mnemonic ), tag, TAGLENGTH );
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 ( stackp( frame_pointer ) ) {
struct pso_pointer locals = make_cons( frame_pointer, result,
frame->payload.
stack_frame.locals );
// 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;
} else if ( memory_initialised ) {

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

@ -48,7 +48,7 @@ struct pso2 {
struct stream_payload stream;
struct string_payload string;
// 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;
} 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.
*
@ -11,5 +11,3 @@
#include "memory/pso.h"
#include "memory/pso2.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 "memory/header.h"
#include "payloads/free.h"
#include "payloads/stack.h"
@ -31,6 +32,7 @@ struct pso4 {
} 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

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 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 +130,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 +152,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;
}

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

@ -41,7 +41,7 @@
*
* @param dummy
*/
void int_handler( int dummy ) {
void interrupt_handler( int dummy ) {
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 );
bool show_prompt = c_truep( fetch_arg( frame, 0 ) );
// 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 );
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 <stdlib.h>
#include <string.h>
/*
* 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.
*/
struct pso_pointer c_string_to_lisp_string( struct pso_pointer frame_pointer,
char32_t *string ) {
wchar_t *string ) {
struct pso_pointer result = nil;
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;
}
/**
* 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

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 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,
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;
}
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,
int64_t value );
struct pso_pointer acquire_integer( struct pso_pointer frame_pointer,
int64_t value );
#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_start( args, previous );
struct pso4 *prev_frame = pointer_to_pso4( previous );
struct pso_pointer new_pointer = allocate( previous, STACKTAG, 4 );
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 );
#endif
prev_frame->payload.stack_frame.previous = previous;
if ( stackp( previous ) ) {
struct pso4 *prev_frame = pointer_to_pso4( previous );
new_frame->payload.stack_frame.depth =
prev_frame->payload.stack_frame.depth + 1;
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 =
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, "
@ -252,8 +251,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 );
}

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>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __psse_payloads_cons_h
#define __psse_payloads_cons_h
#ifndef __psse_payloads_time_h
#define __psse_payloads_time_h
#include <ctype.h>
#include <stdint.h>
@ -31,4 +31,7 @@ struct time_payload {
unsigned __int128 value;
};
struct pso_pointer make_time( struct pso_pointer stack_frame,
struct pso_pointer time );
#endif

12
src/c/psse.c
View file

@ -78,12 +78,6 @@ int main( int argc, char *argv[] ) {
bool show_prompt = false;
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 ) {
switch ( option ) {
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 );
debug_print( L"Oblist: ", DEBUG_BOOTSTRAP, 0 );
debug_print_object( oblist, DEBUG_BOOTSTRAP, 0 );