From ca5671f6137f95f055a0461404595a48cd9fd867 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 17 Apr 2026 18:40:32 +0100 Subject: [PATCH] String-like-things are being created and printed correctly; bind is broken. --- src/c/environment/environment.c | 7 +- src/c/environment/environment.h | 1 + src/c/io/io.c | 736 ++++++++++++++++---------------- src/c/io/print.c | 180 +++++--- src/c/memory/tags.h | 5 +- src/c/ops/assoc.c | 2 +- src/c/ops/repl.c | 9 + src/c/ops/string_ops.c | 18 +- 8 files changed, 508 insertions(+), 450 deletions(-) diff --git a/src/c/environment/environment.c b/src/c/environment/environment.c index 309818e..0fa4e0b 100644 --- a/src/c/environment/environment.c +++ b/src/c/environment/environment.c @@ -36,7 +36,7 @@ bool environment_initialised = false; * @brief Initialise a minimal environment, so that Lisp can be bootstrapped. * * @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 ) { @@ -85,9 +85,14 @@ struct pso_pointer initialise_environment( uint32_t node ) { } if ( !exceptionp( result ) ) { 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 ); 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_BOOTSTRAP, 0 ); } diff --git a/src/c/environment/environment.h b/src/c/environment/environment.h index 4ec736a..9983558 100644 --- a/src/c/environment/environment.h +++ b/src/c/environment/environment.h @@ -10,6 +10,7 @@ #ifndef __psse_environment_environment_h #define __psse_environment_environment_h +#include struct pso_pointer initialise_environment( uint32_t node ); #endif diff --git a/src/c/io/io.c b/src/c/io/io.c index 61175e8..cfeca65 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -35,6 +35,7 @@ #include "memory/node.h" #include "memory/pointer.h" +#include "memory/pso.h" #include "memory/pso2.h" #include "memory/pso4.h" #include "memory/tags.h" @@ -86,14 +87,14 @@ wint_t ungotten = 0; * @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 ) ); +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; - } + if (result != NULL) { + 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. */ -int initialise_io( ) { - int result = curl_global_init( CURL_GLOBAL_SSL ); +int initialise_io() { + int result = curl_global_init(CURL_GLOBAL_SSL); - io_share = curl_share_init( ); + 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 ); - } + 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; + return result; } -struct pso_pointer initialise_default_streams( struct pso_pointer env ) { - lisp_io_in = c_string_to_lisp_symbol( C_IO_IN ); - lisp_io_out = c_string_to_lisp_symbol( C_IO_OUT ); +struct pso_pointer initialise_default_streams(struct pso_pointer env) { + lisp_io_in = c_string_to_lisp_symbol(C_IO_IN); + 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, - make_read_stream( file_to_url_file( stdin ), - c_cons( c_cons - ( c_string_to_lisp_keyword - ( L"url" ), - c_string_to_lisp_string - ( L"system:standard input" ) ), - nil ) ), env ); - if ( !nilp( env ) && !exceptionp( env ) ) { - env = c_bind( lisp_io_out, - make_write_stream( file_to_url_file( stdout ), - c_cons( c_cons - ( c_string_to_lisp_keyword - ( L"url" ), - c_string_to_lisp_string - ( L"system:standard input" ) ), - nil ) ), env ); - } + env = c_bind( + lisp_io_in, + lock_object(make_read_stream( + file_to_url_file(stdin), + c_cons(c_cons(c_string_to_lisp_keyword(L"url"), + c_string_to_lisp_string(L"::system:standard-input")), + nil))), + env); + debug_print_object(env, DEBUG_IO, 0); + if (!nilp(env) && !exceptionp(env)) { + env = c_bind(lisp_io_out, + lock_object(make_write_stream( + file_to_url_file(stdout), + c_cons(c_cons(c_string_to_lisp_keyword(L"url"), + c_string_to_lisp_string( + L"::system:standard-output")), + 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; * @return the c string. */ -char *lisp_string_to_c_string( struct pso_pointer s ) { - char *result = NULL; +char *lisp_string_to_c_string(struct pso_pointer s) { + char *result = NULL; - if ( stringp( s ) || symbolp( s ) ) { - int len = 0; + if (stringp(s) || symbolp(s)) { + int len = 0; - for ( struct pso_pointer c = s; !nilp( c ); c = c_cdr( c ) ) { - len++; - } + for (struct pso_pointer c = s; !nilp(c); 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 ) ); + 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 = c_cdr( c ) ) { - buffer[i++] = pointer_to_object( c )->payload.string.character; - } + int i = 0; + for (struct pso_pointer c = s; !nilp(c); c = c_cdr(c)) { + buffer[i++] = pointer_to_object(c)->payload.string.character; + } - wcstombs( result, buffer, len ); - free( buffer ); - } + 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 ); + debug_print(L"lisp_string_to_c_string( ", DEBUG_IO, 0); + debug_print_object(s, DEBUG_IO, 0); + debug_printf(DEBUG_IO, 0, L") => '%s'\n", result); - return result; + return result; } /** @@ -189,94 +197,93 @@ char *lisp_string_to_c_string( struct pso_pointer s ) { * @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; +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; + 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 ) ); + case CFTYPE_CURL: { + char *cbuff = calloc(sizeof(wchar_t) + 2, sizeof(char)); + wchar_t *wbuff = calloc(2, sizeof(wchar_t)); - size_t count = 0; + size_t count = 0; - debug_print( L"url_fgetwc: about to call url_fgets\n", - DEBUG_IO, 0 ); - 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; - } + 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]; + 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; - } - } + 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; + 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; +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; + 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; - } - } + case CFTYPE_CURL: { + ungotten = wc; + break; + case CFTYPE_NONE: + 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. */ -struct pso_pointer get_character( struct pso_pointer read_stream ) { - struct pso_pointer result = nil; +struct pso_pointer get_character(struct pso_pointer read_stream) { + struct pso_pointer result = nil; - if ( readp( read_stream ) ) { - result = - make_character( url_fgetwc - ( pointer_to_object_of_size_class( read_stream, 2 ) - ->payload.stream.stream ) ); - } + if (readp(read_stream)) { + result = make_character( + url_fgetwc(pointer_to_object_of_size_class(read_stream, 2) + ->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`. */ -struct pso_pointer push_back_character( struct pso_pointer c, - struct pso_pointer r ) { - struct pso_pointer result = nil; +struct pso_pointer push_back_character(struct pso_pointer c, + struct pso_pointer r) { + struct pso_pointer result = nil; - if ( characterp( c ) && readp( r ) ) { - if ( url_ungetwc( ( wint_t ) - ( pointer_to_object( c )->payload.character. - character ), - pointer_to_object( r )->payload.stream.stream ) >= - 0 ) { - result = t; - } - } - return result; + if (characterp(c) && readp(r)) { + if (url_ungetwc( + (wint_t)(pointer_to_object(c)->payload.character.character), + pointer_to_object(r)->payload.stream.stream) >= 0) { + result = t; + } + } + return result; } /** @@ -336,191 +340,186 @@ struct pso_pointer push_back_character( struct pso_pointer c, * @param env my environment. * @return T if the stream was successfully closed, else nil. */ -struct pso_pointer lisp_close( struct pso_pointer frame_pointer, - struct pso_pointer env ) { - struct pso4 *frame = pointer_to_pso4( frame_pointer ); - struct pso_pointer result = nil; +struct pso_pointer lisp_close(struct pso_pointer frame_pointer, + struct pso_pointer env) { + struct pso4 *frame = pointer_to_pso4(frame_pointer); + struct pso_pointer result = nil; - if ( readp( fetch_arg( frame, 0 ) ) || writep( fetch_arg( frame, 0 ) ) ) { - if ( url_fclose( pointer_to_object( fetch_arg( frame, 0 ) ) - ->payload.stream.stream ) == 0 ) { - result = t; - } - } + 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; + return result; } -struct pso_pointer add_meta_integer( struct pso_pointer meta, wchar_t *key, - long int value ) { - return - c_cons( c_cons - ( c_string_to_lisp_keyword( key ), make_integer( value ) ), - meta ); +struct pso_pointer add_meta_integer(struct pso_pointer meta, wchar_t *key, + long int value) { + return c_cons(c_cons(c_string_to_lisp_keyword(key), make_integer(value)), + meta); } -struct pso_pointer add_meta_string( struct pso_pointer meta, wchar_t *key, - char *value ) { - value = trim( value ); - wchar_t buffer[strlen( value ) + 1]; - mbstowcs( buffer, value, strlen( value ) + 1 ); +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 - c_cons( c_cons - ( c_string_to_lisp_keyword( key ), - c_string_to_lisp_string( buffer ) ), meta ); + return c_cons( + c_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]; +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 ) ); + strftime(datestring, sizeof(datestring), nl_langinfo(D_T_FMT), + 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 * 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 ); +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 + // TODO: reimplement - /* make a copy of the string that we can destructively change */ - // char *s = calloc( strlen( string ), sizeof( char ) ); + /* make a copy of the string that we can destructively change */ + // char *s = calloc( strlen( string ), sizeof( char ) ); - // strcpy( s, string ); + // strcpy( s, string ); - // if ( check_tag( cell, READTV) || - // check_tag( cell, WRITETV) ) { - // int offset = index_of( ':', s ); + // 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 )]; + // 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 ); + // mbstowcs( wname, name, strlen( name ) + 1 ); - // cell->payload.stream.meta = - // add_meta_string( cell->payload.stream.meta, wname, value ); + // 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] ); + // 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 ) ); + // 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 ); - // } + // 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 ); + // 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; +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 ); - } + 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 ); - } + 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_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; - } + 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; + /* 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; +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 ); + result = c_assoc(stream_name, env); - return result; + return result; } /** * @brief if `s` points to either an input or an output stream, return the * URL_FILE pointer underlying that stream, else NULL. */ -URL_FILE *stream_get_url_file( struct pso_pointer s ) { - URL_FILE *result = NULL; +URL_FILE *stream_get_url_file(struct pso_pointer s) { + URL_FILE *result = NULL; - if ( readp( s ) || writep( s ) ) { - struct pso2 *obj = pointer_to_object( s ); + if (readp(s) || writep(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 * on my stream, if any, else nil. */ -struct pso_pointer lisp_open( struct pso_pointer frame_pointer, - struct pso_pointer env ) { - struct pso4 *frame = pointer_to_pso4( frame_pointer ); - struct pso_pointer result = nil; +struct pso_pointer lisp_open(struct pso_pointer frame_pointer, + struct pso_pointer env) { + struct pso4 *frame = pointer_to_pso4(frame_pointer); + struct pso_pointer result = nil; - // if ( stringp( fetch_arg( frame, 0) ) ) { - // char *url = lisp_string_to_c_string( fetch_arg( frame, 0) ); + // if ( 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" ); + // 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 ); + // 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; - // } + // 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 ); - // } + // 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 ); - // } + // if ( pointer_to_object( result )->payload.stream.stream == NULL ) { + // result = nil; + // } else { + // 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 * on my stream, if any, else nil. */ -struct pso_pointer lisp_read_char( struct pso_pointer frame_pointer, - struct pso_pointer env ) { - struct pso4 *frame = pointer_to_pso4( frame_pointer ); - struct pso_pointer result = nil; +struct pso_pointer lisp_read_char(struct pso_pointer frame_pointer, + struct pso_pointer env) { + struct pso4 *frame = pointer_to_pso4(frame_pointer); + struct pso_pointer result = nil; - struct pso_pointer stream_pointer = fetch_arg( frame, 0 ); - if ( readp( stream_pointer ) ) { - result = - make_string( url_fgetwc( stream_get_url_file( stream_pointer ) ), - nil ); - } + struct pso_pointer stream_pointer = fetch_arg(frame, 0); + if (readp(stream_pointer)) { + result = + make_string(url_fgetwc(stream_get_url_file(stream_pointer)), 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 * on my stream, if any, else nil. */ -struct pso_pointer lisp_slurp( struct pso_pointer frame_pointer, - struct pso_pointer env ) { - struct pso4 *frame = pointer_to_pso4( frame_pointer ); - struct pso_pointer result = nil; +struct pso_pointer lisp_slurp(struct pso_pointer frame_pointer, + struct pso_pointer env) { + struct pso4 *frame = pointer_to_pso4(frame_pointer); + struct pso_pointer result = nil; - if ( readp( 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 ); - result = cursor; + if (readp(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); + 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 ); + 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; - } - } + struct pso2 *cell = pointer_to_object(cursor); + cursor = make_string((wchar_t)c, nil); + cell->payload.string.cdr = cursor; + } + } - return result; + return result; } diff --git a/src/c/io/print.c b/src/c/io/print.c index 365fb18..da89685 100644 --- a/src/c/io/print.c +++ b/src/c/io/print.c @@ -3,8 +3,8 @@ * * Post Scarcity Software Environment: print. * - * Print basic Lisp objects..This is :bootstrap layer print; it needs to be - * able to print characters, symbols, integers, lists and dotted pairs. I + * Print basic Lisp objects..This is :bootstrap layer print; it needs to be + * able to print characters, symbols, integers, lists and dotted pairs. I * don't think it needs to be able to print anything else. * * (c) 2026 Simon Brooke @@ -12,6 +12,7 @@ */ #include +#include #include #include #include @@ -36,93 +37,130 @@ #include "payloads/cons.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 result = nil; +struct pso_pointer in_print(struct pso_pointer p, URL_FILE *output); - if ( consp( p ) ) { - for ( ; consp( p ); p = c_cdr( p ) ) { - struct pso2 *object = pointer_to_object( p ); +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; + } - 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 ) ) - 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; + if (stringp(p)) { + url_fputwc(L'"', output); + } } -struct pso_pointer in_print( struct pso_pointer p, URL_FILE *output ) { - struct pso2 *object = pointer_to_object( p ); - struct pso_pointer result = nil; +struct pso_pointer print_list_content(struct pso_pointer p, URL_FILE *output) { + struct pso_pointer result = nil; - 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( 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 - } + if (consp(p)) { + for (; consp(p); p = c_cdr(p)) { + struct pso2 *object = pointer_to_object(p); - 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. - * + * * @param p pointer to the object to print. * @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 c_print( struct pso_pointer p, struct pso_pointer stream ) { - URL_FILE *output = writep( stream ) ? - pointer_to_object( stream )->payload.stream.stream : - file_to_url_file( stdout ); +struct pso_pointer c_print(struct pso_pointer p, struct pso_pointer stream) { + struct pso_pointer result = p; + URL_FILE *output = writep(stream) + ? pointer_to_object(stream)->payload.stream.stream + : file_to_url_file(stdout); - if ( writep( stream ) ) { - inc_ref( stream ); - } + if (writep(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; } diff --git a/src/c/memory/tags.h b/src/c/memory/tags.h index 575c739..5516de1 100644 --- a/src/c/memory/tags.h +++ b/src/c/memory/tags.h @@ -13,6 +13,7 @@ #define __psse_memory_tags_h #include +#include #define TAGLENGTH 3 @@ -71,8 +72,8 @@ #define TRUETV 5591636 #define VECTORTV 4408662 #define VECTORPOINTTV 5264214 -#define WRITETV 5264214 - +#define WRITETV 5526103 +// 5526103 /** * @brief return the numerical value of the tag of the object indicated by * pointer `p`. diff --git a/src/c/ops/assoc.c b/src/c/ops/assoc.c index fb63afc..100806d 100644 --- a/src/c/ops/assoc.c +++ b/src/c/ops/assoc.c @@ -41,7 +41,7 @@ struct pso_pointer search( struct pso_pointer key, if ( consp( 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 ); if ( consp( pair ) && c_equal( c_car( pair ), key ) ) { diff --git a/src/c/ops/repl.c b/src/c/ops/repl.c index efc8a3b..2bd0c44 100644 --- a/src/c/ops/repl.c +++ b/src/c/ops/repl.c @@ -57,6 +57,15 @@ void c_repl( ) { 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 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 ) && !url_feof( stream_get_url_file( input_stream ) ) ) { diff --git a/src/c/ops/string_ops.c b/src/c/ops/string_ops.c index b4dc31c..f565234 100644 --- a/src/c/ops/string_ops.c +++ b/src/c/ops/string_ops.c @@ -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, char *tag ) { - struct pso_pointer pointer = nil; + struct pso_pointer pointer = tail; if ( check_type( tail, tag ) || nilp( tail ) ) { 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.hash = calculate_hash( c, tail ); - debug_dump_object( pointer, DEBUG_ALLOC, 0 ); - debug_println( DEBUG_ALLOC ); + debug_printf( DEBUG_ALLOC, 0, + 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 { // \todo should throw an exception! 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 ); } + return pointer; } @@ -138,9 +142,11 @@ 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] != '"' ) { + if ( string[i] != '"' ) { result = make_string( string[i], result ); - } + } else { + result = make_string( L'\\', make_string( string[i], 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-- ) { wchar_t c = towlower( symbol[i] ); - if ( iswalpha( c ) || c == L'-' ) { + if ( iswalpha( c ) || c == L'-' || c == L'*') { result = make_symbol( c, result ); } }