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

Hot damn! When you see an obvious, stupid bug you created, you can't unsee it!

Browse source
This commit is contained in:
Simon Brooke 2026-04-18 11:02:35 +01:00
parent ca5671f613
commit 02a4bc3e28
8 changed files with 563 additions and 495 deletions
Download patch file Download diff file Expand all files Collapse all files

9
src/c/environment/environment.c
View file

@ -85,13 +85,14 @@ struct pso_pointer initialise_environment( uint32_t node ) {
} }
if ( !exceptionp( result ) ) { if ( !exceptionp( result ) ) {
result = c_bind( c_string_to_lisp_symbol( L"nil" ), nil, nil ); result = c_bind( c_string_to_lisp_symbol( L"nil" ), nil, nil );
debug_print(L"Environment after binding `nil`: ", DEBUG_BOOTSTRAP, 0); debug_print( L"Environment after binding `nil`: ", DEBUG_BOOTSTRAP,
debug_print_object( result, DEBUG_BOOTSTRAP, 0); 0 );
debug_print_object( result, DEBUG_BOOTSTRAP, 0 );
result = c_bind( c_string_to_lisp_symbol( L"t" ), t, result ); result = c_bind( c_string_to_lisp_symbol( L"t" ), t, result );
environment_initialised = true; environment_initialised = true;
debug_print(L"Environment after binding `t`: ", DEBUG_BOOTSTRAP, 0); debug_print( L"Environment after binding `t`: ", DEBUG_BOOTSTRAP, 0 );
debug_print_object( result, DEBUG_BOOTSTRAP, 0); debug_print_object( result, DEBUG_BOOTSTRAP, 0 );
debug_print( L"\nEnvironment initialised successfully.\n", debug_print( L"\nEnvironment initialised successfully.\n",
DEBUG_BOOTSTRAP, 0 ); DEBUG_BOOTSTRAP, 0 );

389
src/c/io/io.c
View file

@ -70,11 +70,35 @@ CURLSH *io_share;
* @brief bound to the Lisp symbol representing C_IO_IN in initialisation. * @brief bound to the Lisp symbol representing C_IO_IN in initialisation.
*/ */
struct pso_pointer lisp_io_in; struct pso_pointer lisp_io_in;
/**
* nasty hack, do not use except in dire emergency: bound to the actual UN*X
* stdin at startup.
*/
struct pso_pointer lisp_stdin;
/** /**
* @brief bound to the Lisp symbol representing C_IO_OUT in initialisation. * @brief bound to the Lisp symbol representing C_IO_OUT in initialisation.
*/ */
struct pso_pointer lisp_io_out; struct pso_pointer lisp_io_out;
/**
* nasty hack, do not use except in dire emergency: bound to the actual UN*X
* stdout at startup.
*/
struct pso_pointer lisp_stdout;
/**
* @brief bound to the Lisp symbol representing C_IO_log in initialisation.
*/
struct pso_pointer lisp_io_log;
/**
* nasty hack, do not use except in dire emergency: bound to the actual UN*X
* stderr at startup.
*/
struct pso_pointer lisp_stderr;
/** /**
* 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.
@ -87,10 +111,10 @@ wint_t ungotten = 0;
* @param f the file to be wrapped; * @param f the file to be wrapped;
* @return the new handle, or null if no such handle could be allocated. * @return the new handle, or null if no such handle could be allocated.
*/ */
URL_FILE *file_to_url_file(FILE *f) { URL_FILE *file_to_url_file( FILE *f ) {
URL_FILE *result = (URL_FILE *)malloc(sizeof(URL_FILE)); URL_FILE *result = ( URL_FILE * ) malloc( sizeof( URL_FILE ) );
if (result != NULL) { if ( result != NULL ) {
result->type = CFTYPE_FILE, result->handle.file = f; result->type = CFTYPE_FILE, result->handle.file = f;
} }
@ -102,52 +126,73 @@ 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( ) {
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( );
if (result == 0) { if ( result == 0 ) {
curl_share_setopt(io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_CONNECT); curl_share_setopt( io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_CONNECT );
curl_share_setopt(io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_COOKIE); curl_share_setopt( io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_COOKIE );
curl_share_setopt(io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_DNS); curl_share_setopt( io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_DNS );
curl_share_setopt(io_share, CURLSHOPT_SHARE, curl_share_setopt( io_share, CURLSHOPT_SHARE,
CURL_LOCK_DATA_SSL_SESSION); CURL_LOCK_DATA_SSL_SESSION );
curl_share_setopt(io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_PSL); curl_share_setopt( io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_PSL );
} }
return result; return result;
} }
struct pso_pointer initialise_default_streams(struct pso_pointer env) { struct pso_pointer initialise_default_streams( struct pso_pointer env ) {
lisp_io_in = c_string_to_lisp_symbol(C_IO_IN); lisp_io_in = c_string_to_lisp_symbol( C_IO_IN );
lisp_io_out = c_string_to_lisp_symbol(C_IO_OUT); lisp_io_out = c_string_to_lisp_symbol( C_IO_OUT );
lisp_io_log = c_string_to_lisp_symbol( C_IO_LOG );
debug_print( L"In initialise_default_streams; environment is: ", DEBUG_IO, 0); debug_print( L"In initialise_default_streams; environment is: ", DEBUG_IO,
debug_print_object(env, DEBUG_IO, 0); 0 );
debug_print_object( env, DEBUG_IO, 0 );
env = c_bind( lisp_stdin = lock_object( make_read_stream( file_to_url_file( stdin ),
lisp_io_in, c_cons( c_cons
lock_object(make_read_stream( ( c_string_to_lisp_keyword
file_to_url_file(stdin), ( L"url" ),
c_cons(c_cons(c_string_to_lisp_keyword(L"url"), c_string_to_lisp_string
c_string_to_lisp_string(L"::system:standard-input")), ( L"::system:standard-input" ) ),
nil))), nil ) ) );
env);
debug_print_object(env, DEBUG_IO, 0); env = c_bind( lisp_io_in, lisp_stdin, env );
if (!nilp(env) && !exceptionp(env)) {
env = c_bind(lisp_io_out, debug_print_object( env, DEBUG_IO, 0 );
lock_object(make_write_stream(
file_to_url_file(stdout), if ( !nilp( env ) && !exceptionp( env ) ) {
c_cons(c_cons(c_string_to_lisp_keyword(L"url"), lisp_stdout =
c_string_to_lisp_string( lock_object( make_write_stream
L"::system:standard-output")), ( file_to_url_file( stdout ),
nil))), c_cons( c_cons
env); ( 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 );
} }
debug_print( L"Leaving initialise_default_streams; environment is: ", DEBUG_IO, 0); if ( !nilp( env ) && !exceptionp( env ) ) {
debug_print_object(env, DEBUG_IO, 0); lisp_stderr =
lock_object( make_write_stream
( file_to_url_file( stderr ),
c_cons( c_cons
( 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 );
}
debug_print( L"Leaving initialise_default_streams; environment is: ",
DEBUG_IO, 0 );
debug_print_object( env, DEBUG_IO, 0 );
return env; return env;
} }
@ -161,32 +206,32 @@ struct pso_pointer initialise_default_streams(struct pso_pointer env) {
* @param s the lisp string or symbol; * @param s the lisp string or symbol;
* @return the c string. * @return the c string.
*/ */
char *lisp_string_to_c_string(struct pso_pointer s) { char *lisp_string_to_c_string( struct pso_pointer s ) {
char *result = NULL; char *result = NULL;
if (stringp(s) || symbolp(s)) { if ( stringp( s ) || symbolp( s ) ) {
int len = 0; int len = 0;
for (struct pso_pointer c = s; !nilp(c); c = c_cdr(c)) { for ( struct pso_pointer c = s; !nilp( c ); c = c_cdr( c ) ) {
len++; len++;
} }
wchar_t *buffer = calloc(len + 1, sizeof(wchar_t)); wchar_t *buffer = calloc( len + 1, sizeof( wchar_t ) );
/* worst case, one wide char = four utf bytes */ /* worst case, one wide char = four utf bytes */
result = calloc((len * 4) + 1, sizeof(char)); result = calloc( ( len * 4 ) + 1, sizeof( char ) );
int i = 0; int i = 0;
for (struct pso_pointer c = s; !nilp(c); c = c_cdr(c)) { for ( struct pso_pointer c = s; !nilp( c ); c = c_cdr( c ) ) {
buffer[i++] = pointer_to_object(c)->payload.string.character; buffer[i++] = pointer_to_object( c )->payload.string.character;
} }
wcstombs(result, buffer, len); wcstombs( result, buffer, len );
free(buffer); free( buffer );
} }
debug_print(L"lisp_string_to_c_string( ", DEBUG_IO, 0); debug_print( L"lisp_string_to_c_string( ", DEBUG_IO, 0 );
debug_print_object(s, DEBUG_IO, 0); debug_print_object( s, DEBUG_IO, 0 );
debug_printf(DEBUG_IO, 0, L") => '%s'\n", result); debug_printf( DEBUG_IO, 0, L") => '%s'\n", result );
return result; return result;
} }
@ -197,35 +242,37 @@ char *lisp_string_to_c_string(struct pso_pointer s) {
* @param file the stream to read from; * @param file the stream to read from;
* @return the next wide character on the stream, or zero if no more. * @return the next wide character on the stream, or zero if no more.
*/ */
wint_t url_fgetwc(URL_FILE *input) { wint_t url_fgetwc( URL_FILE *input ) {
wint_t result = -1; wint_t result = -1;
if (ungotten != 0) { if ( ungotten != 0 ) {
/* TODO: not thread safe */ /* TODO: not thread safe */
result = ungotten; result = ungotten;
ungotten = 0; ungotten = 0;
} else { } else {
switch (input->type) { switch ( input->type ) {
case CFTYPE_FILE: case CFTYPE_FILE:
fwide(input->handle.file, 1); /* wide characters */ fwide( input->handle.file, 1 ); /* wide characters */
result = fgetwc(input->handle.file); /* passthrough */ result = fgetwc( input->handle.file ); /* passthrough */
break; break;
case CFTYPE_CURL: { case CFTYPE_CURL:{
char *cbuff = calloc(sizeof(wchar_t) + 2, sizeof(char)); char *cbuff =
wchar_t *wbuff = calloc(2, sizeof(wchar_t)); calloc( sizeof( wchar_t ) + 2, sizeof( char ) );
wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) );
size_t count = 0; size_t count = 0;
debug_print(L"url_fgetwc: about to call url_fgets\n", DEBUG_IO, 0); debug_print( L"url_fgetwc: about to call url_fgets\n",
url_fgets(cbuff, 2, input); DEBUG_IO, 0 );
debug_print(L"url_fgetwc: back from url_fgets\n", DEBUG_IO, 0); url_fgets( cbuff, 2, input );
int c = (int)cbuff[0]; debug_print( L"url_fgetwc: back from url_fgets\n",
DEBUG_IO, 0 );
int c = ( int ) cbuff[0];
// TODO: risk of reading off cbuff? // TODO: risk of reading off cbuff?
debug_printf( debug_printf( DEBUG_IO, 0,
DEBUG_IO, 0,
L"url_fgetwc: cbuff is '%s'; (first) character = %d (%c)\n", L"url_fgetwc: cbuff is '%s'; (first) character = %d (%c)\n",
cbuff, c, c & 0xf7); cbuff, c, c & 0xf7 );
/* The value of each individual byte indicates its UTF-8 function, /* The value of each individual byte indicates its UTF-8 function,
* as follows: * as follows:
* *
@ -236,46 +283,45 @@ wint_t url_fgetwc(URL_FILE *input) {
* sequence. F0 to FF hex (240 to 255): first byte of a four-byte * sequence. F0 to FF hex (240 to 255): first byte of a four-byte
* sequence. * sequence.
*/ */
if (c <= 0xf7) { if ( c <= 0xf7 ) {
count = 1; count = 1;
} else if (c >= 0xc2 && c <= 0xdf) { } else if ( c >= 0xc2 && c <= 0xdf ) {
count = 2; count = 2;
} else if (c >= 0xe0 && c <= 0xef) { } else if ( c >= 0xe0 && c <= 0xef ) {
count = 3; count = 3;
} else if (c >= 0xf0 && c <= 0xff) { } else if ( c >= 0xf0 && c <= 0xff ) {
count = 4; count = 4;
} }
if (count > 1) { if ( count > 1 ) {
url_fgets((char *)&cbuff[1], count, input); url_fgets( ( char * ) &cbuff[1], count, input );
} }
mbstowcs(wbuff, cbuff, mbstowcs( wbuff, cbuff, 2 ); //(char *)(&input->buffer[input->buffer_pos]), 1 );
2); //(char *)(&input->buffer[input->buffer_pos]), 1 );
result = wbuff[0]; result = wbuff[0];
free(wbuff); free( wbuff );
free(cbuff); free( cbuff );
} break; } break;
case CFTYPE_NONE: case CFTYPE_NONE:
break; break;
} }
} }
debug_printf(DEBUG_IO, 0, L"url_fgetwc returning %d (%C)\n", result, debug_printf( DEBUG_IO, 0, L"url_fgetwc returning %d (%C)\n", result,
result); result );
return result; return result;
} }
wint_t url_ungetwc(wint_t wc, URL_FILE *input) { wint_t url_ungetwc( wint_t wc, URL_FILE *input ) {
wint_t result = -1; wint_t result = -1;
switch (input->type) { switch ( input->type ) {
case CFTYPE_FILE: case CFTYPE_FILE:
fwide(input->handle.file, 1); /* wide characters */ fwide( input->handle.file, 1 ); /* wide characters */
result = ungetwc(wc, input->handle.file); /* passthrough */ result = ungetwc( wc, input->handle.file ); /* passthrough */
break; break;
case CFTYPE_CURL: { case CFTYPE_CURL:{
ungotten = wc; ungotten = wc;
break; break;
case CFTYPE_NONE: case CFTYPE_NONE:
@ -294,13 +340,14 @@ wint_t url_ungetwc(wint_t wc, URL_FILE *input) {
* *
* @return a pointer to a character object on success, or `nil` on failure. * @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 get_character( struct pso_pointer read_stream ) {
struct pso_pointer result = nil; struct pso_pointer result = nil;
if (readp(read_stream)) { if ( readp( read_stream ) ) {
result = make_character( result =
url_fgetwc(pointer_to_object_of_size_class(read_stream, 2) make_character( url_fgetwc
->payload.stream.stream)); ( pointer_to_object_of_size_class( read_stream, 2 )
->payload.stream.stream ) );
} }
return result; return result;
@ -314,14 +361,16 @@ struct pso_pointer get_character(struct pso_pointer read_stream) {
* *
* @return `t` on success, else `nil`. * @return `t` on success, else `nil`.
*/ */
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 ) {
struct pso_pointer result = nil; struct pso_pointer result = nil;
if (characterp(c) && readp(r)) { if ( characterp( c ) && readp( r ) ) {
if (url_ungetwc( if ( url_ungetwc( ( wint_t )
(wint_t)(pointer_to_object(c)->payload.character.character), ( pointer_to_object( c )->payload.character.
pointer_to_object(r)->payload.stream.stream) >= 0) { character ),
pointer_to_object( r )->payload.stream.stream ) >=
0 ) {
result = t; result = t;
} }
} }
@ -340,14 +389,14 @@ struct pso_pointer push_back_character(struct pso_pointer c,
* @param env my environment. * @param env my environment.
* @return T if the stream was successfully closed, else nil. * @return T if the stream was successfully closed, else nil.
*/ */
struct pso_pointer lisp_close(struct pso_pointer frame_pointer, struct pso_pointer lisp_close( 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 (readp(fetch_arg(frame, 0)) || writep(fetch_arg(frame, 0))) { if ( readp( fetch_arg( frame, 0 ) ) || writep( fetch_arg( frame, 0 ) ) ) {
if (url_fclose(pointer_to_object(fetch_arg(frame, 0)) if ( url_fclose( pointer_to_object( fetch_arg( frame, 0 ) )
->payload.stream.stream) == 0) { ->payload.stream.stream ) == 0 ) {
result = t; result = t;
} }
} }
@ -355,42 +404,45 @@ struct pso_pointer lisp_close(struct pso_pointer frame_pointer,
return result; return result;
} }
struct pso_pointer add_meta_integer(struct pso_pointer meta, wchar_t *key, struct pso_pointer add_meta_integer( struct pso_pointer meta, wchar_t *key,
long int value) { long int value ) {
return c_cons(c_cons(c_string_to_lisp_keyword(key), make_integer(value)), return
meta); c_cons( c_cons
( c_string_to_lisp_keyword( key ), make_integer( value ) ),
meta );
} }
struct pso_pointer add_meta_string(struct pso_pointer meta, wchar_t *key, struct pso_pointer add_meta_string( struct pso_pointer meta, wchar_t *key,
char *value) { char *value ) {
value = trim(value); value = trim( value );
wchar_t buffer[strlen(value) + 1]; wchar_t buffer[strlen( value ) + 1];
mbstowcs(buffer, value, strlen(value) + 1); mbstowcs( buffer, value, strlen( value ) + 1 );
return c_cons( return
c_cons(c_string_to_lisp_keyword(key), c_string_to_lisp_string(buffer)), c_cons( c_cons
meta); ( c_string_to_lisp_keyword( key ),
c_string_to_lisp_string( buffer ) ), meta );
} }
struct pso_pointer add_meta_time(struct pso_pointer meta, wchar_t *key, struct pso_pointer add_meta_time( struct pso_pointer meta, wchar_t *key,
time_t *value) { time_t *value ) {
/* I don't yet have a concept of a date-time object, which is a /* I don't yet have a concept of a date-time object, which is a
* bit of an oversight! */ * bit of an oversight! */
char datestring[256]; char datestring[256];
strftime(datestring, sizeof(datestring), nl_langinfo(D_T_FMT), strftime( datestring, sizeof( datestring ), nl_langinfo( D_T_FMT ),
localtime(value)); localtime( value ) );
return add_meta_string(meta, key, datestring); return add_meta_string( meta, key, datestring );
} }
/** /**
* Callback to assemble metadata for a URL stream. This is naughty because * Callback to assemble metadata for a URL stream. This is naughty because
* it modifies data, but it's really the only way to create metadata. * it modifies data, but it's really the only way to create metadata.
*/ */
static size_t write_meta_callback(char *string, size_t size, size_t nmemb, static size_t write_meta_callback( char *string, size_t size, size_t nmemb,
struct pso_pointer stream) { struct pso_pointer stream ) {
struct pso2 *cell = pointer_to_object(stream); struct pso2 *cell = pointer_to_object( stream );
// TODO: reimplement // TODO: reimplement
@ -448,43 +500,45 @@ 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 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", url); add_meta_string( cell->payload.stream.meta, L"url", url );
struct stat statbuf; struct stat statbuf;
int result = stat(url, &statbuf); int result = stat( url, &statbuf );
struct passwd *pwd; struct passwd *pwd;
struct group *grp; struct group *grp;
switch (s->type) { switch ( s->type ) {
case CFTYPE_NONE: case CFTYPE_NONE:
break; break;
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( meta, L"owner", pwd->pw_name );
} else { } else {
meta = add_meta_integer(meta, L"owner", statbuf.st_uid); meta = add_meta_integer( 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( meta, L"group", grp->gr_name );
} else { } else {
meta = add_meta_integer(meta, L"group", statbuf.st_gid); meta = add_meta_integer( meta, L"group", statbuf.st_gid );
} }
meta = add_meta_integer(meta, L"size", (intmax_t)statbuf.st_size); meta =
add_meta_integer( meta, L"size",
( intmax_t ) statbuf.st_size );
meta = add_meta_time(meta, L"modified", &statbuf.st_mtime); meta = add_meta_time( meta, L"modified", &statbuf.st_mtime );
} }
break; break;
case CFTYPE_CURL: case CFTYPE_CURL:
curl_easy_setopt(s->handle.curl, CURLOPT_VERBOSE, 1L); curl_easy_setopt( s->handle.curl, CURLOPT_VERBOSE, 1L );
curl_easy_setopt(s->handle.curl, CURLOPT_HEADERFUNCTION, curl_easy_setopt( s->handle.curl, CURLOPT_HEADERFUNCTION,
write_meta_callback); write_meta_callback );
curl_easy_setopt(s->handle.curl, CURLOPT_HEADERDATA, stream); curl_easy_setopt( s->handle.curl, CURLOPT_HEADERDATA, stream );
break; break;
} }
@ -497,11 +551,11 @@ void collect_meta(struct pso_pointer stream, char *url) {
* Resutn the current default input, or of `inputp` is false, output stream from * Resutn the current default input, or of `inputp` is false, output stream from
* this `env`ironment. * this `env`ironment.
*/ */
struct pso_pointer get_default_stream(bool inputp, struct pso_pointer env) { struct pso_pointer get_default_stream( bool inputp, struct pso_pointer env ) {
struct pso_pointer result = nil; struct pso_pointer result = nil;
struct pso_pointer stream_name = inputp ? lisp_io_in : lisp_io_out; struct pso_pointer stream_name = inputp ? lisp_io_in : lisp_io_out;
result = c_assoc(stream_name, env); result = c_assoc( stream_name, env );
return result; return result;
} }
@ -510,11 +564,11 @@ struct pso_pointer get_default_stream(bool inputp, struct pso_pointer env) {
* @brief if `s` points to either an input or an output stream, return the * @brief if `s` points to either an input or an output stream, return the
* URL_FILE pointer underlying that stream, else NULL. * URL_FILE pointer underlying that stream, else NULL.
*/ */
URL_FILE *stream_get_url_file(struct pso_pointer s) { URL_FILE *stream_get_url_file( struct pso_pointer s ) {
URL_FILE *result = NULL; URL_FILE *result = NULL;
if (readp(s) || writep(s)) { if ( readp( s ) || writep( s ) ) {
struct pso2 *obj = pointer_to_object(s); struct pso2 *obj = pointer_to_object( s );
result = obj->payload.stream.stream; result = obj->payload.stream.stream;
} }
@ -537,9 +591,9 @@ URL_FILE *stream_get_url_file(struct pso_pointer s) {
* @return a string of one character, namely the next available character * @return a string of one character, namely the next available character
* on my stream, if any, else nil. * on my stream, if any, else nil.
*/ */
struct pso_pointer lisp_open(struct pso_pointer frame_pointer, 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) ) ) {
@ -604,15 +658,16 @@ struct pso_pointer lisp_open(struct pso_pointer frame_pointer,
* @return a string of one character, namely the next available character * @return a string of one character, namely the next available character
* on my stream, if any, else nil. * on my stream, if any, else nil.
*/ */
struct pso_pointer lisp_read_char(struct pso_pointer frame_pointer, struct pso_pointer lisp_read_char( 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;
struct pso_pointer stream_pointer = fetch_arg(frame, 0); struct pso_pointer stream_pointer = fetch_arg( frame, 0 );
if (readp(stream_pointer)) { if ( readp( stream_pointer ) ) {
result = result =
make_string(url_fgetwc(stream_get_url_file(stream_pointer)), nil); make_string( url_fgetwc( stream_get_url_file( stream_pointer ) ),
nil );
} }
return result; return result;
@ -632,26 +687,26 @@ struct pso_pointer lisp_read_char(struct pso_pointer frame_pointer,
* @return a string of one character, namely the next available character * @return a string of one character, namely the next available character
* on my stream, if any, else nil. * on my stream, if any, else nil.
*/ */
struct pso_pointer lisp_slurp(struct pso_pointer frame_pointer, struct pso_pointer lisp_slurp( 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 (readp(fetch_arg(frame, 0))) { if ( readp( fetch_arg( frame, 0 ) ) ) {
URL_FILE *stream = stream_get_url_file(fetch_arg(frame, 0)); URL_FILE *stream = stream_get_url_file( fetch_arg( frame, 0 ) );
struct pso_pointer cursor = make_string(url_fgetwc(stream), nil); struct pso_pointer cursor = make_string( url_fgetwc( stream ), nil );
result = cursor; result = cursor;
for (wint_t c = url_fgetwc(stream); !url_feof(stream) && c != 0; for ( wint_t c = url_fgetwc( stream ); !url_feof( stream ) && c != 0;
c = url_fgetwc(stream)) { c = url_fgetwc( stream ) ) {
debug_print(L"slurp: cursor is: ", DEBUG_IO, 0); debug_print( L"slurp: cursor is: ", DEBUG_IO, 0 );
debug_dump_object(cursor, DEBUG_IO, 0); debug_dump_object( cursor, DEBUG_IO, 0 );
debug_print(L"; result is: ", DEBUG_IO, 0); debug_print( L"; result is: ", DEBUG_IO, 0 );
debug_dump_object(result, DEBUG_IO, 0); debug_dump_object( result, DEBUG_IO, 0 );
debug_println(DEBUG_IO); debug_println( DEBUG_IO );
struct pso2 *cell = pointer_to_object(cursor); struct pso2 *cell = pointer_to_object( cursor );
cursor = make_string((wchar_t)c, nil); cursor = make_string( ( wchar_t ) c, nil );
cell->payload.string.cdr = cursor; cell->payload.string.cdr = cursor;
} }
} }

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

@ -23,9 +23,15 @@ 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_OUT L"*out*"
#define C_IO_LOG L"*log*"
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_stdin;
extern struct pso_pointer lisp_stdout;
extern struct pso_pointer lisp_stderr;
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 );

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

@ -39,53 +39,53 @@
#include "ops/truth.h" #include "ops/truth.h"
struct pso_pointer in_print(struct pso_pointer p, URL_FILE *output); struct pso_pointer in_print( struct pso_pointer p, URL_FILE * output );
struct pso_pointer print_string_like_thing(struct pso_pointer p, struct pso_pointer print_string_like_thing( struct pso_pointer p,
URL_FILE *output) { URL_FILE *output ) {
switch (get_tag_value(p)) { switch ( get_tag_value( p ) ) {
case KEYTV: case KEYTV:
url_fputwc(L':', output); url_fputwc( L':', output );
break; break;
case STRINGTV: case STRINGTV:
url_fputwc(L'"', output); url_fputwc( L'"', output );
break; break;
} }
if (keywordp(p) || stringp(p) || symbolp(p)) { if ( keywordp( p ) || stringp( p ) || symbolp( p ) ) {
for (struct pso_pointer cursor = p; !nilp(cursor); for ( struct pso_pointer cursor = p; !nilp( cursor );
cursor = pointer_to_object(cursor)->payload.string.cdr) { cursor = pointer_to_object( cursor )->payload.string.cdr ) {
url_fputwc(pointer_to_object(cursor)->payload.character.character, url_fputwc( pointer_to_object( cursor )->payload.character.
output); character, output );
} }
} }
if (stringp(p)) { if ( stringp( p ) ) {
url_fputwc(L'"', output); url_fputwc( L'"', output );
} }
} }
struct pso_pointer print_list_content(struct pso_pointer p, URL_FILE *output) { struct pso_pointer print_list_content( struct pso_pointer p, URL_FILE *output ) {
struct pso_pointer result = nil; struct pso_pointer result = nil;
if (consp(p)) { if ( consp( p ) ) {
for (; consp(p); p = c_cdr(p)) { for ( ; consp( p ); p = c_cdr( p ) ) {
struct pso2 *object = pointer_to_object(p); struct pso2 *object = pointer_to_object( p );
result = in_print(object->payload.cons.car, output); result = in_print( object->payload.cons.car, output );
if (exceptionp(result)) if ( exceptionp( result ) )
break; break;
switch (get_tag_value(object->payload.cons.cdr)) { switch ( get_tag_value( object->payload.cons.cdr ) ) {
case NILTV: case NILTV:
break; break;
case CONSTV: case CONSTV:
url_fputwc(L' ', output); url_fputwc( L' ', output );
break; break;
default: default:
url_fputws(L" . ", output); url_fputws( L" . ", output );
result = in_print(object->payload.cons.cdr, output); result = in_print( object->payload.cons.cdr, output );
} }
} }
} else { } else {
@ -95,41 +95,42 @@ struct pso_pointer print_list_content(struct pso_pointer p, URL_FILE *output) {
return result; return result;
} }
struct pso_pointer in_print(struct pso_pointer p, URL_FILE *output) { struct pso_pointer in_print( struct pso_pointer p, URL_FILE *output ) {
struct pso2 *object = pointer_to_object(p); struct pso2 *object = pointer_to_object( p );
struct pso_pointer result = nil; struct pso_pointer result = nil;
if (object != NULL) { if ( object != NULL ) {
uint32_t v = get_tag_value(p); uint32_t v = get_tag_value( p );
switch (v) { switch ( v ) {
case CHARACTERTV: case CHARACTERTV:
url_fputwc(object->payload.character.character, output); url_fputwc( object->payload.character.character, output );
break; break;
case CONSTV: case CONSTV:
url_fputwc(L'(', output); url_fputwc( L'(', output );
result = print_list_content(p, output); result = print_list_content( p, output );
url_fputwc(L')', output); url_fputwc( L')', output );
break; break;
case INTEGERTV: case INTEGERTV:
url_fwprintf(output, L"%d", url_fwprintf( output, L"%d",
(int64_t)(object->payload.integer.value)); ( int64_t ) ( object->payload.integer.value ) );
break; break;
case KEYTV: case KEYTV:
case STRINGTV: case STRINGTV:
case SYMBOLTV: case SYMBOLTV:
print_string_like_thing(p, output); print_string_like_thing( p, output );
break; break;
case NILTV: case NILTV:
url_fputws(L"nil", output); url_fputws( L"nil", output );
break; break;
case READTV: case READTV:
case WRITETV: case WRITETV:
url_fwprintf(output, L"<%s stream: ", v == READTV ? "read" : "write"); url_fwprintf( output, L"<%s stream: ",
in_print(object->payload.stream.meta, output); v == READTV ? "read" : "write" );
url_fputwc(L'>', output); in_print( object->payload.stream.meta, output );
url_fputwc( L'>', output );
break; break;
case TRUETV: case TRUETV:
url_fputwc(L't', output); url_fputwc( L't', output );
break; break;
default: default:
// TODO: return exception // TODO: return exception
@ -148,18 +149,18 @@ struct pso_pointer in_print(struct pso_pointer p, URL_FILE *output) {
* @param stream if a pointer to an open write stream, print to there. * @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. * @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) { struct pso_pointer c_print( struct pso_pointer p, struct pso_pointer stream ) {
struct pso_pointer result = p; struct pso_pointer result = p;
URL_FILE *output = writep(stream) URL_FILE *output = writep( stream )
? pointer_to_object(stream)->payload.stream.stream ? pointer_to_object( stream )->payload.stream.stream
: file_to_url_file(stdout); : file_to_url_file( stdout );
if (writep(stream)) { if ( writep( stream ) ) {
inc_ref(stream); inc_ref( stream );
result = in_print(p, output); result = in_print( p, output );
dec_ref(stream); dec_ref( stream );
} }
return result; return result;

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

@ -24,9 +24,6 @@
#include "memory/pointer.h" #include "memory/pointer.h"
#include "memory/pso.h" #include "memory/pso.h"
#include "memory/pso2.h" #include "memory/pso2.h"
#include "memory/pso2.h"
#include "memory/pso2.h"
#include "memory/pso2.h"
#include "memory/pso4.h" #include "memory/pso4.h"
#include "memory/tags.h" #include "memory/tags.h"
@ -58,17 +55,19 @@ void c_repl( ) {
struct pso_pointer input_stream = c_assoc( lisp_io_in, env ); struct pso_pointer input_stream = c_assoc( lisp_io_in, env );
struct pso_pointer output_stream = c_assoc( lisp_io_out, env ); struct pso_pointer output_stream = c_assoc( lisp_io_out, env );
if (!readp(input_stream)) { if ( !readp( input_stream ) ) {
debug_print(L"Invalid read stream: ", DEBUG_IO, 0); debug_print( L"Invalid read stream: ", DEBUG_IO, 0 );
debug_print_object(input_stream, DEBUG_IO, 0); debug_print_object( input_stream, DEBUG_IO, 0 );
input_stream = lisp_stdin;
} }
if (!writep(output_stream)) { if ( !writep( output_stream ) ) {
debug_print(L"Invalid write stream: ", DEBUG_IO, 0); debug_print( L"Invalid write stream: ", DEBUG_IO, 0 );
debug_print_object(output_stream, DEBUG_IO, 0); debug_print_object( output_stream, DEBUG_IO, 0 );
output_stream = lisp_stdout;
} }
while ( readp( input_stream ) while ( readp( input_stream ) &&
&& !url_feof( stream_get_url_file( input_stream ) ) ) { !url_feof( stream_get_url_file( input_stream ) ) ) {
/* bottom of stack */ /* bottom of stack */
struct pso_pointer frame_pointer = make_frame( 1, nil, input_stream ); struct pso_pointer frame_pointer = make_frame( 1, nil, input_stream );

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

@ -83,9 +83,9 @@ struct pso_pointer make_string_like_thing( wint_t c, struct pso_pointer tail,
cell->payload.string.hash = calculate_hash( c, tail ); cell->payload.string.hash = calculate_hash( c, tail );
debug_printf( DEBUG_ALLOC, 0, debug_printf( DEBUG_ALLOC, 0,
L"Building string-like-thing of type %3.3s: ", L"Building string-like-thing of type %3.3s: ",
cell->header.tag.bytes.mnemonic); cell->header.tag.bytes.mnemonic );
debug_print_object(pointer, DEBUG_ALLOC, 0); debug_print_object( pointer, DEBUG_ALLOC, 0 );
debug_println(DEBUG_ALLOC); debug_println( DEBUG_ALLOC );
} else { } else {
// \todo should throw an exception! // \todo should throw an exception!
struct pso2 *tobj = pointer_to_object( tail ); struct pso2 *tobj = pointer_to_object( tail );
@ -145,7 +145,7 @@ struct pso_pointer c_string_to_lisp_string( wchar_t *string ) {
if ( string[i] != '"' ) { if ( string[i] != '"' ) {
result = make_string( string[i], result ); result = make_string( string[i], result );
} else { } else {
result = make_string( L'\\', make_string( string[i], result)); result = make_string( L'\\', make_string( string[i], result ) );
} }
} }
@ -163,7 +163,7 @@ struct pso_pointer c_string_to_lisp_symbol( wchar_t *symbol ) {
for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) { for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) {
wchar_t c = towlower( symbol[i] ); wchar_t c = towlower( symbol[i] );
if ( iswalpha( c ) || c == L'-' || c == L'*') { if ( iswalpha( c ) || c == L'-' || c == L'*' ) {
result = make_symbol( c, result ); result = make_symbol( c, result );
} }
} }

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

@ -69,7 +69,7 @@ struct pso_pointer c_car( struct pso_pointer cons ) {
*/ */
struct pso_pointer c_cdr( struct pso_pointer p ) { struct pso_pointer c_cdr( struct pso_pointer p ) {
struct pso_pointer result = nil; struct pso_pointer result = nil;
struct pso2 *object = pointer_to_object( result ); struct pso2 *object = pointer_to_object( p );
switch ( get_tag_value( p ) ) { switch ( get_tag_value( p ) ) {
case CONSTV: case CONSTV:

14
src/c/psse.c
View file

@ -12,21 +12,23 @@
* 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.
*/ */
#include <signal.h>
#include <stdbool.h> #include <stdbool.h>
#include <stdio.h> #include <stdio.h>
#include <wchar.h> #include <wchar.h>
#include <signal.h>
#include "debug.h" #include "debug.h"
#include "psse.h"
#include "io/io.h" #include "io/io.h"
#include "psse.h"
#include "io/print.h"
#include "memory/node.h" #include "memory/node.h"
#include "memory/pso.h" #include "memory/pso.h"
#include "memory/tags.h" #include "memory/tags.h"
#include "ops/repl.h" #include "ops/repl.h"
#include "ops/stack_ops.h" #include "ops/stack_ops.h"
#include "ops/string_ops.h"
#include "ops/truth.h" #include "ops/truth.h"
#include "payloads/cons.h" #include "payloads/cons.h"
@ -67,7 +69,6 @@ void print_options( FILE *stream ) {
#endif #endif
} }
/** /**
* main entry point; parse command line arguments, initialise the environment, * main entry point; parse command line arguments, initialise the environment,
* and enter the read-eval-print loop. * and enter the read-eval-print loop.
@ -124,7 +125,12 @@ int main( int argc, char *argv[] ) {
exit( 1 ); exit( 1 );
} }
c_repl( ); c_print( c_cons( c_string_to_lisp_keyword( L"a" ),
( c_cons( c_string_to_lisp_keyword( L"b" ),
c_cons( c_string_to_lisp_keyword( L"c" ),
nil ) ) ) ), lisp_stdout );
// c_repl();
exit( 0 ); exit( 0 );
} }