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

String-like-things are being created and printed correctly; bind is broken.

Browse source
This commit is contained in:
Simon Brooke 2026-04-17 18:40:32 +01:00
parent cf05e30540
commit ca5671f613
8 changed files with 508 additions and 450 deletions
Download patch file Download diff file Expand all files Collapse all files

7
src/c/environment/environment.c
View file

@ -36,7 +36,7 @@ bool environment_initialised = false;
* @brief Initialise a minimal environment, so that Lisp can be bootstrapped. * @brief Initialise a minimal environment, so that Lisp can be bootstrapped.
* *
* @param node the index of the node we are initialising. * @param node the index of the node we are initialising.
* @return struct pso_pointer t on success, else an exception. * @return a proto-environment on success, else an exception.
*/ */
struct pso_pointer initialise_environment( uint32_t node ) { struct pso_pointer initialise_environment( uint32_t node ) {
@ -85,9 +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_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_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 );
} }

1
src/c/environment/environment.h
View file

@ -10,6 +10,7 @@
#ifndef __psse_environment_environment_h #ifndef __psse_environment_environment_h
#define __psse_environment_environment_h #define __psse_environment_environment_h
#include <stdint.h>
struct pso_pointer initialise_environment( uint32_t node ); struct pso_pointer initialise_environment( uint32_t node );
#endif #endif

736
src/c/io/io.c
View file

@ -35,6 +35,7 @@
#include "memory/node.h" #include "memory/node.h"
#include "memory/pointer.h" #include "memory/pointer.h"
#include "memory/pso.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"
@ -86,14 +87,14 @@ 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;
} }
return result; return result;
} }
/** /**
@ -101,47 +102,54 @@ 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);
debug_print( L"In initialise_default_streams; environment is: ", DEBUG_IO, 0);
debug_print_object(env, DEBUG_IO, 0);
env = c_bind( lisp_io_in, env = c_bind(
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 ); env);
if ( !nilp( env ) && !exceptionp( env ) ) { debug_print_object(env, DEBUG_IO, 0);
env = c_bind( lisp_io_out, if (!nilp(env) && !exceptionp(env)) {
make_write_stream( file_to_url_file( stdout ), env = c_bind(lisp_io_out,
c_cons( c_cons lock_object(make_write_stream(
( c_string_to_lisp_keyword file_to_url_file(stdout),
( 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-output")),
nil ) ), env ); nil))),
} env);
}
return env; debug_print( L"Leaving initialise_default_streams; environment is: ", DEBUG_IO, 0);
debug_print_object(env, DEBUG_IO, 0);
return env;
} }
/** /**
@ -153,34 +161,34 @@ 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;
} }
/** /**
@ -189,94 +197,93 @@ 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 = char *cbuff = calloc(sizeof(wchar_t) + 2, sizeof(char));
calloc( sizeof( wchar_t ) + 2, sizeof( char ) ); wchar_t *wbuff = calloc(2, sizeof(wchar_t));
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_print(L"url_fgetwc: about to call url_fgets\n", DEBUG_IO, 0);
DEBUG_IO, 0 ); url_fgets(cbuff, 2, input);
url_fgets( cbuff, 2, input ); debug_print(L"url_fgetwc: back from url_fgets\n", DEBUG_IO, 0);
debug_print( L"url_fgetwc: back from url_fgets\n", int c = (int)cbuff[0];
DEBUG_IO, 0 ); // TODO: risk of reading off cbuff?
int c = ( int ) cbuff[0]; debug_printf(
// TODO: risk of reading off cbuff? DEBUG_IO, 0,
debug_printf( 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: *
* * 00 to 7F hex (0 to 127): first and only byte of a sequence.
* 00 to 7F hex (0 to 127): first and only byte of a sequence. * 80 to BF hex (128 to 191): continuing byte in a multi-byte
* 80 to BF hex (128 to 191): continuing byte in a multi-byte * sequence. C2 to DF hex (194 to 223): first byte of a two-byte
* sequence. C2 to DF hex (194 to 223): first byte of a two-byte * sequence. E0 to EF hex (224 to 239): first byte of a three-byte
* sequence. E0 to EF hex (224 to 239): first byte of a three-byte * 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, 2 ); //(char *)(&input->buffer[input->buffer_pos]), 1 ); mbstowcs(wbuff, cbuff,
result = wbuff[0]; 2); //(char *)(&input->buffer[input->buffer_pos]), 1 );
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:
break; break;
} }
} }
return result; return result;
} }
/** /**
@ -287,17 +294,16 @@ 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 = result = make_character(
make_character( url_fgetwc url_fgetwc(pointer_to_object_of_size_class(read_stream, 2)
( pointer_to_object_of_size_class( read_stream, 2 ) ->payload.stream.stream));
->payload.stream.stream ) ); }
}
return result; return result;
} }
/** /**
@ -308,20 +314,18 @@ 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( ( wint_t ) if (url_ungetwc(
( pointer_to_object( c )->payload.character. (wint_t)(pointer_to_object(c)->payload.character.character),
character ), pointer_to_object(r)->payload.stream.stream) >= 0) {
pointer_to_object( r )->payload.stream.stream ) >= result = t;
0 ) { }
result = t; }
} return result;
}
return result;
} }
/** /**
@ -336,191 +340,186 @@ 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;
} }
} }
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 return c_cons(c_cons(c_string_to_lisp_keyword(key), make_integer(value)),
c_cons( c_cons meta);
( 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 return c_cons(
c_cons( c_cons c_cons(c_string_to_lisp_keyword(key), c_string_to_lisp_string(buffer)),
( c_string_to_lisp_keyword( key ), meta);
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
/* make a copy of the string that we can destructively change */ /* make a copy of the string that we can destructively change */
// char *s = calloc( strlen( string ), sizeof( char ) ); // char *s = calloc( strlen( string ), sizeof( char ) );
// strcpy( s, string ); // strcpy( s, string );
// if ( check_tag( cell, READTV) || // if ( check_tag( cell, READTV) ||
// check_tag( cell, WRITETV) ) { // check_tag( cell, WRITETV) ) {
// int offset = index_of( ':', s ); // int offset = index_of( ':', s );
// if ( offset != -1 ) { // if ( offset != -1 ) {
// s[offset] = ( char ) 0; // s[offset] = ( char ) 0;
// char *name = trim( s ); // char *name = trim( s );
// char *value = trim( &s[++offset] ); // char *value = trim( &s[++offset] );
// wchar_t wname[strlen( name )]; // wchar_t wname[strlen( name )];
// mbstowcs( wname, name, strlen( name ) + 1 ); // mbstowcs( wname, name, strlen( name ) + 1 );
// cell->payload.stream.meta = // cell->payload.stream.meta =
// add_meta_string( cell->payload.stream.meta, wname, value ); // add_meta_string( cell->payload.stream.meta, wname, value );
// debug_printf( DEBUG_IO, // debug_printf( DEBUG_IO,
// L"write_meta_callback: added header '%s': value // L"write_meta_callback: added header '%s': value
// '%s'\n", name, value ); // '%s'\n", name, value );
// } else if ( strncmp( "HTTP", s, 4 ) == 0 ) { // } else if ( strncmp( "HTTP", s, 4 ) == 0 ) {
// int offset = index_of( ' ', s ); // int offset = index_of( ' ', s );
// char *value = trim( &s[offset] ); // char *value = trim( &s[offset] );
// cell->payload.stream.meta = // cell->payload.stream.meta =
// add_meta_integer( add_meta_string // add_meta_integer( add_meta_string
// ( cell->payload.stream.meta, L"status", // ( cell->payload.stream.meta, L"status",
// value ), L"status-code", strtol( value, // value ), L"status-code", strtol( value,
// NULL, // NULL,
// 10 ) ); // 10 ) );
// debug_printf( DEBUG_IO, // debug_printf( DEBUG_IO,
// L"write_meta_callback: added header 'status': value // L"write_meta_callback: added header 'status': value
// '%s'\n", value ); // '%s'\n", value );
// } else { // } else {
// debug_printf( DEBUG_IO, // debug_printf( DEBUG_IO,
// L"write_meta_callback: header passed with no colon: // L"write_meta_callback: header passed with no colon:
// '%s'\n", s ); // '%s'\n", s );
// } // }
// } else { // } else {
// debug_print // debug_print
// ( L"Pointer passed to write_meta_callback did not point to a // ( L"Pointer passed to write_meta_callback did not point to a
// stream: ", // stream: ",
// DEBUG_IO ); // DEBUG_IO );
// debug_dump_object( stream, DEBUG_IO ); // debug_dump_object( stream, DEBUG_IO );
// } // }
// free( s ); // free( s );
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 = meta = add_meta_integer(meta, L"size", (intmax_t)statbuf.st_size);
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;
} }
/* this is destructive change before the cell is released into the /* this is destructive change before the cell is released into the
* wild, and consequently permissible, just. */ * wild, and consequently permissible, just. */
cell->payload.stream.meta = meta; cell->payload.stream.meta = meta;
} }
/** /**
* 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;
} }
/** /**
* @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;
} }
return result; return result;
} }
/** /**
@ -538,59 +537,59 @@ 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) ) ) {
// char *url = lisp_string_to_c_string( fetch_arg( frame, 0) ); // char *url = lisp_string_to_c_string( fetch_arg( frame, 0) );
// if ( nilp( fetch_arg( frame, 1) ) ) { // if ( 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", ( long int ) &stream, ( int ) // handle = %ld\n", ( long int ) &stream, ( int )
// stream->type, ( long int ) stream->handle.file ); // stream->type, ( long int ) stream->handle.file );
// switch ( stream->type ) { // switch ( stream->type ) {
// case CFTYPE_NONE: // case CFTYPE_NONE:
// return // return
// make_exception( c_string_to_lisp_string // make_exception( c_string_to_lisp_string
// ( L"Could not open stream" ), // ( L"Could not open stream" ),
// frame_pointer , nil ); // frame_pointer , nil );
// break; // break;
// case CFTYPE_FILE: // case CFTYPE_FILE:
// if ( stream->handle.file == NULL ) { // if ( stream->handle.file == NULL ) {
// return // return
// make_exception( c_string_to_lisp_string // make_exception( c_string_to_lisp_string
// ( L"Could not open file" ), // ( L"Could not open file" ),
// frame_pointer , nil); // frame_pointer , nil);
// } // }
// 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( 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( 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( result, url );
// } // }
// free( url ); // free( url );
// } // }
return result; return result;
} }
/** /**
@ -605,19 +604,18 @@ 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 ) ), make_string(url_fgetwc(stream_get_url_file(stream_pointer)), nil);
nil ); }
}
return result; return result;
} }
/** /**
@ -634,29 +632,29 @@ 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;
} }
} }
return result; return result;
} }

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

@ -3,8 +3,8 @@
* *
* Post Scarcity Software Environment: print. * Post Scarcity Software Environment: print.
* *
* Print basic Lisp objects..This is :bootstrap layer print; it needs to be * Print basic Lisp objects..This is :bootstrap layer print; it needs to be
* able to print characters, symbols, integers, lists and dotted pairs. I * able to print characters, symbols, integers, lists and dotted pairs. I
* don't think it needs to be able to print anything else. * don't think it needs to be able to print anything else.
* *
* (c) 2026 Simon Brooke <simon@journeyman.cc> * (c) 2026 Simon Brooke <simon@journeyman.cc>
@ -12,6 +12,7 @@
*/ */
#include <ctype.h> #include <ctype.h>
#include <stdint.h>
#include <stdio.h> #include <stdio.h>
#include <stdlib.h> #include <stdlib.h>
#include <string.h> #include <string.h>
@ -36,93 +37,130 @@
#include "payloads/cons.h" #include "payloads/cons.h"
#include "payloads/integer.h" #include "payloads/integer.h"
struct pso_pointer in_print( struct pso_pointer p, URL_FILE * output ); #include "ops/truth.h"
struct pso_pointer print_list_content( struct pso_pointer p, URL_FILE *output ) { struct pso_pointer in_print(struct pso_pointer p, URL_FILE *output);
struct pso_pointer result = nil;
if ( consp( p ) ) { struct pso_pointer print_string_like_thing(struct pso_pointer p,
for ( ; consp( p ); p = c_cdr( p ) ) { URL_FILE *output) {
struct pso2 *object = pointer_to_object( p ); switch (get_tag_value(p)) {
case KEYTV:
url_fputwc(L':', output);
break;
case STRINGTV:
url_fputwc(L'"', output);
break;
}
result = in_print( object->payload.cons.car, output ); if (keywordp(p) || stringp(p) || symbolp(p)) {
for (struct pso_pointer cursor = p; !nilp(cursor);
cursor = pointer_to_object(cursor)->payload.string.cdr) {
url_fputwc(pointer_to_object(cursor)->payload.character.character,
output);
}
}
if ( exceptionp( result ) ) if (stringp(p)) {
break; url_fputwc(L'"', output);
}
switch ( get_tag_value( object->payload.cons.cdr ) ) {
case NILTV:
break;
case CONSTV:
url_fputwc( L' ', output );
break;
default:
url_fputws( L" . ", output );
result = in_print( object->payload.cons.cdr, output );
}
}
} else {
// TODO: return exception
}
return result;
} }
struct pso_pointer in_print( struct pso_pointer p, URL_FILE *output ) { struct pso_pointer print_list_content(struct pso_pointer p, URL_FILE *output) {
struct pso2 *object = pointer_to_object( p ); struct pso_pointer result = nil;
struct pso_pointer result = nil;
if ( object != NULL ) { if (consp(p)) {
switch ( get_tag_value( p ) ) { for (; consp(p); p = c_cdr(p)) {
case CHARACTERTV: struct pso2 *object = pointer_to_object(p);
url_fputwc( object->payload.character.character, output );
break;
case CONSTV:
url_fputwc( L'(', output );
result = print_list_content( p, output );
url_fputwc( L')', output );
break;
case INTEGERTV:
url_fwprintf( output, L"%d",
( int64_t ) ( object->payload.integer.value ) );
break;
case TRUETV:
url_fputwc( L't', output );
break;
case NILTV:
url_fputws( L"nil", output );
default:
// TODO: return exception
}
} else {
// TODO: return exception
}
return result; result = in_print(object->payload.cons.car, output);
if (exceptionp(result))
break;
switch (get_tag_value(object->payload.cons.cdr)) {
case NILTV:
break;
case CONSTV:
url_fputwc(L' ', output);
break;
default:
url_fputws(L" . ", output);
result = in_print(object->payload.cons.cdr, output);
}
}
} else {
// TODO: return exception
}
return result;
}
struct pso_pointer in_print(struct pso_pointer p, URL_FILE *output) {
struct pso2 *object = pointer_to_object(p);
struct pso_pointer result = nil;
if (object != NULL) {
uint32_t v = get_tag_value(p);
switch (v) {
case CHARACTERTV:
url_fputwc(object->payload.character.character, output);
break;
case CONSTV:
url_fputwc(L'(', output);
result = print_list_content(p, output);
url_fputwc(L')', output);
break;
case INTEGERTV:
url_fwprintf(output, L"%d",
(int64_t)(object->payload.integer.value));
break;
case KEYTV:
case STRINGTV:
case SYMBOLTV:
print_string_like_thing(p, output);
break;
case NILTV:
url_fputws(L"nil", output);
break;
case READTV:
case WRITETV:
url_fwprintf(output, L"<%s stream: ", v == READTV ? "read" : "write");
in_print(object->payload.stream.meta, output);
url_fputwc(L'>', output);
break;
case TRUETV:
url_fputwc(L't', output);
break;
default:
// TODO: return exception
}
} else {
// TODO: return exception
}
return result;
} }
/** /**
* @brief Simple print for bootstrap layer. * @brief Simple print for bootstrap layer.
* *
* @param p pointer to the object to print. * @param p pointer to the object to print.
* @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) {
URL_FILE *output = writep( stream ) ? struct pso_pointer result = p;
pointer_to_object( stream )->payload.stream.stream : URL_FILE *output = writep(stream)
file_to_url_file( stdout ); ? pointer_to_object(stream)->payload.stream.stream
: file_to_url_file(stdout);
if ( writep( stream ) ) { if (writep(stream)) {
inc_ref( stream ); inc_ref(stream);
}
struct pso_pointer result = in_print( p, output ); result = in_print(p, output);
if ( writep( stream ) ) { dec_ref(stream);
dec_ref( stream ); }
}
return result; return result;
} }

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

@ -13,6 +13,7 @@
#define __psse_memory_tags_h #define __psse_memory_tags_h
#include <stdbool.h> #include <stdbool.h>
#include <stdint.h>
#define TAGLENGTH 3 #define TAGLENGTH 3
@ -71,8 +72,8 @@
#define TRUETV 5591636 #define TRUETV 5591636
#define VECTORTV 4408662 #define VECTORTV 4408662
#define VECTORPOINTTV 5264214 #define VECTORPOINTTV 5264214
#define WRITETV 5264214 #define WRITETV 5526103
// 5526103
/** /**
* @brief return the numerical value of the tag of the object indicated by * @brief return the numerical value of the tag of the object indicated by
* pointer `p`. * pointer `p`.

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

@ -41,7 +41,7 @@ struct pso_pointer search( struct pso_pointer key,
if ( consp( store ) ) { if ( consp( store ) ) {
for ( struct pso_pointer cursor = store; for ( struct pso_pointer cursor = store;
consp( store ) && found == false; cursor = c_cdr( cursor ) ) { consp( cursor ) && found == false; cursor = c_cdr( cursor ) ) {
struct pso_pointer pair = c_car( cursor ); struct pso_pointer pair = c_car( cursor );
if ( consp( pair ) && c_equal( c_car( pair ), key ) ) { if ( consp( pair ) && c_equal( c_car( pair ), key ) ) {

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

@ -57,6 +57,15 @@ void c_repl( ) {
struct pso_pointer env = consp( oblist ) ? oblist : c_cons( oblist, nil ); struct pso_pointer env = consp( oblist ) ? oblist : c_cons( oblist, nil );
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)) {
debug_print(L"Invalid read stream: ", DEBUG_IO, 0);
debug_print_object(input_stream, DEBUG_IO, 0);
}
if (!writep(output_stream)) {
debug_print(L"Invalid write stream: ", DEBUG_IO, 0);
debug_print_object(output_stream, DEBUG_IO, 0);
}
while ( readp( input_stream ) while ( readp( input_stream )
&& !url_feof( stream_get_url_file( input_stream ) ) ) { && !url_feof( stream_get_url_file( input_stream ) ) ) {

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

@ -71,7 +71,7 @@ uint32_t calculate_hash( wint_t c, struct pso_pointer ptr ) {
*/ */
struct pso_pointer make_string_like_thing( wint_t c, struct pso_pointer tail, struct pso_pointer make_string_like_thing( wint_t c, struct pso_pointer tail,
char *tag ) { char *tag ) {
struct pso_pointer pointer = nil; struct pso_pointer pointer = tail;
if ( check_type( tail, tag ) || nilp( tail ) ) { if ( check_type( tail, tag ) || nilp( tail ) ) {
pointer = allocate( tag, CONS_SIZE_CLASS ); pointer = allocate( tag, CONS_SIZE_CLASS );
@ -81,8 +81,11 @@ struct pso_pointer make_string_like_thing( wint_t c, struct pso_pointer tail,
cell->payload.string.cdr = tail; cell->payload.string.cdr = tail;
cell->payload.string.hash = calculate_hash( c, tail ); cell->payload.string.hash = calculate_hash( c, tail );
debug_dump_object( pointer, DEBUG_ALLOC, 0 ); debug_printf( DEBUG_ALLOC, 0,
debug_println( DEBUG_ALLOC ); L"Building string-like-thing of type %3.3s: ",
cell->header.tag.bytes.mnemonic);
debug_print_object(pointer, DEBUG_ALLOC, 0);
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 );
@ -91,6 +94,7 @@ struct pso_pointer make_string_like_thing( wint_t c, struct pso_pointer tail,
tag, tobj->header.tag.bytes.mnemonic ); tag, tobj->header.tag.bytes.mnemonic );
} }
return pointer; return pointer;
} }
@ -138,9 +142,11 @@ struct pso_pointer c_string_to_lisp_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-- ) {
if ( iswprint( string[i] ) && string[i] != '"' ) { if ( string[i] != '"' ) {
result = make_string( string[i], result ); result = make_string( string[i], result );
} } else {
result = make_string( L'\\', make_string( string[i], result));
}
} }
return result; return result;
@ -157,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'-' ) { if ( iswalpha( c ) || c == L'-' || c == L'*') {
result = make_symbol( c, result ); result = make_symbol( c, result );
} }
} }