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

342
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,10 +87,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;
} }
@ -101,46 +102,53 @@ 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);
env = c_bind( lisp_io_in, debug_print( L"In initialise_default_streams; environment is: ", DEBUG_IO, 0);
make_read_stream( file_to_url_file( stdin ), debug_print_object(env, DEBUG_IO, 0);
c_cons( c_cons
( c_string_to_lisp_keyword env = c_bind(
( L"url" ), lisp_io_in,
c_string_to_lisp_string lock_object(make_read_stream(
( L"system:standard input" ) ), file_to_url_file(stdin),
nil ) ), env ); c_cons(c_cons(c_string_to_lisp_keyword(L"url"),
if ( !nilp( env ) && !exceptionp( env ) ) { c_string_to_lisp_string(L"::system:standard-input")),
env = c_bind( lisp_io_out, nil))),
make_write_stream( file_to_url_file( stdout ), env);
c_cons( c_cons debug_print_object(env, DEBUG_IO, 0);
( c_string_to_lisp_keyword if (!nilp(env) && !exceptionp(env)) {
( L"url" ), env = c_bind(lisp_io_out,
c_string_to_lisp_string lock_object(make_write_stream(
( L"system:standard input" ) ), file_to_url_file(stdout),
nil ) ), env ); c_cons(c_cons(c_string_to_lisp_keyword(L"url"),
c_string_to_lisp_string(
L"::system:standard-output")),
nil))),
env);
} }
debug_print( L"Leaving initialise_default_streams; environment is: ", DEBUG_IO, 0);
debug_print_object(env, DEBUG_IO, 0);
return env; return env;
} }
@ -153,32 +161,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;
} }
@ -189,37 +197,35 @@ 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 );
int c = ( int ) cbuff[0];
// TODO: risk of reading off cbuff? // TODO: risk of reading off cbuff?
debug_printf( 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:
* *
@ -230,45 +236,46 @@ 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, 2 ); //(char *)(&input->buffer[input->buffer_pos]), 1 ); mbstowcs(wbuff, cbuff,
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:
@ -287,14 +294,13 @@ 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,16 +314,14 @@ 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 ) >=
0 ) {
result = t; result = t;
} }
} }
@ -336,14 +340,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;
} }
} }
@ -351,45 +355,42 @@ 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 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
@ -447,45 +448,43 @@ 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 = 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;
} }
@ -498,11 +497,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;
} }
@ -511,11 +510,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;
} }
@ -538,9 +537,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) ) ) {
@ -605,16 +604,15 @@ 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,26 +632,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;
} }
} }

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

@ -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,31 +37,56 @@
#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 print_string_like_thing(struct pso_pointer p,
URL_FILE *output) {
switch (get_tag_value(p)) {
case KEYTV:
url_fputwc(L':', output);
break;
case STRINGTV:
url_fputwc(L'"', output);
break;
}
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 (stringp(p)) {
url_fputwc(L'"', 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 {
// TODO: return exception // TODO: return exception
@ -69,29 +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) {
switch ( get_tag_value( p ) ) { uint32_t v = get_tag_value(p);
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 TRUETV: case KEYTV:
url_fputwc( L't', output ); case STRINGTV:
case SYMBOLTV:
print_string_like_thing(p, output);
break; break;
case NILTV: case NILTV:
url_fputws( L"nil", output ); 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: default:
// TODO: return exception // TODO: return exception
} }
@ -109,19 +148,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) {
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

@ -58,6 +58,15 @@ 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)) {
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 ) ) ) {
/* bottom of stack */ /* bottom of stack */

16
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,8 +142,10 @@ 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));
} }
} }
@ -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 );
} }
} }