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

Compiles again, now with bootstrap-layer print implemented, but not yet tested.

Browse source 
To get print implemented, I also had to implement a lot of other things.
This commit is contained in:
Simon Brooke 2026-03-31 15:05:44 +01:00
parent 2b22780ccf
commit 364d7d2c7b
23 changed files with 1616 additions and 57 deletions
Download patch file Download diff file Expand all files Collapse all files

8
src/c/debug.c
View file

@ -45,6 +45,14 @@ void debug_print( wchar_t *message, int level, int indent ) {
#endif
}
void debug_print_object( struct pso_pointer object, int level, int indent ) {
// TODO: not yet implemented
}
void debug_dump_object( struct pso_pointer object, int level, int indent ) {
// TODO: not yet implemented
}
/**
* @brief print a 128 bit integer value to stderr, if `verbosity` matches `level`.
*

6
src/c/debug.h
View file

@ -23,6 +23,8 @@
#include <wchar.h>
#include <wctype.h>
#include "memory/pointer.h"
/**
* @brief Print messages debugging memory allocation.
*
@ -102,6 +104,10 @@ extern int verbosity;
void debug_print( wchar_t *message, int level, int indent );
void debug_print_object( struct pso_pointer object, int level, int indent );
void debug_dump_object( struct pso_pointer object, int level, int indent );
void debug_print_128bit( __int128_t n, int level );
void debug_println( int level );

526
src/c/io/fopen.c Normal file
View file

@ -0,0 +1,526 @@
/*
* fopen.c
*
* adapted from https://curl.haxx.se/libcurl/c/fopen.html.
*
* Modifications to read/write wide character streams by
* Simon Brooke.
*
* NOTE THAT: for my purposes, I'm only interested in wide characters,
* and I always read them one character at a time.
*
* Copyright (c) 2003, 2017 Simtec Electronics
* Some portions (c) 2019 Simon Brooke <simon@journeyman.cc>
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
* 3. The name of the author may not be used to endorse or promote products
* derived from this software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
* IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
* OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
* IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
* NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
* DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
* THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
* THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
* This example requires libcurl 7.9.7 or later.
*/
#include <stdio.h>
#include <string.h>
#ifndef WIN32
#include <sys/time.h>
#endif
#include <stdlib.h>
#include <errno.h>
#include <curl/curl.h>
#include "io/fopen.h"
#ifdef FOPEN_STANDALONE
CURLSH *io_share;
#else
#include "memory/pso2.h"
#include "io/io.h"
#include "utils.h"
#endif
/* exported functions */
URL_FILE *url_fopen( const char *url, const char *operation );
int url_fclose( URL_FILE * file );
int url_feof( URL_FILE * file );
size_t url_fread( void *ptr, size_t size, size_t nmemb, URL_FILE * file );
char *url_fgets( char *ptr, size_t size, URL_FILE * file );
void url_rewind( URL_FILE * file );
/* we use a global one for convenience */
static CURLM *multi_handle;
/* curl calls this routine to get more data */
static size_t write_callback( char *buffer,
size_t size, size_t nitems, void *userp ) {
char *newbuff;
size_t rembuff;
URL_FILE *url = ( URL_FILE * ) userp;
size *= nitems;
rembuff = url->buffer_len - url->buffer_pos; /* remaining space in buffer */
if ( size > rembuff ) {
/* not enough space in buffer */
newbuff = realloc( url->buffer, url->buffer_len + ( size - rembuff ) );
if ( newbuff == NULL ) {
fprintf( stderr, "callback buffer grow failed\n" );
size = rembuff;
} else {
/* realloc succeeded increase buffer size */
url->buffer_len += size - rembuff;
url->buffer = newbuff;
}
}
memcpy( &url->buffer[url->buffer_pos], buffer, size );
url->buffer_pos += size;
return size;
}
/* use to attempt to fill the read buffer up to requested number of bytes */
static int fill_buffer( URL_FILE *file, size_t want ) {
fd_set fdread;
fd_set fdwrite;
fd_set fdexcep;
struct timeval timeout;
int rc;
CURLMcode mc; /* curl_multi_fdset() return code */
/* only attempt to fill buffer if transactions still running and buffer
* doesn't exceed required size already
*/
if ( ( !file->still_running ) || ( file->buffer_pos > want ) )
return 0;
/* attempt to fill buffer */
do {
int maxfd = -1;
long curl_timeo = -1;
FD_ZERO( &fdread );
FD_ZERO( &fdwrite );
FD_ZERO( &fdexcep );
/* set a suitable timeout to fail on */
timeout.tv_sec = 60; /* 1 minute */
timeout.tv_usec = 0;
curl_multi_timeout( multi_handle, &curl_timeo );
if ( curl_timeo >= 0 ) {
timeout.tv_sec = curl_timeo / 1000;
if ( timeout.tv_sec > 1 )
timeout.tv_sec = 1;
else
timeout.tv_usec = ( curl_timeo % 1000 ) * 1000;
}
/* get file descriptors from the transfers */
mc = curl_multi_fdset( multi_handle, &fdread, &fdwrite, &fdexcep,
&maxfd );
if ( mc != CURLM_OK ) {
fprintf( stderr, "curl_multi_fdset() failed, code %d.\n", mc );
break;
}
/* On success the value of maxfd is guaranteed to be >= -1. We call
select(maxfd + 1, ...); specially in case of (maxfd == -1) there are
no fds ready yet so we call select(0, ...) --or Sleep() on Windows--
to sleep 100ms, which is the minimum suggested value in the
curl_multi_fdset() doc. */
if ( maxfd == -1 ) {
#ifdef _WIN32
Sleep( 100 );
rc = 0;
#else
/* Portable sleep for platforms other than Windows. */
struct timeval wait = { 0, 100 * 1000 }; /* 100ms */
rc = select( 0, NULL, NULL, NULL, &wait );
#endif
} else {
/* Note that on some platforms 'timeout' may be modified by select().
If you need access to the original value save a copy beforehand. */
rc = select( maxfd + 1, &fdread, &fdwrite, &fdexcep, &timeout );
}
switch ( rc ) {
case -1:
/* select error */
break;
case 0:
default:
/* timeout or readable/writable sockets */
curl_multi_perform( multi_handle, &file->still_running );
break;
}
} while ( file->still_running && ( file->buffer_pos < want ) );
return 1;
}
/* use to remove want bytes from the front of a files buffer */
static int use_buffer( URL_FILE *file, size_t want ) {
/* sort out buffer */
if ( ( file->buffer_pos - want ) <= 0 ) {
/* ditch buffer - write will recreate */
free( file->buffer );
file->buffer = NULL;
file->buffer_pos = 0;
file->buffer_len = 0;
} else {
/* move rest down make it available for later */
memmove( file->buffer,
&file->buffer[want], ( file->buffer_pos - want ) );
file->buffer_pos -= want;
}
return 0;
}
URL_FILE *url_fopen( const char *url, const char *operation ) {
/* this code could check for URLs or types in the 'url' and
basically use the real fopen() for standard files */
URL_FILE *file;
( void ) operation;
file = calloc( 1, sizeof( URL_FILE ) );
if ( !file )
return NULL;
file->handle.file = fopen( url, operation );
if ( file->handle.file ) {
file->type = CFTYPE_FILE; /* marked as file */
} else if ( index_of( ':', url ) > -1 ) {
file->type = CFTYPE_CURL; /* marked as URL */
file->handle.curl = curl_easy_init( );
curl_easy_setopt( file->handle.curl, CURLOPT_URL, url );
curl_easy_setopt( file->handle.curl, CURLOPT_WRITEDATA, file );
curl_easy_setopt( file->handle.curl, CURLOPT_VERBOSE, 0L );
curl_easy_setopt( file->handle.curl, CURLOPT_WRITEFUNCTION,
write_callback );
/* use the share object */
curl_easy_setopt( file->handle.curl, CURLOPT_SHARE, io_share );
if ( !multi_handle )
multi_handle = curl_multi_init( );
curl_multi_add_handle( multi_handle, file->handle.curl );
/* lets start the fetch */
curl_multi_perform( multi_handle, &file->still_running );
if ( ( file->buffer_pos == 0 ) && ( !file->still_running ) ) {
/* if still_running is 0 now, we should return NULL */
/* make sure the easy handle is not in the multi handle anymore */
curl_multi_remove_handle( multi_handle, file->handle.curl );
/* cleanup */
curl_easy_cleanup( file->handle.curl );
free( file );
file = NULL;
}
} else {
file->type = CFTYPE_NONE;
/* not a file, and doesn't look like a URL. */
}
return file;
}
int url_fclose( URL_FILE *file ) {
int ret = 0; /* default is good return */
switch ( file->type ) {
case CFTYPE_FILE:
ret = fclose( file->handle.file ); /* passthrough */
break;
case CFTYPE_CURL:
/* make sure the easy handle is not in the multi handle anymore */
curl_multi_remove_handle( multi_handle, file->handle.curl );
/* cleanup */
curl_easy_cleanup( file->handle.curl );
break;
default: /* unknown or supported type - oh dear */
ret = EOF;
errno = EBADF;
break;
}
free( file->buffer ); /* free any allocated buffer space */
free( file );
return ret;
}
int url_feof( URL_FILE *file ) {
int ret = 0;
switch ( file->type ) {
case CFTYPE_FILE:
ret = feof( file->handle.file );
break;
case CFTYPE_CURL:
if ( ( file->buffer_pos == 0 ) && ( !file->still_running ) )
ret = 1;
break;
default: /* unknown or supported type - oh dear */
ret = -1;
errno = EBADF;
break;
}
return ret;
}
size_t url_fread( void *ptr, size_t size, size_t nmemb, URL_FILE *file ) {
size_t want;
switch ( file->type ) {
case CFTYPE_FILE:
want = fread( ptr, size, nmemb, file->handle.file );
break;
case CFTYPE_CURL:
want = nmemb * size;
fill_buffer( file, want );
/* check if there's data in the buffer - if not fill_buffer()
* either errored or EOF */
if ( !file->buffer_pos )
return 0;
/* ensure only available data is considered */
if ( file->buffer_pos < want )
want = file->buffer_pos;
/* xfer data to caller */
memcpy( ptr, file->buffer, want );
use_buffer( file, want );
want = want / size; /* number of items */
break;
default: /* unknown or supported type - oh dear */
want = 0;
errno = EBADF;
break;
}
return want;
}
char *url_fgets( char *ptr, size_t size, URL_FILE *file ) {
size_t want = size - 1; /* always need to leave room for zero termination */
size_t loop;
switch ( file->type ) {
case CFTYPE_FILE:
ptr = fgets( ptr, ( int ) size, file->handle.file );
break;
case CFTYPE_CURL:
fill_buffer( file, want );
/* check if there's data in the buffer - if not fill either errored or
* EOF */
if ( !file->buffer_pos )
return NULL;
/* ensure only available data is considered */
if ( file->buffer_pos < want )
want = file->buffer_pos;
/*buffer contains data */
/* look for newline or eof */
for ( loop = 0; loop < want; loop++ ) {
if ( file->buffer[loop] == '\n' ) {
want = loop + 1; /* include newline */
break;
}
}
/* xfer data to caller */
memcpy( ptr, file->buffer, want );
ptr[want] = 0; /* always null terminate */
use_buffer( file, want );
break;
default: /* unknown or supported type - oh dear */
ptr = NULL;
errno = EBADF;
break;
}
return ptr; /*success */
}
void url_rewind( URL_FILE *file ) {
switch ( file->type ) {
case CFTYPE_FILE:
rewind( file->handle.file ); /* passthrough */
break;
case CFTYPE_CURL:
/* halt transaction */
curl_multi_remove_handle( multi_handle, file->handle.curl );
/* restart */
curl_multi_add_handle( multi_handle, file->handle.curl );
/* ditch buffer - write will recreate - resets stream pos */
free( file->buffer );
file->buffer = NULL;
file->buffer_pos = 0;
file->buffer_len = 0;
break;
default: /* unknown or supported type - oh dear */
break;
}
}
#ifdef FOPEN_STANDALONE
#define FGETSFILE "fgets.test"
#define FREADFILE "fread.test"
#define REWINDFILE "rewind.test"
/* Small main program to retrieve from a url using fgets and fread saving the
* output to two test files (note the fgets method will corrupt binary files if
* they contain 0 chars */
int main( int argc, char *argv[] ) {
URL_FILE *handle;
FILE *outf;
size_t nread;
char buffer[256];
const char *url;
CURL *curl;
CURLcode res;
curl_global_init( CURL_GLOBAL_DEFAULT );
curl = curl_easy_init( );
if ( argc < 2 )
url = "http://192.168.7.3/testfile"; /* default to testurl */
else
url = argv[1]; /* use passed url */
/* copy from url line by line with fgets */
outf = fopen( FGETSFILE, "wb+" );
if ( !outf ) {
perror( "couldn't open fgets output file\n" );
return 1;
}
handle = url_fopen( url, "r" );
if ( !handle ) {
printf( "couldn't url_fopen() %s\n", url );
fclose( outf );
return 2;
}
while ( !url_feof( handle ) ) {
url_fgets( buffer, sizeof( buffer ), handle );
fwrite( buffer, 1, strlen( buffer ), outf );
}
url_fclose( handle );
fclose( outf );
/* Copy from url with fread */
outf = fopen( FREADFILE, "wb+" );
if ( !outf ) {
perror( "couldn't open fread output file\n" );
return 1;
}
handle = url_fopen( "testfile", "r" );
if ( !handle ) {
printf( "couldn't url_fopen() testfile\n" );
fclose( outf );
return 2;
}
do {
nread = url_fread( buffer, 1, sizeof( buffer ), handle );
fwrite( buffer, 1, nread, outf );
} while ( nread );
url_fclose( handle );
fclose( outf );
/* Test rewind */
outf = fopen( REWINDFILE, "wb+" );
if ( !outf ) {
perror( "couldn't open fread output file\n" );
return 1;
}
handle = url_fopen( "testfile", "r" );
if ( !handle ) {
printf( "couldn't url_fopen() testfile\n" );
fclose( outf );
return 2;
}
nread = url_fread( buffer, 1, sizeof( buffer ), handle );
fwrite( buffer, 1, nread, outf );
url_rewind( handle );
buffer[0] = '\n';
fwrite( buffer, 1, 1, outf );
nread = url_fread( buffer, 1, sizeof( buffer ), handle );
fwrite( buffer, 1, nread, outf );
url_fclose( handle );
fclose( outf );
return 0; /* all done */
}
#endif

574
src/c/io/io.c Normal file
View file

@ -0,0 +1,574 @@
/*
* io.c
*
* Communication between PSSE and the outside world, via libcurl. NOTE
* that this file destructively changes metadata on URL connections,
* because the metadata is not available until the stream has been read
* from. It would be better to find a workaround!
*
* (c) 2019 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <grp.h>
#include <langinfo.h>
#include <pwd.h>
#include <stdlib.h>
#include <string.h>
#include <time.h>
#include <sys/stat.h>
#include <sys/types.h>
#include <unistd.h>
#include <uuid/uuid.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include <curl/curl.h>
//#include "arith/integer.h"
#include "debug.h"
#include "io/fopen.h"
#include "io/io.h"
#include "memory/node.h"
#include "memory/pointer.h"
#include "memory/pso2.h"
#include "memory/pso4.h"
#include "memory/tags.h"
// #include "ops/intern.h"
// #include "ops/lispops.h"
#include "ops/stack_ops.h"
#include "ops/string_ops.h"
#include "ops/truth.h"
#include "payloads/cons.h"
#include "payloads/exception.h"
#include "payloads/integer.h"
#include "payloads/stack.h"
#include "utils.h"
/**
* The sharing hub for all connections. TODO: Ultimately this probably doesn't
* work for a multi-user environment and we will need one sharing hub for each
* user, or else we will need to not share at least cookies and ssl sessions.
*/
CURLSH *io_share;
/**
* @brief bound to the Lisp string representing C_IO_IN in initialisation.
*/
struct pso_pointer lisp_io_in;
/**
* @brief bound to the Lisp string representing C_IO_OUT in initialisation.
*/
struct pso_pointer lisp_io_out;
/**
* Allow a one-character unget facility. This may not be enough - we may need
* to allocate a buffer.
*/
wint_t ungotten = 0;
/**
* Initialise the I/O subsystem.
*
* @return 0 on success; any other value means failure.
*/
int io_init( ) {
int result = curl_global_init( CURL_GLOBAL_SSL );
io_share = curl_share_init( );
if ( result == 0 ) {
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_DNS );
curl_share_setopt( io_share, CURLSHOPT_SHARE,
CURL_LOCK_DATA_SSL_SESSION );
curl_share_setopt( io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_PSL );
}
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 = 0;
for ( struct pso_pointer c = s; !nilp( c );
c = cdr(c)) {
len++;
}
wchar_t *buffer = calloc( len + 1, sizeof( wchar_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; !nilp( 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;
}
/**
* given this file handle f, return a new url_file handle wrapping it.
*
* @param f the file to be wrapped;
* @return the new handle, or null if no such handle could be allocated.
*/
URL_FILE *file_to_url_file( FILE *f ) {
URL_FILE *result = ( URL_FILE * ) malloc( sizeof( URL_FILE ) );
if ( result != NULL ) {
result->type = CFTYPE_FILE, result->handle.file = f;
}
return result;
}
/**
* get one wide character from the buffer.
*
* @param file the stream to read from;
* @return the next wide character on the stream, or zero if no more.
*/
wint_t url_fgetwc( URL_FILE *input ) {
wint_t result = -1;
if ( ungotten != 0 ) {
/* TODO: not thread safe */
result = ungotten;
ungotten = 0;
} else {
switch ( input->type ) {
case CFTYPE_FILE:
fwide( input->handle.file, 1 ); /* wide characters */
result = fgetwc( input->handle.file ); /* passthrough */
break;
case CFTYPE_CURL:{
char *cbuff =
calloc( sizeof( wchar_t ) + 2, sizeof( char ) );
wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) );
size_t count = 0;
debug_print( L"url_fgetwc: about to call url_fgets\n",
DEBUG_IO, 0 );
url_fgets( cbuff, 2, input );
debug_print( L"url_fgetwc: back from url_fgets\n",
DEBUG_IO, 0 );
int c = ( int ) cbuff[0];
// TODO: risk of reading off cbuff?
debug_printf( DEBUG_IO, 0,
L"url_fgetwc: cbuff is '%s'; (first) character = %d (%c)\n",
cbuff, c, c & 0xf7 );
/* The value of each individual byte indicates its UTF-8 function, as follows:
*
* 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 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.
* F0 to FF hex (240 to 255): first byte of a four-byte sequence.
*/
if ( c <= 0xf7 ) {
count = 1;
} else if ( c >= 0xc2 && c <= 0xdf ) {
count = 2;
} else if ( c >= 0xe0 && c <= 0xef ) {
count = 3;
} else if ( c >= 0xf0 && c <= 0xff ) {
count = 4;
}
if ( count > 1 ) {
url_fgets( ( char * ) &cbuff[1], count, input );
}
mbstowcs( wbuff, cbuff, 2 ); //(char *)(&input->buffer[input->buffer_pos]), 1 );
result = wbuff[0];
free( wbuff );
free( cbuff );
}
break;
case CFTYPE_NONE:
break;
}
}
debug_printf( DEBUG_IO, 0, L"url_fgetwc returning %d (%C)\n", result,
result );
return result;
}
wint_t url_ungetwc( wint_t wc, URL_FILE *input ) {
wint_t result = -1;
switch ( input->type ) {
case CFTYPE_FILE:
fwide( input->handle.file, 1 ); /* wide characters */
result = ungetwc( wc, input->handle.file ); /* passthrough */
break;
case CFTYPE_CURL:{
ungotten = wc;
break;
case CFTYPE_NONE:
break;
}
}
return result;
}
/**
* Function, sort-of: close the file indicated by my first arg, and return
* nil. If the first arg is not a stream, does nothing. All other args are
* ignored.
*
* * (close stream)
*
* @param frame my stack frame.
* @param frame_pointer a pointer to my stack frame.
* @param env my environment.
* @return T if the stream was successfully closed, else nil.
*/
struct pso_pointer
lisp_close( struct pso4 *frame, struct pso_pointer frame_pointer,
struct pso_pointer env ) {
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 )
== 0 ) {
result = t;
}
}
return result;
}
struct pso_pointer add_meta_integer( struct pso_pointer meta, wchar_t *key,
long int value ) {
return
cons( cons
( c_string_to_lisp_keyword( key ),
make_integer( value ) ), meta );
}
struct pso_pointer add_meta_string( struct pso_pointer meta, wchar_t *key,
char *value ) {
value = trim( value );
wchar_t buffer[strlen( value ) + 1];
mbstowcs( buffer, value, strlen( value ) + 1 );
return cons( cons( 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,
time_t *value ) {
/* I don't yet have a concept of a date-time object, which is a
* bit of an oversight! */
char datestring[256];
strftime( datestring,
sizeof( datestring ),
nl_langinfo( D_T_FMT ), localtime( value ) );
return add_meta_string( meta, key, datestring );
}
/**
* 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.
*/
static size_t write_meta_callback( char *string, size_t size, size_t nmemb,
struct pso_pointer stream ) {
struct pso2 *cell = pointer_to_object( stream );
// TODO: reimplement
/* make a copy of the string that we can destructively change */
// char *s = calloc( strlen( string ), sizeof( char ) );
// strcpy( s, string );
// if ( check_tag( cell, READTV) ||
// check_tag( cell, WRITETV) ) {
// int offset = index_of( ':', s );
// if ( offset != -1 ) {
// s[offset] = ( char ) 0;
// char *name = trim( s );
// char *value = trim( &s[++offset] );
// wchar_t wname[strlen( name )];
// mbstowcs( wname, name, strlen( name ) + 1 );
// cell->payload.stream.meta =
// add_meta_string( cell->payload.stream.meta, wname, value );
// debug_printf( DEBUG_IO,
// L"write_meta_callback: added header '%s': value '%s'\n",
// name, value );
// } else if ( strncmp( "HTTP", s, 4 ) == 0 ) {
// int offset = index_of( ' ', s );
// char *value = trim( &s[offset] );
// cell->payload.stream.meta =
// add_meta_integer( add_meta_string
// ( cell->payload.stream.meta, L"status",
// value ), L"status-code", strtol( value,
// NULL,
// 10 ) );
// debug_printf( DEBUG_IO,
// L"write_meta_callback: added header 'status': value '%s'\n",
// value );
// } else {
// debug_printf( DEBUG_IO,
// L"write_meta_callback: header passed with no colon: '%s'\n",
// s );
// }
// } else {
// debug_print
// ( L"Pointer passed to write_meta_callback did not point to a stream: ",
// DEBUG_IO );
// debug_dump_object( stream, DEBUG_IO );
// }
// free( s );
return 0; // strlen( string );
}
void collect_meta( 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", url );
struct stat statbuf;
int result = stat( url, &statbuf );
struct passwd *pwd;
struct group *grp;
switch ( s->type ) {
case CFTYPE_NONE:
break;
case CFTYPE_FILE:
if ( result == 0 ) {
if ( ( pwd = getpwuid( statbuf.st_uid ) ) != NULL ) {
meta = add_meta_string( meta, L"owner", pwd->pw_name );
} else {
meta = add_meta_integer( meta, L"owner", statbuf.st_uid );
}
if ( ( grp = getgrgid( statbuf.st_gid ) ) != NULL ) {
meta = add_meta_string( meta, L"group", grp->gr_name );
} else {
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_time( meta, L"modified", &statbuf.st_mtime );
}
break;
case CFTYPE_CURL:
curl_easy_setopt( s->handle.curl, CURLOPT_VERBOSE, 1L );
curl_easy_setopt( s->handle.curl, CURLOPT_HEADERFUNCTION,
write_meta_callback );
curl_easy_setopt( s->handle.curl, CURLOPT_HEADERDATA, stream );
break;
}
/* this is destructive change before the cell is released into the
* wild, and consequently permissible, just. */
cell->payload.stream.meta = meta;
}
/**
* Resutn the current default input, or of `inputp` is false, output stream from
* this `env`ironment.
*/
struct pso_pointer get_default_stream( bool inputp, struct pso_pointer env ) {
struct pso_pointer result = nil;
// struct pso_pointer stream_name = inputp ? lisp_io_in : lisp_io_out;
// result = c_assoc( stream_name, env );
return result;
}
/**
* Function: return a stream open on the URL indicated by the first argument;
* if a second argument is present and is non-nil, open it for writing. At
* present, further arguments are ignored and there is no mechanism to open
* to append, or error if the URL is faulty or indicates an unavailable
* resource.
*
* * (open url)
*
* @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_open( struct pso4 *frame, struct pso_pointer frame_pointer,
struct pso_pointer env ) {
struct pso_pointer result = nil;
// if ( stringp( fetch_arg( frame, 0) ) ) {
// char *url = lisp_string_to_c_string( fetch_arg( frame, 0) );
// if ( 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;
}
/**
* 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 pso4 *frame, struct pso_pointer frame_pointer,
struct pso_pointer env ) {
struct pso_pointer result = nil;
if ( readp( fetch_arg( frame, 0) ) ) {
result =
make_string( url_fgetwc
( pointer_to_object( fetch_arg( frame, 0) )->payload.
stream.stream ), nil );
}
return result;
}
/**
* Function: return a string representing all characters from the stream
* indicated by arg 0; further arguments are ignored.
*
* TODO: it should be possible to optionally pass a string URL to this function,
*
* * (slurp 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_slurp( struct pso4 *frame, struct pso_pointer frame_pointer,
struct pso_pointer env ) {
struct pso_pointer result = nil;
if ( readp( fetch_arg( frame, 0) ) ) {
URL_FILE *stream = pointer_to_object( fetch_arg( frame, 0) )->payload.stream.stream;
struct pso_pointer cursor = make_string( url_fgetwc( stream ), nil );
result = cursor;
for ( wint_t c = url_fgetwc( stream ); !url_feof( stream ) && c != 0;
c = url_fgetwc( stream ) ) {
debug_print( L"slurp: cursor is: ", DEBUG_IO, 0);
debug_dump_object( cursor, DEBUG_IO, 0 );
debug_print( L"; result is: ", DEBUG_IO, 0 );
debug_dump_object( result, DEBUG_IO, 0 );
debug_println( DEBUG_IO );
struct pso2 *cell = pointer_to_object( cursor );
cursor = make_string( ( wchar_t ) c, nil );
cell->payload.string.cdr = cursor;
}
}
return result;
}

49
src/c/io/io.h Normal file
View file

@ -0,0 +1,49 @@
/*
* io.h
*
* Communication between PSSE and the outside world, via libcurl.
*
* (c) 2019 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __psse_io_h
#define __psse_io_h
#include <curl/curl.h>
#include "memory/pointer.h"
#include "memory/pso2.h"
#include "memory/pso4.h"
extern CURLSH *io_share;
int io_init( );
#define C_IO_IN L"*in*"
#define C_IO_OUT L"*out*"
extern struct pso_pointer lisp_io_in;
extern struct pso_pointer lisp_io_out;
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_default_stream( bool inputp, struct pso_pointer env );
struct pso_pointer
lisp_close( struct pso4 *frame, struct pso_pointer frame_pointer,
struct pso_pointer env );
struct pso_pointer
lisp_open( struct pso4 *frame, struct pso_pointer frame_pointer,
struct pso_pointer env );
struct pso_pointer
lisp_read_char( struct pso4 *frame, struct pso_pointer frame_pointer,
struct pso_pointer env );
struct pso_pointer
lisp_slurp( struct pso4 *frame, struct pso_pointer frame_pointer,
struct pso_pointer env );
char *lisp_string_to_c_string( struct pso_pointer s );
#endif

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

@ -20,9 +20,13 @@
*/
#include <wchar.h>
#include <wctype.h>
/* libcurl, used for io */
#include <curl/curl.h>
#include "io/fopen.h"
#include "io/io.h"
#include "memory/node.h"
#include "memory/pointer.h"
#include "memory/pso.h"
#include "memory/pso2.h"
@ -32,16 +36,16 @@
#include "payloads/cons.h"
#include "payloads/integer.h"
struct pso_pointer in_print( pso_pointer p, URL_FILE * stream);
struct pso_pointer in_print( struct pso_pointer p, URL_FILE * output);
struct pso_pointer print_list_content( pso_pointer p, URL_FILE * stream) {
struct pso_pointer print_list_content( struct pso_pointer p, URL_FILE * output) {
struct pso_pointer result = nil;
if (consp(p)) {
for (; consp( p); p = cdr(p)) {
stuct pso2* object = pointer_to_object(cursor);
struct pso2* object = pointer_to_object(p);
result = in_print( object->payload.cons.car, stream);
result = in_print( object->payload.cons.car, output);
if (exceptionp(result)) break;
@ -49,18 +53,14 @@ struct pso_pointer print_list_content( pso_pointer p, URL_FILE * stream) {
case NILTV :
break;
case CONSTV :
url_fputwc( L'\ ', output );
url_fputwc( L' ', output );
break;
default :
url_fputws( L" . ", output);
result = in_print( object->payload.cons.cdr, stream);
result = in_print( object->payload.cons.cdr, output);
}
}
struct pso_pointer cdr = object->payload.cons.cdr;
switchb( get)
} else {
// TODO: return exception
}
@ -68,25 +68,25 @@ struct pso_pointer print_list_content( pso_pointer p, URL_FILE * stream) {
return result;
}
struct pso_pointer in_print( pso_pointer p, URL_FILE * stream) {
stuct pso2* object = pointer_to_object(p);
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) {
if (object != NULL) {
switch (get_tag_value( p)) {
case CHARACTERTV :
url_fputwc( object->payload.character.character, output);
break;
case CONSTV :
url_fputwc( L'\(', output );
result = print_list_content( object, stream);
url_fputwc( L'\)', output );
url_fputwc( L'(', output );
result = print_list_content( p, output);
url_fputwc( L')', output );
break;
case INTEGERTV :
fwprintf( output, "%d", (int64_t)(object->payload.integer.value));
url_fwprintf( output, L"%d", (int64_t)(object->payload.integer.value));
break;
case TRUETV :
url_fputwc( L'\t', output );
url_fputwc( L't', output );
break;
case NILTV :
url_fputws( L"nil", output );
@ -107,10 +107,10 @@ struct pso_pointer in_print( pso_pointer p, URL_FILE * stream) {
* @param stream if a pointer to an open write stream, print to there.
* @return struct pso_pointer `nil`, or an exception if some erroe occurred.
*/
struct pso_pointer print( pso_pointer p, pso_pointer stream) {
struct pso_pointer print( struct pso_pointer p, struct pso_pointer stream) {
URL_FILE *output = writep( stream) ?
pointer_to_object( stream )->payload.stream.stream:
stdout;
pointer_to_object( stream )->payload.stream.stream :
file_to_url_file(stdout);
if ( writep( stream)) { inc_ref( stream); }

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

@ -14,6 +14,6 @@
#ifndef __psse_io_print_h
#define __psse_io_print_h
struct pso_pointer print( pso_pointer p, pso_pointer stream);
struct pso_pointer print( struct pso_pointer p, struct pso_pointer stream);
#endif

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

@ -13,8 +13,6 @@
#include <stdint.h>
#include "memory/header.h"
#include "memory/tags.h"
#include "payloads/character.h"
#include "payloads/cons.h"
#include "payloads/free.h"

53
src/c/memory/tags.c Normal file
View file

@ -0,0 +1,53 @@
/**
* memory/tags.h
*
* It would be nice if I could get the macros for tsg operations to work,
* but at present they don't and they're costing me time. So I'm going to
* redo them as functions.
*
* (c) 2026 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdbool.h>
#include <stdint.h>
#include <string.h>
#include "memory/pointer.h"
#include "memory/pso2.h"
uint32_t get_tag_value (struct pso_pointer p) {
struct pso2* object = pointer_to_object( p);
return object->header.tag.value & 0xffffff;
}
/**
* @brief check that the tag of the object indicated by this poiner has this
* value.
*
* @param p must be a struct pso_pointer, indicating the appropriate object.
* @param v should be an integer, ideally uint32_t, the expected value of a tag.
*
* @return true if the tag at p matches v, else false.
*/
bool check_tag( struct pso_pointer p, uint32_t v) {
return get_tag_value(p) == v;
}
/**
* @brief Like check_tag, q.v., but comparing with the string value of the tag
* rather than the integer value. Only the first TAGLENGTH characters of `s`
* are considered.
*
* @param p a pointer to an object;
* @param s a string, in C conventions;
* @return true if the first TAGLENGTH characters of `s` are equal to the tag
* of the object.
* @return false otherwise.
*/
bool check_type( struct pso_pointer p, char* s) {
return (strncmp(
&(pointer_to_object(p)->header.tag.bytes.mnemonic[0]), s, TAGLENGTH)
== 0);
}

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

@ -12,8 +12,11 @@
#ifndef __psse_memory_tags_h
#define __psse_memory_tags_h
#include <stdbool.h>
#define TAGLENGTH 3
#define CHARACTERTAG "CHR"
#define CONSTAG "CNS"
#define EXCEPTIONTAG "EXP"
#define FREETAG "FRE"
@ -43,9 +46,8 @@
#define VECTORPOINTTAG "VSP"
#define WRITETAG "WRT"
// TODO: all these tag values are WRONG, recalculate!
#define CONSTV 5459523
#define CHARACTERTV 5392451
#define CONSTV 5459523
#define EXCEPTIONTV 5265477
#define FREETV 4543046
#define FUNCTIONTV 5133638
@ -71,12 +73,37 @@
#define VECTORPOINTTV 5264214
#define WRITETV 5264214
#define consp(p) (check_tag(p,CONSTV))
#define exceptionp(p) (check_tag(p,EXCEPTIONTV))
#define freep(p) (check_tag(p,FREETV))
#define functionp(p) (check_tag(p,FUNCTIONTV))
#define integerp(p) (check_tag(p,INTEGERTV))
#define keywordp(p) (check_tag(p,KEYTV))
/**
* @brief return the numerical value of the tag of the object indicated by
* pointer `p`.
*
* @param p must be a struct pso_pointer, indicating the appropriate object.
*
* @return the numerical value of the tag, as a uint32_t.
*/
// #define get_tag_value(p)((pointer_to_object(p)->header.tag.value) & 0xffffff)
uint32_t get_tag_value (struct pso_pointer p);
/**
* @brief check that the tag of the object indicated by this poiner has this
* value.
*
* @param p must be a struct pso_pointer, indicating the appropriate object.
* @param v should be an integer, ideally uint32_t, the expected value of a tag.
*
* @return true if the tag at p matches v, else false.
*/
// #define check_tag(p,v) (get_tag_value(p) == v)
bool check_tag( struct pso_pointer p, uint32_t v);
bool check_type( struct pso_pointer p, char* s);
#define consp(p) (check_tag(p, CONSTV))
#define exceptionp(p) (check_tag(p, EXCEPTIONTV))
#define freep(p) (check_tag(p, FREETV))
#define functionp(p) (check_tag(p, FUNCTIONTV))
#define integerp(p) (check_tag(p, INTEGERTV))
#define keywordp(p) (check_tag(p, KEYTV))
#define lambdap(p) (check_tag(p,LAMBDATV))
#define loopp(p) (check_tag(p,LOOPTV))
#define namespacep(p)(check_tag(p,NAMESPACETV))
@ -101,25 +128,4 @@
#define vectorp(p) (check_tag(p,VECTORTV))
#define writep(p) (check_tag(p,WRITETV))
/**
* @brief return the numerical value of the tag of the object indicated by
* pointer `p`.
*
* @param p must be a struct pso_pointer, indicating the appropriate object.
*
* @return the numerical value of the tag, as a uint32_t.
*/
#define get_tag_value(p)((pointer_to_object(p)->header.tag.value) & 0xffffff)
/**
* @brief check that the tag of the object indicated by this poiner has this
* value.
*
* @param p must be a struct pso_pointer, indicating the appropriate object.
* @param v should be an integer, ideally uint32_t, the expected value of a tag.
*
* @return true if the tag at p matches v, else false.
*/
#define check_tag(p,v) (get_tag_value(p) == v)
#endif

1
src/c/ops/eval.c
View file

@ -10,6 +10,7 @@
*/
#include "memory/pointer.h"
#include "memory/pso2.h"
#include "memory/pso4.h"
#include "memory/tags.h"

164
src/c/ops/string_ops.c Normal file
View file

@ -0,0 +1,164 @@
/**
* ops/string_ops.h
*
* Operations on a Lisp string frame.
*
* (c) 2026 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdint.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include "debug.h"
#include "memory/node.h"
#include "memory/pointer.h"
#include "memory/pso.h"
#include "memory/pso2.h"
#include "memory/tags.h"
#include "ops/truth.h"
#include "payloads/exception.h"
/**
* Return a hash value for this string like thing.
*
* What's important here is that two strings with the same characters in the
* same order should have the same hash value, even if one was created using
* `"foobar"` and the other by `(append "foo" "bar")`. I *think* this function
* has that property. I doubt that it's the most efficient hash function to
* have that property.
*
* returns 0 for things which are not string like.
*/
uint32_t calculate_hash( wint_t c, struct pso_pointer ptr ) {
struct pso2 *cell = pointer_to_object( ptr );
uint32_t result = 0;
switch ( get_tag_value(ptr)) {
case KEYTV:
case STRINGTV:
case SYMBOLTV:
if ( nilp( cell->payload.string.cdr ) ) {
result = ( uint32_t ) c;
} else {
result =
( ( uint32_t ) c *
cell->payload.string.hash ) & 0xffffffff;
}
break;
}
return result;
}
/**
* Construct a string from this character (which later will be UTF) and
* this tail. A string is implemented as a flat list of cells each of which
* has one character and a pointer to the next; in the last cell the
* pointer to next is nil.
*
* NOTE THAT: in 0.1.X, we may allocate symbols and keywords as arrays of
* wchar_t in larger pso classes, so this function may be only for strings
* (and thus simpler).
*/
struct pso_pointer make_string_like_thing( wint_t c, struct pso_pointer tail,
char* tag ) {
struct pso_pointer pointer = nil;
if ( check_type( tail, tag ) || check_tag( tail, NILTV ) ) {
pointer = allocate( tag, CONS_SIZE_CLASS);
struct pso2 *cell = pointer_to_object( pointer );
cell->payload.string.character = c;
cell->payload.string.cdr = tail;
cell->payload.string.hash = calculate_hash( c, tail);
debug_dump_object( pointer, DEBUG_ALLOC, 0 );
debug_println( DEBUG_ALLOC );
} else {
// \todo should throw an exception!
debug_printf( DEBUG_ALLOC, 0,
L"Warning: only %4.4s can be prepended to %4.4s\n",
tag, tag );
}
return pointer;
}
/**
* Construct a string from the character `c` and this `tail`. A string is
* implemented as a flat list of cells each of which has one character and a
* pointer to the next; in the last cell the pointer to next is NIL.
*
* @param c the character to add (prepend);
* @param tail the string which is being built.
*/
struct pso_pointer make_string( wint_t c, struct pso_pointer tail ) {
return make_string_like_thing( c, tail, STRINGTAG );
}
/**
* Construct a keyword from the character `c` and this `tail`. A string is
* implemented as a flat list of cells each of which has one character and a
* pointer to the next; in the last cell the pointer to next is NIL.
*
* @param c the character to add (prepend);
* @param tail the keyword which is being built.
*/
struct pso_pointer make_keyword( wint_t c, struct pso_pointer tail ) {
return make_string_like_thing( c, tail, KEYTAG );
}
/**
* Construct a symbol from the character `c` and this `tail`. A string is
* implemented as a flat list of cells each of which has one character and a
* pointer to the next; in the last cell the pointer to next is NIL.
*
* @param c the character to add (prepend);
* @param tail the symbol which is being built.
*/
struct pso_pointer make_symbol( wint_t c, struct pso_pointer tail ) {
return make_string_like_thing( c, tail, STRINGTAG );
}
/**
* Return a lisp string representation of this wide character string.
*/
struct pso_pointer c_string_to_lisp_string( wchar_t *string ) {
struct pso_pointer result = nil;
for ( int i = wcslen( string ) - 1; i >= 0; i-- ) {
if ( iswprint( string[i] ) && string[i] != '"' ) {
result = make_string( string[i], result );
}
}
return result;
}
/**
* Return a lisp keyword representation of this wide character string. In
* keywords, I am accepting only lower case characters and numbers.
*/
struct pso_pointer c_string_to_lisp_keyword( wchar_t *symbol ) {
struct pso_pointer result = nil;
for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) {
wchar_t c = towlower( symbol[i] );
if ( iswalnum( c ) || c == L'-' ) {
result = make_keyword( c, result );
}
}
return result;
}

32
src/c/ops/string_ops.h Normal file
View file

@ -0,0 +1,32 @@
/**
* ops/string_ops.h
*
* Operations on a Lisp string.
*
* (c) 2026 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __psse_ops_string_ops_h
#define __psse_ops_string_ops_h
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
struct pso_pointer make_string_like_thing( wint_t c, struct pso_pointer tail,
char* tag );
struct pso_pointer make_string( wint_t c, struct pso_pointer tail );
struct pso_pointer make_keyword( wint_t c, struct pso_pointer tail );
struct pso_pointer make_symbol( wint_t c, struct pso_pointer tail );
struct pso_pointer c_string_to_lisp_string( wchar_t *string );
struct pso_pointer c_string_to_lisp_keyword( wchar_t *symbol );
#endif

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

@ -13,6 +13,7 @@
#include "memory/pointer.h"
#define CONS_SIZE_CLASS 2
/**
* @brief A cons cell.

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

@ -8,7 +8,13 @@
*/
#include "memory/node.h"
#include "memory/pointer.h"
#include "memory/pso.h"
#include "payloads/exception.h"
struct pso_pointer make_exception( struct pso_pointer message, struct pso_pointer frame_pointer, struct pso_pointer cause) {
// TODO: not yet implemented
return nil;
}

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

@ -9,7 +9,6 @@
#ifndef __psse_payloads_exception_h
#define __psse_payloads_exception_h
#include <stdbool.h>
#include "memory/pointer.h"
@ -25,4 +24,6 @@ struct exception_payload {
struct pso_pointer cause;
};
struct pso_pointer make_exception( struct pso_pointer message, struct pso_pointer frame_pointer, struct pso_pointer cause);
#endif

39
src/c/payloads/integer.c Normal file
View file

@ -0,0 +1,39 @@
/**
* payloads/integer.c
*
* An integer. Doctrine here is that we are not implementing bignum arithmetic in
* the bootstrap layer; an integer is, for now, just a 64 bit integer.
*
* (c) 2026 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdint.h>
#include "memory/node.h"
#include "memory/pointer.h"
#include "memory/pso.h"
#include "memory/pso2.h"
#include "memory/tags.h"
#include "debug.h"
/**
* Allocate an integer cell representing this `value` and return a pso_pointer to it.
* @param value an integer value;
* @param more `nil`, or a pointer to the more significant cell(s) of this number.
* *NOTE* that if `more` is not `nil`, `value` *must not* exceed `MAX_INTEGER`.
*/
struct pso_pointer make_integer( int64_t value ) {
struct pso_pointer result = nil;
debug_print( L"Entering make_integer\n", DEBUG_ALLOC , 0);
result = allocate( INTEGERTAG, 2);
struct pso2 *cell = pointer_to_object( result );
cell->payload.integer.value = value;
debug_print( L"make_integer: returning\n", DEBUG_ALLOC , 0);
debug_dump_object( result, DEBUG_ALLOC, 0 );
return result;
}

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

@ -23,5 +23,6 @@ struct integer_payload {
__int128_t value;
};
struct pso_pointer make_integer( int64_t value );
#endif

2
src/c/payloads/psse-string.h
View file

@ -33,4 +33,6 @@ struct string_payload {
struct pso_pointer cdr;
};
struct pso_pointer make_string( wint_t c, struct pso_pointer tail );
#endif

25
src/c/payloads/psse_string.c Normal file
View file

@ -0,0 +1,25 @@
/**
* payloads/string.c
*
* A string cell.
*
* (c) 2026 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdint.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include "memory/node.h"
#include "memory/pointer.h"
#include "memory/pso2.h"
#include "memory/tags.h"
#include "ops/string_ops.h"
#include "ops/truth.h"

33
src/c/utils.c Normal file
View file

@ -0,0 +1,33 @@
/*
* utils.c
*
* little generally useful functions which aren't in any way special to PSSE.
*
* (c) 2019 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <ctype.h>
#include <stdlib.h>
#include <string.h>
int index_of( char c, const char *s ) {
int i;
for ( i = 0; s[i] != c && s[i] != 0; i++ );
return s[i] == c ? i : -1;
}
char *trim( char *s ) {
int i;
for ( i = strlen( s ); ( isblank( s[i] ) || iscntrl( s[i] ) ) && i >= 0;
i-- ) {
s[i] = '\0';
}
for ( i = 0; s[i] != '\0' && ( isblank( s[i] ) || iscntrl( s[i] ) ); i++ );
return ( char * ) &s[i];
}

17
src/c/utils.h Normal file
View file

@ -0,0 +1,17 @@
/*
* utils.h
*
* little generally useful functions which aren't in any way special to PSSE.
*
* (c) 2019 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __psse_utils_h
#define __psse_utils_h
int index_of( char c, const char *s );
char *trim( char *s );
#endif

17
src/sed/convert.sed Normal file
View file

@ -0,0 +1,17 @@
# sed script to help converting snippets of code from 0.0.X to 0.1.X
s?allocate_cell( *\([A-Z]*\) *)?allocate( \1, 2)?g
s?c_car(?car(?g
s?c_cdr(?cdr(?g
s?cons_pointer?pso_pointer?g
s?consspaceobject\.h?pso2\.h?
s?cons_space_object?pso2?g
s?debug_print(\([^)]*\))?debug_print(\1, 0)?g
s?frame->arg?frame->payload.stack_frame.arg?g
s?make_cons?cons?g
s?NIL?nil?g
s?nilTAG?NILTAG?g
s?&pointer2cell?pointer_to_object?g
s?stack_frame?pso4?g
s?stack\.h?pso4\.h?
s?tag.value?header.tag.bytes.value \& 0xfffff?g