From aa0d60bbed0112eaffa6a963916b4bff8255b3c8 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 23 Apr 2026 11:50:30 +0100 Subject: [PATCH] It compiles. It runs. Nothing works, but it also doesn't crash. Victory! --- src/c/debug.c | 18 +- src/c/environment/environment.c | 2 +- src/c/io/io.c | 338 +++++++++++++++----------------- src/c/io/io.h | 10 +- src/c/io/read.c | 51 +++-- src/c/io/read.h | 2 + src/c/memory/pso.c | 33 +++- src/c/memory/pso2.h | 2 +- src/c/memory/pso4.c | 4 +- src/c/memory/pso4.h | 4 +- src/c/ops/assoc.c | 12 +- src/c/ops/repl.c | 4 +- src/c/ops/string_ops.c | 52 ++++- src/c/ops/string_ops.h | 4 +- src/c/payloads/integer.c | 5 + src/c/payloads/integer.h | 2 + src/c/payloads/stack.c | 11 +- src/c/payloads/time.c | 57 ++++++ src/c/payloads/time.h | 11 +- src/c/psse.c | 12 +- 20 files changed, 390 insertions(+), 244 deletions(-) create mode 100644 src/c/payloads/time.c diff --git a/src/c/debug.c b/src/c/debug.c index a551b19..e293e89 100644 --- a/src/c/debug.c +++ b/src/c/debug.c @@ -118,15 +118,15 @@ void debug_println( int level ) { */ void debug_printf( int level, int indent, char32_t *format, ... ) { #ifdef DEBUG - if ( level & verbosity ) { - fwide( stderr, 1 ); - for ( int i = 0; i < indent; i++ ) { - fputws( L" ", stderr ); - } - va_list( args ); - va_start( args, format ); - vfwprintf( stderr, format, args ); - } +// if ( level & verbosity ) { +// fwide( stderr, 1 ); +// for ( int i = 0; i < indent; i++ ) { +// fputws( L" ", stderr ); +// } +// va_list( args ); +// va_start( args, format ); +// vfwprintf( stderr, format, args ); +// } #endif } diff --git a/src/c/environment/environment.c b/src/c/environment/environment.c index 3bbb021..4c83bc7 100644 --- a/src/c/environment/environment.c +++ b/src/c/environment/environment.c @@ -41,7 +41,7 @@ bool environment_initialised = false; struct pso_pointer initialise_environment( uint32_t node ) { struct pso_pointer result = initialise_memory( node ); - struct pso_pointer frame_pointer = make_frame( 0, nil ); + struct pso_pointer frame_pointer = nil; // can't have a frame pointer before we've initialised nil and t if ( c_truep( result ) ) { debug_print( L"Initialising `nil`... ", DEBUG_BOOTSTRAP, 0 ); diff --git a/src/c/io/io.c b/src/c/io/io.c index 20e01e1..c2e9c3c 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -106,6 +106,16 @@ struct pso_pointer lisp_stderr; */ struct pso_pointer lisp_io_prompt; +/** + * @brief bound to the Lisp symbol representing C_IO_READBASE in initialisation + */ +struct pso_pointer lisp_io_readbase; + +/** + * @brief bound to the Lisp symbol representing C_IO_READTABLE in initialisation + */ +struct pso_pointer lisp_io_readtable; + /** * Allow a one-character unget facility. This may not be enough - we may need * to allocate a buffer. @@ -134,6 +144,10 @@ URL_FILE *file_to_url_file( FILE *f ) { * @return 0 on success; any other value means failure. */ int initialise_io( ) { + fwide( stdin, 1 ); + fwide( stdout, 1 ); + fwide( stderr, 1 ); + int result = curl_global_init( CURL_GLOBAL_SSL ); io_share = curl_share_init( ); @@ -150,75 +164,100 @@ int initialise_io( ) { return result; } -struct pso_pointer initialise_default_streams( struct pso_pointer stack_frame, +struct pso_pointer initialise_default_streams( struct pso_pointer + frame_pointer, struct pso_pointer env ) { // todo: issue #21: should this have stack frame passed in? // It's called in initialisation before everything else is set // up, so **possibly** not? - lisp_io_in = c_string_to_lisp_symbol( stack_frame, C_IO_IN ); - lisp_io_out = c_string_to_lisp_symbol( stack_frame, C_IO_OUT ); - lisp_io_log = c_string_to_lisp_symbol( stack_frame, C_IO_LOG ); - lisp_io_prompt = c_string_to_lisp_symbol( stack_frame, C_IO_PROMPT ); + lisp_io_in = c_string_to_lisp_symbol( frame_pointer, C_IO_IN ); + lisp_io_out = c_string_to_lisp_symbol( frame_pointer, C_IO_OUT ); + lisp_io_log = c_string_to_lisp_symbol( frame_pointer, C_IO_LOG ); + lisp_io_prompt = c_string_to_lisp_symbol( frame_pointer, C_IO_PROMPT ); + lisp_io_readbase = c_string_to_lisp_symbol( frame_pointer, C_IO_READBASE ); + lisp_io_readtable = + c_string_to_lisp_symbol( frame_pointer, C_IO_READTABLE ); debug_print( L"In initialise_default_streams; environment is: ", DEBUG_IO, 0 ); debug_print_object( env, DEBUG_IO, 0 ); env = - lisp_bind( make_frame - ( 3, stack_frame, lisp_io_prompt, - c_string_to_lisp_string( stack_frame, INITIAL_PROMPT ), - env ) ); + lisp_bind( make_frame( 3, frame_pointer, lisp_io_prompt, + c_string_to_lisp_string( frame_pointer, + INITIAL_PROMPT ), + lisp_bind( make_frame + ( 3, frame_pointer, lisp_io_readbase, + acquire_integer( frame_pointer, + 10 ), + lisp_bind( make_frame + ( 3, frame_pointer, + lisp_io_readtable, + nil, env ) ) ) ) ) ); lisp_stdin = lock_object( make_read_stream - ( stack_frame, file_to_url_file( stdin ), - make_cons( stack_frame, - make_cons( stack_frame, + ( frame_pointer, file_to_url_file( stdin ), + make_cons( frame_pointer, + make_cons( frame_pointer, c_string_to_lisp_keyword - ( stack_frame, L"url" ), + ( frame_pointer, L"url" ), c_string_to_lisp_string - ( stack_frame, + ( frame_pointer, L"::system:standard-input" ) ), - stack_frame ) ) ); + frame_pointer ) ) ); env = - lisp_bind( make_frame( 3, stack_frame, lisp_io_in, lisp_stdin, env ) ); + lisp_bind( make_frame + ( 3, frame_pointer, lisp_io_in, lisp_stdin, env ) ); debug_print_object( env, DEBUG_IO, 0 ); if ( !c_nilp( env ) && !exceptionp( env ) ) { lisp_stdout = - lock_object( make_write_stream( stack_frame, + lock_object( make_write_stream( frame_pointer, file_to_url_file( stdout ), - make_cons( stack_frame, - make_cons( stack_frame, - c_string_to_lisp_keyword - ( stack_frame, - L"url" ), - c_string_to_lisp_string - ( stack_frame, - L"::system:standard-output" ) ), + make_cons( frame_pointer, + make_cons + ( frame_pointer, + c_string_to_lisp_keyword + ( frame_pointer, + L"url" ), + c_string_to_lisp_string + ( frame_pointer, + L"::system:standard-output" ) ), nil ) ) ); env = lisp_bind( make_frame - ( 3, stack_frame, lisp_io_out, lisp_stdout, env ) ); + ( 3, frame_pointer, lisp_io_out, lisp_stdout, env ) ); } if ( !c_nilp( env ) && !exceptionp( env ) ) { lisp_stderr = lock_object( make_write_stream - ( stack_frame, file_to_url_file( stderr ), - make_cons( stack_frame, - make_cons( stack_frame, + ( frame_pointer, file_to_url_file( stderr ), + make_cons( frame_pointer, + make_cons( frame_pointer, c_string_to_lisp_keyword - ( stack_frame, L"url" ), + ( frame_pointer, L"url" ), c_string_to_lisp_string - ( stack_frame, + ( frame_pointer, L"::system:standard-output" ) ), nil ) ) ); env = lisp_bind( make_frame ( 3, frame_pointer, lisp_io_log, lisp_stderr, env ) ); } + // TODO: create the sink stream. Something like: + // URL_FILE *sink = url_fopen( "/dev/null", "w" ); + // fwide( sink->handle.file, 1 ); +// bind_value( L"*sink*", +// make_write_stream( sink, +// make_cons( make_cons +// ( c_string_to_lisp_keyword +// ( L"url" ), +// c_string_to_lisp_string +// ( L"system:standard sink" ) ), +// NIL ) ), false ); + debug_print( L"Leaving initialise_default_streams; environment is: ", DEBUG_IO, 0 ); @@ -226,40 +265,6 @@ struct pso_pointer initialise_default_streams( struct pso_pointer stack_frame, return env; } -/** - * 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; !c_nilp( c ); c = c_cdr( c ) ) { - len++; - } - - char32_t *buffer = calloc( len + 1, sizeof( char32_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; !c_nilp( c ); 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; -} /** * get one wide character from the buffer. @@ -351,25 +356,6 @@ wint_t url_ungetwc( wint_t wc, URL_FILE *input ) { return result; } -/** - * @brief Read one character object from this `read_stream`. - * - * @param read_stream a pointer to an object which should be a read stream - * object, - * - * @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; - if ( readp( read_stream ) ) { - result = - make_character( url_fgetwc - ( pointer_to_object_of_size_class - ( read_stream, 2 )->payload.stream.stream ) ); - } - - return result; -} /** * @brief Push back this character `c` onto this read stream `r`. @@ -384,8 +370,8 @@ struct pso_pointer push_back_character( struct pso_pointer c, 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( c )->payload. + character.character ), pointer_to_object( r )->payload.stream.stream ) >= 0 ) { result = t; @@ -412,8 +398,8 @@ struct pso_pointer lisp_close( struct pso_pointer 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 ) + ( pointer_to_object( fetch_arg( frame, 0 ) )->payload. + stream.stream ) == 0 ) { result = t; } @@ -422,34 +408,43 @@ struct pso_pointer lisp_close( struct pso_pointer frame_pointer, return result; } -struct pso_pointer add_meta_integer( struct pso_pointer meta, char32_t *key, +struct pso_pointer add_meta_integer( struct pso_pointer frame_pointer, + struct pso_pointer meta, char32_t *key, long int value ) { - // todo: issue #21: must have stack frame passed in. - return - make_cons( make_cons - ( c_string_to_lisp_keyword( key ), make_integer( value ) ), - meta ); + return make_cons( frame_pointer, + make_cons( frame_pointer, + c_string_to_lisp_keyword( frame_pointer, + key ), + make_integer( frame_pointer, value ) ), + meta ); } -struct pso_pointer add_meta_string( struct pso_pointer meta, char32_t *key, +struct pso_pointer add_meta_string( struct pso_pointer frame_pointer, + struct pso_pointer meta, char32_t *key, char *value ) { - // todo: issue #21: must have stack frame passed in. value = trim( value ); char32_t buffer[strlen( value ) + 1]; mbstowcs( buffer, value, strlen( value ) + 1 ); - return - make_cons( make_cons - ( c_string_to_lisp_keyword( frame_pointer, key ), - c_string_to_lisp_string( buffer ) ), meta ); + return make_cons( frame_pointer, + make_cons( frame_pointer, + c_string_to_lisp_keyword( frame_pointer, + key ), + c_string_to_lisp_string( frame_pointer, + buffer ) ), meta ); } -struct pso_pointer add_meta_time( struct pso_pointer meta, char32_t *key, +struct pso_pointer add_meta_time( struct pso_pointer frame_pointer, + struct pso_pointer meta, char32_t *key, time_t *value ) { - // todo: issue #21: must have stack frame passed in. - char datestring[256]; - strftime( datestring, sizeof( datestring ), nl_langinfo( D_T_FMT ), - localtime( value ) ); - return add_meta_string( meta, key, datestring ); + return make_cons( frame_pointer, + make_cons( frame_pointer, + c_string_to_lisp_keyword( frame_pointer, + key ), + make_time( frame_pointer, + ( value == + NULL ) ? nil : + make_integer( frame_pointer, + *value ) ) ), meta ); } /** @@ -505,11 +500,12 @@ static size_t write_meta_callback( char *string, size_t size, size_t nmemb, return 0; // strlen( string ); } -void collect_meta( struct pso_pointer stream, char *url ) { +void collect_meta( struct pso_pointer frame_pointer, 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", + add_meta_string( frame_pointer, cell->payload.stream.meta, L"url", url ); struct stat statbuf; int result = stat( url, &statbuf ); @@ -521,21 +517,31 @@ void collect_meta( struct pso_pointer stream, char *url ) { case CFTYPE_FILE: if ( result == 0 ) { if ( ( pwd = getpwuid( statbuf.st_uid ) ) != NULL ) { - meta = add_meta_string( meta, L"owner", pwd->pw_name ); + meta = + add_meta_string( frame_pointer, meta, L"owner", + pwd->pw_name ); } else { - meta = add_meta_integer( meta, L"owner", statbuf.st_uid ); + meta = + add_meta_integer( frame_pointer, meta, L"owner", + statbuf.st_uid ); } if ( ( grp = getgrgid( statbuf.st_gid ) ) != NULL ) { - meta = add_meta_string( meta, L"group", grp->gr_name ); + meta = + add_meta_string( frame_pointer, meta, L"group", + grp->gr_name ); } else { - meta = add_meta_integer( meta, L"group", statbuf.st_gid ); + meta = + add_meta_integer( frame_pointer, meta, L"group", + statbuf.st_gid ); } meta = - add_meta_integer( meta, L"size", + add_meta_integer( frame_pointer, meta, L"size", ( intmax_t ) statbuf.st_size ); - meta = add_meta_time( meta, L"modified", &statbuf.st_mtime ); + meta = + add_meta_time( frame_pointer, meta, L"modified", + &statbuf.st_mtime ); } break; case CFTYPE_CURL: @@ -595,75 +601,51 @@ 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 ( c_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 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( frame_pointer, - url_fgetwc( stream_get_url_file - ( stream_pointer ) ), nil ); + if ( stringp( fetch_arg( frame, 0 ) ) ) { + char *url = lisp_string_to_c_string( fetch_arg( frame, 0 ) ); + if ( c_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( make_frame( 1, frame_pointer, + c_string_to_lisp_string + ( frame_pointer, + L"Could not open stream" ) ) ); + break; + case CFTYPE_FILE: + if ( stream->handle.file == NULL ) { + return make_exception( make_frame( 1, frame_pointer, + c_string_to_lisp_string + ( frame_pointer, + L"Could not open file" ) ) ); + } + break; + case CFTYPE_CURL: + /* can't tell whether a URL is bad without reading it */ + break; + } + result = make_read_stream( frame_pointer, stream, nil ); + } else { + // TODO: anything more complex is a problem for another day. + URL_FILE *stream = url_fopen( url, "w" ); + result = make_write_stream( frame_pointer, stream, nil ); + } + if ( pointer_to_object( result )->payload.stream.stream == NULL ) { + result = nil; + } else { + collect_meta( frame_pointer, result, url ); + } + free( url ); } return result; } + /** * Function: return a string representing all characters from the stream * indicated by arg 0; further arguments are ignored. diff --git a/src/c/io/io.h b/src/c/io/io.h index cc660d1..10552b4 100644 --- a/src/c/io/io.h +++ b/src/c/io/io.h @@ -33,10 +33,14 @@ struct pso_pointer initialise_default_streams( struct pso_pointer #define C_IO_IN L"*in*" #define C_IO_OUT L"*out*" #define C_IO_LOG L"*log*" +#define C_IO_READBASE L"*read_base*" +#define C_IO_READTABLE L"*read_table*" extern struct pso_pointer lisp_io_in; extern struct pso_pointer lisp_io_out; extern struct pso_pointer lisp_io_log; +extern struct pso_pointer lisp_io_readbase; +extern struct pso_pointer lisp_io_read_table; extern struct pso_pointer lisp_stdin; extern struct pso_pointer lisp_stdout; @@ -47,11 +51,12 @@ extern struct pso_pointer lisp_stderr; extern struct pso_pointer lisp_io_prompt; + + 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_character( struct pso_pointer read_stream ); struct pso_pointer push_back_character( struct pso_pointer c, struct pso_pointer r ); @@ -65,9 +70,6 @@ lisp_close( struct pso_pointer frame_pointer, struct pso_pointer env ); struct pso_pointer lisp_open( struct pso_pointer frame_pointer, struct pso_pointer env ); struct pso_pointer -lisp_read_char( struct pso_pointer frame_pointer, struct pso_pointer env ); -struct pso_pointer lisp_slurp( struct pso_pointer frame_pointer, struct pso_pointer env ); -char *lisp_string_to_c_string( struct pso_pointer s ); #endif diff --git a/src/c/io/read.c b/src/c/io/read.c index 8525836..2b44d55 100644 --- a/src/c/io/read.c +++ b/src/c/io/read.c @@ -32,6 +32,7 @@ #include "memory/pso2.h" #include "memory/tags.h" +#include "payloads/exception.h" #include "payloads/function.h" #include "payloads/integer.h" #include "payloads/read_stream.h" @@ -73,12 +74,7 @@ * 1. The read table currently in use; * 2. The character most recently read from that stream. */ -struct pso_pointer read_example( -#ifndef MANAGED_POINTER_ONLY - struct pso4 *frame, -#endif - struct pso_pointer frame_pointer, - struct pso_pointer env ) { +struct pso_pointer read_example( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer stream = fetch_arg( frame, 0 ); struct pso_pointer readtable = fetch_arg( frame, 1 ); @@ -88,6 +84,31 @@ struct pso_pointer read_example( 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 read_character( struct pso_pointer frame_pointer ) { + 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( frame_pointer, + url_fgetwc( stream_get_url_file + ( stream_pointer ) ), nil ); + } + + return result; +} + /** * @brief Read one integer from the stream and return it. * @@ -111,7 +132,8 @@ struct pso_pointer read_number( struct pso_pointer frame_pointer ) { if ( readp( stream ) ) { if ( c_nilp( character ) ) { - character = get_character( stream ); + character = + read_character( make_frame( 1, frame_pointer, stream ) ); } char32_t c = c_nilp( character ) ? 0 : pointer_to_object( character )->payload.character.character; @@ -137,7 +159,8 @@ struct pso_pointer read_symbol( struct pso_pointer frame_pointer ) { if ( readp( stream ) ) { if ( c_nilp( character ) ) { - character = get_character( stream ); + character = + read_character( make_frame( 1, frame_pointer, stream ) ); } char32_t c = c_nilp( character ) @@ -186,7 +209,7 @@ struct pso_pointer read( struct pso_pointer frame_pointer ) { } if ( c_nilp( character ) ) { - character = get_character( stream ); + character = read_character( make_frame( 1, frame_pointer, stream ) ); } struct pso_pointer readmacro = c_assoc( character, readtable ); @@ -205,12 +228,10 @@ struct pso_pointer read( struct pso_pointer frame_pointer ) { /* skip all characters from semi-colon to the end of the line */ break; case EOF: - // result = throw_exception( c_string_to_lisp_symbol( - // L"read" ), - // c_string_to_lisp_string - // ( L"End of input while - // reading" ), - // frame_pointer ); + result = make_exception( make_frame( 1, frame_pointer, + c_string_to_lisp_string + ( frame_pointer, + L"Read: end of input while reading" ) ) ); break; default: struct pso_pointer next = make_frame( 3, frame_pointer, stream, diff --git a/src/c/io/read.h b/src/c/io/read.h index 7bb4687..5508510 100644 --- a/src/c/io/read.h +++ b/src/c/io/read.h @@ -13,6 +13,8 @@ #ifndef __psse_io_read_h #define __psse_io_read_h +struct pso_pointer read_character( struct pso_pointer frame_pointer ); + struct pso_pointer read_number( struct pso_pointer frame_pointer ); struct pso_pointer read_symbol( struct pso_pointer frame_pointer ); diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index 16e60f9..b827f50 100644 --- a/src/c/memory/pso.c +++ b/src/c/memory/pso.c @@ -35,6 +35,26 @@ #include "ops/truth.h" +/** + * @brief a means of creating a cons cell without using a stack frame, to + * prevent runaway recursion. + * + * @param car + * @param cdr + * + * return cons + */ +struct pso_pointer cheaty_make_cons( struct pso_pointer car, + struct pso_pointer cdr ) { + struct pso_pointer result = allocate( nil, CONSTAG, 2 ); + struct pso2 *obj = pointer_to_object( result ); + + obj->payload.cons.car = car; + obj->payload.cons.cdr = cdr; + + return result; +} + /** * @brief Allocate an object of this `size_class` with this `tag`. * @@ -67,15 +87,18 @@ struct pso_pointer allocate( struct pso_pointer frame_pointer, char *tag, struct pso4 *frame = pointer_to_pso4( frame_pointer ); if ( !c_nilp( result ) ) { - strncpy( ( char * ) ( pointer_to_object( result )->header.tag. - bytes.mnemonic ), tag, TAGLENGTH ); + strncpy( ( char * ) ( pointer_to_object( result )->header.tag.bytes. + mnemonic ), tag, TAGLENGTH ); debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ", result.page, result.offset ); if ( stackp( frame_pointer ) ) { - struct pso_pointer locals = make_cons( frame_pointer, result, - frame->payload. - stack_frame.locals ); + // You can't make a stack frame in the middle of making a stack + // frame. Infinite recursion. So we have to cheat. + struct pso_pointer locals = cheaty_make_cons( result, + frame-> + payload.stack_frame. + locals ); frame->payload.stack_frame.locals = locals; } else if ( memory_initialised ) { diff --git a/src/c/memory/pso2.h b/src/c/memory/pso2.h index 812d582..2d93a50 100644 --- a/src/c/memory/pso2.h +++ b/src/c/memory/pso2.h @@ -48,7 +48,7 @@ struct pso2 { struct stream_payload stream; struct string_payload string; // TODO: this isn't working and I don't know why (error: field ‘time’ has incomplete type) -// struct time_payload time; + struct time_payload time; struct vectorp_payload vectorp; } payload; }; diff --git a/src/c/memory/pso4.c b/src/c/memory/pso4.c index d68e1e2..745af24 100644 --- a/src/c/memory/pso4.c +++ b/src/c/memory/pso4.c @@ -1,5 +1,5 @@ /** - * memory/pso4.h + * memory/pso4.c * * Paged space object of size class 4, 16 words total, 14 words payload. * @@ -11,5 +11,3 @@ #include "memory/pso.h" #include "memory/pso2.h" #include "memory/pso4.h" - -struct pso4 *pointer_to_pso4( struct pso_pointer p ); diff --git a/src/c/memory/pso4.h b/src/c/memory/pso4.h index bafda3f..59996f7 100644 --- a/src/c/memory/pso4.h +++ b/src/c/memory/pso4.h @@ -13,6 +13,7 @@ #include #include "memory/header.h" + #include "payloads/free.h" #include "payloads/stack.h" @@ -31,6 +32,7 @@ struct pso4 { } payload; }; -struct pso4 *pointer_to_pso4( struct pso_pointer p ); +// struct pso4 *pointer_to_pso4( struct pso_pointer p ); +#define pointer_to_pso4(p)((struct pso4*)pointer_to_object(p)) #endif diff --git a/src/c/ops/assoc.c b/src/c/ops/assoc.c index f77cbb8..d61f6e8 100644 --- a/src/c/ops/assoc.c +++ b/src/c/ops/assoc.c @@ -108,8 +108,8 @@ struct pso_pointer assoc( struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer store = or( make_frame( 2, frame_pointer, fetch_arg( frame, 1 ), - frame->payload. - stack_frame.env ) ); + frame->payload.stack_frame. + env ) ); return c_assoc( key, store ); } @@ -130,8 +130,8 @@ struct pso_pointer interned( struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer store = or( make_frame( 2, frame_pointer, fetch_arg( frame, 1 ), - frame->payload. - stack_frame.env ) ); + frame->payload.stack_frame. + env ) ); return c_interned( key, store ); } @@ -152,8 +152,8 @@ struct pso_pointer internedp( struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer store = or( make_frame( 2, frame_pointer, fetch_arg( frame, 1 ), - frame->payload. - stack_frame.env ) ); + frame->payload.stack_frame. + env ) ); return c_internedp( key, store ) ? t : nil; } diff --git a/src/c/ops/repl.c b/src/c/ops/repl.c index e2f46fe..a427a2b 100644 --- a/src/c/ops/repl.c +++ b/src/c/ops/repl.c @@ -41,7 +41,7 @@ * * @param dummy */ -void int_handler( int dummy ) { +void interrupt_handler( int dummy ) { wprintf( L"TODO: handle ctrl-C in a more interesting way\n" ); } @@ -52,7 +52,7 @@ void repl( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); bool show_prompt = c_truep( fetch_arg( frame, 0 ) ); // todo: issue #21: must have stack frame passed in. - signal( SIGINT, int_handler ); + signal( SIGINT, interrupt_handler ); debug_print( L"Entered repl\n", DEBUG_REPL, 0 ); struct pso_pointer env = fetch_env( frame_pointer ); diff --git a/src/c/ops/string_ops.c b/src/c/ops/string_ops.c index 7bdc88a..74d0f47 100644 --- a/src/c/ops/string_ops.c +++ b/src/c/ops/string_ops.c @@ -8,7 +8,8 @@ */ #include - +#include +#include /* * wide characters */ @@ -143,7 +144,7 @@ struct pso_pointer make_symbol( struct pso_pointer frame_pointer, wint_t c, * Return a lisp string representation of this wide character string. */ struct pso_pointer c_string_to_lisp_string( struct pso_pointer frame_pointer, - char32_t *string ) { + wchar_t *string ) { struct pso_pointer result = nil; for ( int i = wcslen( string ) - 1; i >= 0; i-- ) { @@ -159,6 +160,53 @@ struct pso_pointer c_string_to_lisp_string( struct pso_pointer frame_pointer, 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 = 1; + for ( struct pso_pointer c = s; !c_nilp( c ); c = c_cdr( c ) ) { + len++; + } + + wchar_t *buffer = calloc( len, sizeof( char32_t ) ); + int i = 0; + for ( struct pso_pointer c = s; !c_nilp( c ); c = c_cdr( c ) ) { + buffer[i++] = + ( wchar_t ) ( pointer_to_object( c )->payload.string. + character ); + } + + mbstate_t ps; + const wchar_t *src = buffer; + memset( &ps, 0, sizeof( ps ) ); + result = + calloc( wcsrtombs( NULL, &src, len, &ps ) + 1, sizeof( char ) ); + src = buffer; + memset( &ps, 0, sizeof( ps ) ); + wcsrtombs( result, &src, len, &ps ); + free( buffer ); +// mbstate_t ps = mbstate_t(); +// +// result = calloc( wcsrtombs( NULL, &buffer, len, &ps) + 1 ); +// wcsrtombs( result, &buffer, len, &ps); +// 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; +} + /** * Return a lisp symbol representation of this wide character string. In diff --git a/src/c/ops/string_ops.h b/src/c/ops/string_ops.h index 781901f..463aab7 100644 --- a/src/c/ops/string_ops.h +++ b/src/c/ops/string_ops.h @@ -31,7 +31,9 @@ struct pso_pointer make_symbol( struct pso_pointer frame_pointer, wint_t c, struct pso_pointer tail ); struct pso_pointer c_string_to_lisp_string( struct pso_pointer frame_pointer, - char32_t * string ); + wchar_t *string ); +char *lisp_string_to_c_string( struct pso_pointer s ); + struct pso_pointer c_string_to_lisp_keyword( struct pso_pointer frame_pointer, char32_t * symbol ); diff --git a/src/c/payloads/integer.c b/src/c/payloads/integer.c index 8fe53d7..9b85b5a 100644 --- a/src/c/payloads/integer.c +++ b/src/c/payloads/integer.c @@ -39,3 +39,8 @@ struct pso_pointer make_integer( struct pso_pointer frame_pointer, return result; } + +struct pso_pointer acquire_integer( struct pso_pointer frame_pointer, + int64_t value ) { + return make_integer( frame_pointer, value ); +} diff --git a/src/c/payloads/integer.h b/src/c/payloads/integer.h index ea8464a..b60cabe 100644 --- a/src/c/payloads/integer.h +++ b/src/c/payloads/integer.h @@ -27,5 +27,7 @@ struct integer_payload { struct pso_pointer make_integer( struct pso_pointer frame_pointer, int64_t value ); +struct pso_pointer acquire_integer( struct pso_pointer frame_pointer, + int64_t value ); #endif diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index 3a3fa70..34682ed 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -42,7 +42,6 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, va_list args; va_start( args, previous ); - struct pso4 *prev_frame = pointer_to_pso4( previous ); struct pso_pointer new_pointer = allocate( previous, STACKTAG, 4 ); struct pso4 *new_frame = pointer_to_pso4( new_pointer ); @@ -53,9 +52,9 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, arg_count, new_pointer.page, new_pointer.offset ); #endif - prev_frame->payload.stack_frame.previous = previous; if ( stackp( previous ) ) { + struct pso4 *prev_frame = pointer_to_pso4( previous ); new_frame->payload.stack_frame.depth = prev_frame->payload.stack_frame.depth + 1; new_frame->payload.stack_frame.env = @@ -193,8 +192,8 @@ struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer struct pso_pointer arg_length = length( make_frame( 1, previous, argvalues ) ); int arg_count = - integerp( arg_length ) ? pointer_to_object( arg_length )-> - payload.integer.value : 0; + integerp( arg_length ) ? pointer_to_object( arg_length )->payload. + integer.value : 0; #ifdef DEBUG debug_printf( DEBUG_ALLOC, 0, L"\nAllocating stack frame with %d arguments at page %d, " @@ -252,8 +251,8 @@ struct pso_pointer make_frame_with_arglist( struct pso_pointer previous, struct pso_pointer argvalues ) { return make_frame_with_arglist_and_env( previous, argvalues, pointer_to_pso4 - ( previous )->payload.stack_frame. - env ); + ( previous )->payload. + stack_frame.env ); } diff --git a/src/c/payloads/time.c b/src/c/payloads/time.c new file mode 100644 index 0000000..6dad3c2 --- /dev/null +++ b/src/c/payloads/time.c @@ -0,0 +1,57 @@ +/** + * payloads/time.c + * + * A time record. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include + + +#include "memory/tags.h" +#include "memory/pointer.h" +#include "memory/pso.h" +#include "memory/pso2.h" +#include "memory/tags.h" + +#include "payloads/integer.h" +#include "payloads/stack.h" +#include "payloads/time.h" + +#define _GNU_SOURCE + +#define seconds_per_year 31557600L + +/** + * PSSE Lisp epoch is 14 Bn years, or 441,806,400,000,000,000 seconds, before + * the UNIX epoch; the value in microseconds will break the C reader. + */ +unsigned __int128 epoch_offset = + ( ( __int128 ) ( seconds_per_year * 1000000000L ) * + ( __int128 ) ( 14L * 1000000000L ) ); + + +unsigned __int128 unix_time_to_lisp_time( time_t t ) { + unsigned __int128 result = epoch_offset + ( t * 1000000000 ); + + return result; +} + + +struct pso_pointer make_time( struct pso_pointer frame_pointer, + struct pso_pointer specification ) { + struct pso_pointer result = allocate( frame_pointer, TIMETAG, 2 ); + struct pso2 *cell = pointer_to_object( result ); + + if ( integerp( specification ) ) { + cell->payload.time.value = + pointer_to_object( specification )->payload.integer.value; + } else { + cell->payload.time.value = unix_time_to_lisp_time( time( NULL ) ); + } + + return result; +} diff --git a/src/c/payloads/time.h b/src/c/payloads/time.h index d808c0e..0890e8a 100644 --- a/src/c/payloads/time.h +++ b/src/c/payloads/time.h @@ -1,14 +1,14 @@ /** - * payloads/cons.h + * payloads/time.h * - * A cons cell. + * A timee record. * * (c) 2026 Simon Brooke * Licensed under GPL version 2.0, or, at your option, any later version. */ -#ifndef __psse_payloads_cons_h -#define __psse_payloads_cons_h +#ifndef __psse_payloads_time_h +#define __psse_payloads_time_h #include #include @@ -31,4 +31,7 @@ struct time_payload { unsigned __int128 value; }; +struct pso_pointer make_time( struct pso_pointer stack_frame, + struct pso_pointer time ); + #endif diff --git a/src/c/psse.c b/src/c/psse.c index 65e9196..a31b59e 100644 --- a/src/c/psse.c +++ b/src/c/psse.c @@ -78,12 +78,6 @@ int main( int argc, char *argv[] ) { bool show_prompt = false; char *infilename = NULL; - setlocale( LC_ALL, "" ); - if ( initialise_io( ) != 0 ) { - fputs( "Failed to initialise I/O subsystem\n", stderr ); - exit( 1 ); - } - while ( ( option = getopt( argc, argv, "dhi:ps:v:" ) ) != -1 ) { switch ( option ) { case 'd': @@ -114,6 +108,12 @@ int main( int argc, char *argv[] ) { } } + setlocale( LC_ALL, "" ); + if ( initialise_io( ) != 0 ) { + fputs( "Failed to initialise I/O subsystem\n", stderr ); + exit( 1 ); + } + oblist = initialise_node( 0 ); debug_print( L"Oblist: ", DEBUG_BOOTSTRAP, 0 ); debug_print_object( oblist, DEBUG_BOOTSTRAP, 0 );