From 9eb0d3c5a07a171d3506679d9c1b211712921ed1 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 1 Apr 2026 16:06:16 +0100 Subject: [PATCH] I think read will now read integers and symbols, but it's untested. Everything compiles. --- src/c/io/io.c | 40 +++++- src/c/io/io.h | 6 +- src/c/io/read.c | 180 ++++++++++++++++++++++++--- src/c/memory/destroy.c | 58 +++++++++ src/c/memory/destroy.h | 17 +++ src/c/memory/page.c | 7 ++ src/c/memory/pointer.c | 79 ++++++++++-- src/c/memory/pointer.h | 4 + src/c/memory/pso.c | 58 ++++++--- src/c/memory/pso.h | 232 +---------------------------------- src/c/memory/pso4.c | 17 +++ src/c/memory/pso4.h | 2 + src/c/memory/tags.h | 2 + src/c/ops/eq.c | 11 +- src/c/ops/reverse.c | 10 ++ src/c/payloads/character.c | 34 +++++ src/c/payloads/character.h | 3 +- src/c/payloads/cons.c | 17 +++ src/c/payloads/cons.h | 2 +- src/c/payloads/exception.c | 25 +++- src/c/payloads/exception.h | 3 + src/c/payloads/psse_string.c | 20 +++ src/c/payloads/psse_string.h | 3 + src/c/payloads/read_stream.c | 5 +- src/c/payloads/read_stream.h | 3 + src/c/payloads/stack.c | 30 ++++- src/c/payloads/stack.h | 3 + src/c/psse.c | 16 ++- 28 files changed, 594 insertions(+), 293 deletions(-) create mode 100644 src/c/memory/destroy.c create mode 100644 src/c/memory/destroy.h create mode 100644 src/c/memory/pso4.c create mode 100644 src/c/payloads/character.c diff --git a/src/c/io/io.c b/src/c/io/io.c index 5729504..a8cf105 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -46,6 +46,7 @@ #include "ops/string_ops.h" #include "ops/truth.h" +#include "payloads/character.h" #include "payloads/cons.h" #include "payloads/exception.h" #include "payloads/integer.h" @@ -81,7 +82,7 @@ wint_t ungotten = 0; * * @return 0 on success; any other value means failure. */ -int io_init( ) { +int initialise_io( ) { int result = curl_global_init( CURL_GLOBAL_SSL ); io_share = curl_share_init( ); @@ -252,6 +253,43 @@ 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`. + * + * @param c a pointer to an object which should be a character object; + * @param r a pointer to an object which should be a read stream object, + * + * @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; + + 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; +} /** * Function, sort-of: close the file indicated by my first arg, and return diff --git a/src/c/io/io.h b/src/c/io/io.h index 49a79da..c64114f 100644 --- a/src/c/io/io.h +++ b/src/c/io/io.h @@ -18,7 +18,7 @@ extern CURLSH *io_share; -int io_init( ); +int initialise_io( ); #define C_IO_IN L"*in*" #define C_IO_OUT L"*out*" @@ -30,6 +30,10 @@ 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); + struct pso_pointer get_default_stream( bool inputp, struct pso_pointer env ); struct pso_pointer diff --git a/src/c/io/read.c b/src/c/io/read.c index 9fd059e..7811bf1 100644 --- a/src/c/io/read.c +++ b/src/c/io/read.c @@ -23,16 +23,22 @@ #include #include "debug.h" -#include "memory/node.h" -#include "memory/pointer.h" -#include "memory/pso2.h" #include "io/io.h" #include "io/read.h" +#include "memory/node.h" +#include "memory/pointer.h" +#include "memory/pso2.h" +#include "memory/tags.h" #include "payloads/integer.h" -#include "ops/stack_ops.h" +#include "payloads/read_stream.h" +#include "ops/assoc.h" +#include "ops/reverse.h" +#include "ops/stack_ops.h" +#include "ops/string_ops.h" +#include "ops/truth.h" // TODO: what I've copied from 0.0.6 is *wierdly* over-complex for just now. // I think I'm going to essentially delete all this and start again. We need @@ -57,29 +63,167 @@ /** * An example wrapper function while I work out how I'm going to do this. + * + * For this and all other `read` functions unless documented otherwise, the + * arguments in the frame are expected to be: + * + * 0. The input stream to read from; + * 1. The read table currently in use; + * 2. The character most recently read from that stream. */ -struct pso_pointer read_example( struct pso4 *frame, - struct pso_pointer frame_pointer, +struct pso_pointer read_example( struct pso_pointer frame_pointer, struct pso_pointer env) { - struct pso_pointer character = fetch_arg( frame, 0); - struct pso_pointer stream = fetch_arg( frame, 1); - struct pso_pointer readtable = fetch_arg( frame, 2); + struct pso4 *frame = pointer_to_pso4( frame_pointer); + struct pso_pointer stream = fetch_arg( frame, 0); + struct pso_pointer readtable = fetch_arg( frame, 1); + struct pso_pointer character = fetch_arg( frame, 2); + struct pso_pointer result = nil; - return character; + return result; } - /** - * Read the next object on this input stream and return a pso_pointer to it. + * @brief Read one integer from the stream and return it. + * + * For this and all other `read` functions unless documented otherwise, the + * arguments in the frame are expected to be: + * + * 0. The input stream to read from; + * 1. The read table currently in use; + * 2. The character most recently read from that stream. */ -struct pso_pointer read( struct pso4 *frame, - struct pso_pointer frame_pointer, +struct pso_pointer read_number( struct pso_pointer frame_pointer, + struct pso_pointer env) { + struct pso4 *frame = pointer_to_pso4( frame_pointer); + struct pso_pointer stream = fetch_arg( frame, 0); + struct pso_pointer readtable = fetch_arg( frame, 1); + struct pso_pointer character = fetch_arg( frame, 2); + struct pso_pointer result = nil; + + int base = 10; + // TODO: should check for *read-base* in the environment + int64_t value = 0; + + if (readp(stream)) { + if (nilp( character)) { + character = get_character( stream); + } + wchar_t c = nilp(character) ? 0 : + pointer_to_object( character)->payload.character.character; + + URL_FILE * input = pointer_to_object(stream)->payload.stream.stream; + for ( ; iswdigit( c ); + c = url_fgetwc( input ) ){ + value = (value * base) + ((int)c - (int)L'0'); + } + + url_ungetwc( c, input); + result = make_integer( value); + } // else exception? + + return result; +} + +struct pso_pointer read_symbol( struct pso_pointer frame_pointer, + struct pso_pointer env) { + struct pso4 *frame = pointer_to_pso4( frame_pointer); + struct pso_pointer stream = fetch_arg( frame, 0); + struct pso_pointer readtable = fetch_arg( frame, 1); + struct pso_pointer character = fetch_arg( frame, 2); + struct pso_pointer result = nil; + + if (readp(stream)) { + if (nilp( character)) { + character = get_character( stream); + } + + wchar_t c = nilp(character) ? 0 : + pointer_to_object( character)->payload.character.character; + + URL_FILE * input = pointer_to_object(stream)->payload.stream.stream; + for ( ; iswalnum( c ); + c = url_fgetwc( input ) ){ + result = make_string_like_thing(c, result, SYMBOLTAG); + } + + url_ungetwc( c, input); + result = reverse( result); + } + + return result; +} + +/** + * @brief Read the next object on the input stream indicated by this stack + * frame, and return a pso_pointer to the object read. + * + * For this and all other `read` functions unless documented otherwise, the + * arguments in the frame are expected to be: + * + * 0. The input stream to read from; + * 1. The read table currently in use; + * 2. The character most recently read from that stream. + */ +struct pso_pointer read( struct pso_pointer frame_pointer, struct pso_pointer env ) { - struct pso_pointer* character = fetch_arg( frame, 0); - struct pso_pointer stream = fetch_arg( frame, 1); - struct pso_pointer readtable = fetch_arg( frame, 2); + struct pso4 *frame = pointer_to_pso4( frame_pointer); + struct pso_pointer stream = fetch_arg( frame, 0); + struct pso_pointer readtable = fetch_arg( frame, 1); + struct pso_pointer character = fetch_arg( frame, 2); + + struct pso_pointer result = nil; if (nilp(stream)) { - + stream = make_read_stream( file_to_url_file(stdin), nil); } + + if (nilp( readtable)) { + // TODO: check for the value of `*read-table*` in the environment and + // use that. + } + + if (nilp( character)) { + character = get_character( stream); + } + + struct pso_pointer readmacro = assoc(character, readtable); + + if (!nilp( readmacro)) { + // invoke the read macro on the stream + } else if (readp( stream) && characterp(character)) { + wchar_t c = pointer_to_object( character)->payload.character.character; + URL_FILE * input = pointer_to_object(stream)->payload.stream.stream; + + switch ( c ) { + case ';': + for ( c = url_fgetwc( input ); c != '\n'; + c = url_fgetwc( input ) ); + /* 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 ); + break; + default: + struct pso_pointer next = make_frame( frame_pointer, stream, readtable, make_character(c)); + if ( iswdigit( c ) ) { + result = + read_number( next, env ); + } else if ( iswalpha( c ) ) { + result = read_symbol( next, env ); + } else { +// result = +// throw_exception( c_string_to_lisp_symbol( L"read" ), +// make_cons( c_string_to_lisp_string +// ( L"Unrecognised start of input character" ), +// make_string( c, NIL ) ), +// frame_pointer ); + } + break; + } + } + + return result; } diff --git a/src/c/memory/destroy.c b/src/c/memory/destroy.c new file mode 100644 index 0000000..b497655 --- /dev/null +++ b/src/c/memory/destroy.c @@ -0,0 +1,58 @@ +/** + * memory/free.c + * + * Centralised point for despatching free methods to types. + * + * TODO: In the long run, we need a type for tags, which defines a constructor + * and a free method, along with the minimum and maximum size classes + * allowable for that tag; and we need a namespace in which tags are + * canonically stored, probably ::system:tags, in which the tag is bound to + * the type record describing it. And this all needs to work in Lisp, not + * in the substrate. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include "memory/node.h" +#include "memory/pointer.h" +#include "memory/pso.h" +#include "memory/tags.h" + +#include "payloads/cons.h" +#include "payloads/exception.h" +#include "payloads/stack.h" +#include "payloads/psse_string.h" + +/** + * @brief Despatch destroy message to the handler for the type of the + * object indicated by `p`, if there is one. What the destroy handler + * needs to do is dec_ref all the objects pointed to by it. + * + * The handler has 0.1.0 lisp calling convention, since + * 1. we should be able to write destroy handlers in Lisp; and + * 2. in the long run this whole system should be rewritten in Lisp. + * + * The handler returns `nil` on success, an exception pointer on + * failure. This function returns that exception pointer. How we + * handle that exception pointer I simply don't know yet. + */ +struct pso_pointer destroy( struct pso_pointer p) { + struct pso_pointer result = nil; + struct pso_pointer f = make_frame( nil, p); + inc_ref( f); + + switch (get_tag_value(p)) { + case CONSTV: destroy_cons(f, nil); break; + case EXCEPTIONTV: destroy_exception(f, nil); break; + case KEYTV : + case STRINGTV: + case SYMBOLTV: destroy_string(f, nil); break; + case STACKTV: destroy_stack_frame(f, nil); break; + // TODO: others. + } + + dec_ref(f); + return result; +} + diff --git a/src/c/memory/destroy.h b/src/c/memory/destroy.h new file mode 100644 index 0000000..ad2fc84 --- /dev/null +++ b/src/c/memory/destroy.h @@ -0,0 +1,17 @@ +/** + * memory/destroy.h + * + * Despatcher for destructor functions when objects are freed. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_destroy_h +#define __psse_memory_destroy_h + +#include "memory/pointer.h" + +struct pso_pointer destroy( struct pso_pointer p); + +#endif diff --git a/src/c/memory/page.c b/src/c/memory/page.c index c5c735e..0d60021 100644 --- a/src/c/memory/page.c +++ b/src/c/memory/page.c @@ -17,6 +17,7 @@ #include "memory/memory.h" #include "memory/node.h" #include "memory/page.h" +#include "memory/pso.h" #include "memory/pso2.h" #include "memory/pso3.h" #include "memory/pso4.h" @@ -124,6 +125,12 @@ struct pso_pointer allocate_page( uint8_t size_class ) { L"Initialised page %d; freelist for size class %x updated.\n", npages_allocated, size_class ); + if (npages_allocated == 0) { + // first page allocated; initialise nil and t + nil = lock_object( allocate(NILTAG, 2)); + t = lock_object( allocate(TRUETAG, 2)); + } + npages_allocated++; } else { // TODO: exception when we have one. diff --git a/src/c/memory/pointer.c b/src/c/memory/pointer.c index 8120e78..fb7c035 100644 --- a/src/c/memory/pointer.c +++ b/src/c/memory/pointer.c @@ -29,24 +29,35 @@ struct pso_pointer make_pointer( uint32_t node, uint16_t page, /** * @brief returns the in-memory address of the object indicated by this - * pointer. TODO: Yhe reason I'm doing it this way is because I'm not + * pointer `p`. + * + * NOTE THAT: It's impossible, with our calling conventions, to pass an + * exception back from this function. Consequently, if anything goes wrong + * we return NULL. The caller *should* check for that and throw an exception. + * + * NOTE THAT: The return signature of these functions is pso2, because it is + * safe to cast any paged space object to a pso2, but safe to cast an object + * of a smaller size class to a larger one. If you know what size class you + * want, you should prefer `pointer_to_object_of_size_class()`, q.v. + * + * TODO: The reason I'm doing it this way is because I'm not * certain reference counter updates work right it we work with 'the object' * rather than 'the address of the object'. I really ought to have a * conversation with someone who understands this bloody language. * - * @param pointer a pso_pointer which references an object. - * @return struct pso2* the actual address in memory of that object. + * @param p a pso_pointer which references an object. + * + * @return the actual address in memory of that object, or NULL if `p` is + * invalid. */ -struct pso2 *pointer_to_object( struct pso_pointer pointer ) { +struct pso2 *pointer_to_object( struct pso_pointer p ) { struct pso2 *result = NULL; - if ( pointer.node == node_index ) { - if (pointer.page < get_pages_allocated() && pointer.offset < (PAGE_BYTES / 8)) { + if ( p.node == node_index ) { + if (p.page < get_pages_allocated() && p.offset < (PAGE_BYTES / 8)) { // TODO: that's not really a safe test of whether this is a valid pointer. - union page *pg = pages[pointer.page]; - result = ( struct pso2 * ) &pg->words[pointer.offset]; - } else { - // TODO: throw bad pointer exception. + union page *pg = pages[p.page]; + result = ( struct pso2 * ) &pg->words[p.offset]; } } // TODO: else if we have a copy of the object in cache, return that; @@ -54,3 +65,51 @@ struct pso2 *pointer_to_object( struct pso_pointer pointer ) { return result; } + +/** + * @brief returns the memory address of the object indicated by this pointer + * `p`, if it is of this `size_class`. + * + * NOTE THAT: It's impossible, with our calling conventions, to pass an + * exception back from this function. Consequently, if anything goes wrong + * we return NULL. The caller *should* check for that and throw an exception. + * + * NOTE THAT: The return signature of these functions is pso2, because it is + * safe to cast any paged space object to a pso2, but safe to cast an object + * of a smaller size class to a larger one. You should check that the object + * returned has the size class you expect. + * + * @param p a pointer to an object; + * @param size_class a size class. + * + * @return the memory address of the object, provided it is a valid object and + * of the specified size class, else NULL. + */ +struct pso2 * pointer_to_object_of_size_class( struct pso_pointer p, uint8_t size_class) { + struct pso2 * result = pointer_to_object( p); + + if (result->header.tag.bytes.size_class != size_class) { + result = NULL; + } + + return result; +} + +/** + * @brief returns the memory address of the object indicated by this pointer + * `p`, if it has this `tag_value`. + * + * NOTE THAT: It's impossible, with our calling conventions, to pass an + * exception back from this function. Consequently, if anything goes wrong + * we return NULL. The caller *should* check for that and throw an exception. + */ +struct pso2 * pointer_to_object_with_tag_value( struct pso_pointer p, uint32_t tag_value) { + struct pso2 * result = pointer_to_object( p); + + if ((result->header.tag.value & 0xffffff) != tag_value) { + result = NULL; + } + + return result; +} + diff --git a/src/c/memory/pointer.h b/src/c/memory/pointer.h index 902fce2..b467f5e 100644 --- a/src/c/memory/pointer.h +++ b/src/c/memory/pointer.h @@ -43,4 +43,8 @@ struct pso_pointer make_pointer( uint32_t node, uint16_t page, uint16_t offset); struct pso2* pointer_to_object( struct pso_pointer pointer); +struct pso2 * pointer_to_object_of_size_class( struct pso_pointer p, uint8_t size_class); + +struct pso2 * pointer_to_object_with_tag_value( struct pso_pointer p, uint32_t tag_value); + #endif diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index a3a48e7..75df0d5 100644 --- a/src/c/memory/pso.c +++ b/src/c/memory/pso.c @@ -18,6 +18,7 @@ #include #include "debug.h" +#include "memory/destroy.h" #include "memory/header.h" #include "memory/memory.h" #include "memory/node.h" @@ -74,24 +75,6 @@ uint32_t payload_size( struct pso2 *object ) { sizeof( struct pso_header ) ); } -void free_cell( struct pso_pointer p ) { - struct pso2 *p2 = pointer_to_object( p ); - uint32_t array_size = payload_size( p2 ); - uint8_t size_class = p2->header.tag.bytes.size_class; - - strncpy( ( char * ) ( p2->header.tag.bytes.mnemonic ), FREETAG, - TAGLENGTH ); - - /* will C just let me cheerfully walk off the end of the array I've declared? */ - for ( int i = 0; i < array_size; i++ ) { - p2->payload.words[i] = 0; - } - - /* TODO: obtain mutex on freelist */ - p2->payload.free.next = freelists[size_class]; - freelists[size_class] = p; -} - /** * increment the reference count of the object at this cons pointer. * @@ -153,7 +136,7 @@ struct pso_pointer dec_ref( struct pso_pointer pointer ) { #endif if ( object->header.count == 0 ) { - free_cell( pointer ); + free_object( pointer ); pointer = nil; } } @@ -165,11 +148,46 @@ struct pso_pointer dec_ref( struct pso_pointer pointer ) { * @brief Prevent an object ever being dereferenced. * * @param pointer pointer to an object to lock. + * + * @return the `pointer` */ -void lock_object( struct pso_pointer pointer ) { +struct pso_pointer lock_object( struct pso_pointer pointer ) { struct pso2 *object = pointer_to_object( pointer ); object->header.count = MAXREFERENCE; + + return pointer; } +/** + * @brief decrement all pointers pointed to by the object at this pointer; + * clear its memory, and return it to the freelist. + */ +struct pso_pointer free_object( struct pso_pointer p ) { + struct pso_pointer result = nil; + struct pso2 *obj = pointer_to_object( p ); + uint32_t array_size = payload_size( obj ); + uint8_t size_class = obj->header.tag.bytes.size_class; + result = destroy( p); + + /* will C just let me cheerfully walk off the end of the array I've declared? */ + for ( int i = 0; i < array_size; i++ ) { + obj->payload.words[i] = 0; + } + + + + strncpy( ( char * ) ( obj->header.tag.bytes.mnemonic ), FREETAG, + TAGLENGTH ); +#ifdef DEBUG + debug_printf( DEBUG_ALLOC, 0, L"Freeing object of size class %d at {%d, %d, %d}", + size_class, p.node, p.page, p.offset); +#endif + + /* TODO: obtain mutex on freelist */ + obj->payload.free.next = freelists[size_class]; + freelists[size_class] = p; + + return result; +} diff --git a/src/c/memory/pso.h b/src/c/memory/pso.h index 3d74fe7..5e5f308 100644 --- a/src/c/memory/pso.h +++ b/src/c/memory/pso.h @@ -14,234 +14,6 @@ #include "memory/header.h" #include "memory/pointer.h" -// #include "payloads/cons.h" -// #include "payloads/exception.h" -// #include "payloads/free.h" -// #include "payloads/function.h" -// #include "payloads/hashtable.h" -// #include "payloads/integer.h" -// #include "payloads/keyword.h" -// #include "payloads/lambda.h" -// #include "payloads/mutex.h" -// #include "payloads/namespace.h" -// #include "payloads/nlambda.h" -// #include "payloads/read_stream.h" -// #include "payloads/special.h" -// #include "payloads/stack.h" -// #include "payloads/string.h" -// #include "payloads/symbol.h" -// #include "payloads/time.h" -// #include "payloads/vector_pointer.h" -// #include "payloads/write_stream.h" - -// /** -// * @brief A paged space object of size class 2, four words total, two words -// * payload. -// * -// */ -// struct pso2 { -// struct pso_header header; -// union { -// char bytes[16]; -// uint64_t words[2]; -// struct cons_payload cons; -// struct free_payload free; -// struct function_payload function; -// struct integer_payload integer; -// struct lambda_payload lambda; -// struct special_payload special; -// struct stream_payload stream; -// struct time_payload time; -// struct vectorp_payload vectorp; -// } payload; -// }; - -// /** -// * @brief A paged space object of size class 3, 8 words total, 6 words -// * payload. -// * -// */ -// struct pso3 { -// struct pso_header header; -// union { -// char bytes[48]; -// uint64_t words[6]; -// struct exception_payload exception; -// struct free_payload free; -// struct mutex_payload mutex; -// } payload; -// }; - -// /** -// * @brief A paged space object of size class 4, 16 words total, 14 words -// * payload. -// * -// */ -// struct pso4 { -// struct pso_header header; -// union { -// char bytes[112]; -// uint64_t words[14]; -// struct free_payload free; -// struct stack_frame_payload stack_frame; -// } payload; -// }; - -// /** -// * @brief A paged space object of size class 5, 32 words total, 30 words -// * payload. -// * -// */ -// struct pso5 { -// struct pso_header header; -// union { -// char bytes[240]; -// uint64_t words[30]; -// struct free_payload free; -// } payload; -// }; - -// /** -// * @brief A paged space object of size class 6, 64 words total, 62 words -// * payload. -// * -// */ -// struct pso6 { -// struct pso_header header; -// union { -// char bytes[496]; -// uint64_t words[62]; -// struct free_payload free; -// struct hashtable_payload hashtable; -// struct namespace_payload namespace; -// } payload; -// }; - -// /** -// * @brief A paged space object of size class 7, 128 words total, 126 words -// * payload. -// * -// */ -// struct pso7 { -// struct pso_header header; -// union { -// char bytes[1008]; -// uint64_t words[126]; -// struct free_payload free; -// } payload; -// }; - -// /** -// * @brief A paged space object of size class 8, 256 words total, 254 words -// * payload. -// * -// */ -// struct pso8 { -// struct pso_header header; -// union { -// char bytes[2032]; -// uint64_t words[254]; -// struct free_payload free; -// } payload; -// }; - -// /** -// * @brief A paged space object of size class 9, 512 words total, 510 words -// * payload. -// * -// */ -// struct pso9 { -// struct pso_header header; -// union { -// char bytes[4080]; -// uint64_t words[510]; -// struct free_payload free; -// } payload; -// }; - -// /** -// * @brief A paged space object of size class a, 1024 words total, 1022 words -// * payload. -// * -// */ -// struct psoa { -// struct pso_header header; -// union { -// char bytes[8176]; -// uint64_t words[1022]; -// struct free_payload free; -// } payload; -// }; - -// /** -// * @brief A paged space object of size class b, 2048 words total, 2046 words -// * payload. -// * -// */ -// struct psob { -// struct pso_header header; -// union { -// char bytes[16368]; -// uint64_t words[2046]; -// struct free_payload free; -// } payload; -// }; - -// /** -// * @brief A paged space object of size class c, 4096 words total, 4094 words -// * payload. -// * -// */ -// struct psoc { -// struct pso_header header; -// union { -// char bytes[32752]; -// uint64_t words[4094]; -// struct free_payload free; -// } payload; -// }; - -// /** -// * @brief A paged space object of size class d, 8192 words total, 8190 words -// * payload. -// * -// */ -// struct psod { -// struct pso_header header; -// union { -// char bytes[65520]; -// uint64_t words[8190]; -// struct free_payload free; -// } payload; -// }; - -// /** -// * @brief A paged space object of size class e, 16384 words total, 16382 words -// * payload. -// * -// */ -// struct psoe { -// struct pso_header header; -// union { -// char bytes[131056]; -// uint64_t words[16382]; -// struct free_payload free; -// } payload; -// }; - -// /** -// * @brief A paged space object of size class f, 32768 words total, 32766 words -// * payload. -// * -// */ -// struct psof { -// struct pso_header header; -// union { -// char bytes[262128]; -// uint64_t words[32766]; -// struct free_payload free; -// } payload; -// }; struct pso_pointer allocate( char* tag, uint8_t size_class); @@ -249,8 +21,8 @@ struct pso_pointer dec_ref( struct pso_pointer pointer ); struct pso_pointer inc_ref( struct pso_pointer pointer ); -void lock_object( struct pso_pointer pointer); +struct pso_pointer lock_object( struct pso_pointer pointer); -// uint32_t get_tag_value( struct pso_pointer pointer); +struct pso_pointer free_object( struct pso_pointer p ); #endif diff --git a/src/c/memory/pso4.c b/src/c/memory/pso4.c new file mode 100644 index 0000000..fd604d5 --- /dev/null +++ b/src/c/memory/pso4.c @@ -0,0 +1,17 @@ +/** + * memory/pso4.h + * + * Paged space object of size class 4, 16 words total, 14 words payload. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include "memory/pointer.h" +#include "memory/pso.h" +#include "memory/pso2.h" +#include "memory/pso4.h" + +struct pso4* pointer_to_pso4( struct pso_pointer p) { + struct pso4* result = (struct pso4*)pointer_to_object_of_size_class( p, 4); +} diff --git a/src/c/memory/pso4.h b/src/c/memory/pso4.h index 9ffc337..819f272 100644 --- a/src/c/memory/pso4.h +++ b/src/c/memory/pso4.h @@ -31,4 +31,6 @@ struct pso4 { } payload; }; +struct pso4* pointer_to_pso4( struct pso_pointer p); + #endif diff --git a/src/c/memory/tags.h b/src/c/memory/tags.h index a6f4218..e152bd2 100644 --- a/src/c/memory/tags.h +++ b/src/c/memory/tags.h @@ -98,6 +98,7 @@ bool check_tag( struct pso_pointer p, uint32_t v); bool check_type( struct pso_pointer p, char* s); +#define characterp(p) (check_tag(p, CHARACTERTV)) #define consp(p) (check_tag(p, CONSTV)) #define exceptionp(p) (check_tag(p, EXCEPTIONTV)) #define freep(p) (check_tag(p, FREETV)) @@ -116,6 +117,7 @@ bool check_type( struct pso_pointer p, char* s); #define realp(p) (check_tag(p,REALTV)) #define sequencep(p) (check_tag(p,CONSTV)||check_tag(p,STRINGTV)||check_tag(p,SYMBOLTV)) #define specialp(p) (check_tag(p,SPECIALTV)) +#define stackp(p) (check_tag(p, STACKTV)) #define streamp(p) (check_tag(p,READTV)||check_tag(p,WRITETV)) #define stringp(p) (check_tag(p,STRINGTV)) #define symbolp(p) (check_tag(p,SYMBOLTV)) diff --git a/src/c/ops/eq.c b/src/c/ops/eq.c index ed274f9..271e2a5 100644 --- a/src/c/ops/eq.c +++ b/src/c/ops/eq.c @@ -43,13 +43,20 @@ bool equal( struct pso_pointer a, struct pso_pointer b) { if ( eq( a, b)) { result = true; } else if ( get_tag_value(a) == get_tag_value(b)) { + struct pso2 *oa = pointer_to_object(a); + struct pso2 *ob = pointer_to_object(b); + switch ( get_tag_value(a)) { + case CHARACTERTV : + result = (oa->payload.character.character == ob->payload.character.character); + break; case CONSTV : result = (equal( car(a), car(b)) && equal( cdr(a), cdr(b))); break; case INTEGERTV : - result = (pointer_to_object(a)->payload.integer.value == - pointer_to_object(b)->payload.integer.value); + result = (oa->payload.integer.value + == + ob->payload.integer.value); break; case KEYTV: case STRINGTV : diff --git a/src/c/ops/reverse.c b/src/c/ops/reverse.c index 1b70342..186af0b 100644 --- a/src/c/ops/reverse.c +++ b/src/c/ops/reverse.c @@ -25,6 +25,16 @@ #include "ops/string_ops.h" #include "ops/truth.h" +/** + * @brief reverse a sequence. + * + * A sequence is a list or a string-like-thing. A dotted pair is not a + * sequence. + * + * @param sequence a pointer to a sequence. + * @return a sequence like the `sequence` passed, but reversed; or `nil` if + * the argument was not a sequence. + */ struct pso_pointer reverse( struct pso_pointer sequence) { struct pso_pointer result = nil; diff --git a/src/c/payloads/character.c b/src/c/payloads/character.c new file mode 100644 index 0000000..124053a --- /dev/null +++ b/src/c/payloads/character.c @@ -0,0 +1,34 @@ +/** + * payloads/character.c + * + * A character object. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +/* + * wide characters + */ +#include +#include + +#include "memory/node.h" +#include "memory/pointer.h" +#include "memory/pso.h" +#include "memory/pso2.h" +#include "memory/tags.h" + +#include "ops/truth.h" + +#include "payloads/character.h" + +struct pso_pointer make_character( wint_t c) { + struct pso_pointer result = allocate( CHARACTERTAG, 2 ); + + if (!nilp(result)) { + pointer_to_object(result)->payload.character.character = (wchar_t) c; + } + + return result; +} diff --git a/src/c/payloads/character.h b/src/c/payloads/character.h index 81a6dfa..854cc13 100644 --- a/src/c/payloads/character.h +++ b/src/c/payloads/character.h @@ -36,4 +36,5 @@ struct character_payload { wchar_t character; }; -#endif \ No newline at end of file +struct pso_pointer make_character( wint_t c); +#endif diff --git a/src/c/payloads/cons.c b/src/c/payloads/cons.c index 8fde4b4..5da54bc 100644 --- a/src/c/payloads/cons.c +++ b/src/c/payloads/cons.c @@ -13,6 +13,7 @@ #include "memory/pointer.h" #include "memory/pso.h" #include "memory/pso2.h" +#include "memory/pso4.h" #include "memory/tags.h" #include "payloads/cons.h" @@ -89,3 +90,19 @@ struct pso_pointer cdr( struct pso_pointer p ) { return result; } + +/** + * @brief When a cons cell is freed, its car and cdr pointers must be + * decremented. + * + * Lisp calling conventions; one expected arg, the pointer to the cell to + * be destroyed. + */ +struct pso_pointer destroy_cons( struct pso_pointer fp, struct pso_pointer env) { + if (stackp(fp)) { + struct pso4 *frame = pointer_to_pso4( fp); + struct pso_pointer p = frame->payload.stack_frame.arg[0]; + dec_ref( car( p)); + dec_ref( cdr( p)); + } +} diff --git a/src/c/payloads/cons.h b/src/c/payloads/cons.h index b66ce7c..8649d13 100644 --- a/src/c/payloads/cons.h +++ b/src/c/payloads/cons.h @@ -32,6 +32,6 @@ struct pso_pointer cdr( struct pso_pointer cons ); struct pso_pointer cons( struct pso_pointer car, struct pso_pointer cdr ); -bool consp( struct pso_pointer ptr ); +struct pso_pointer destroy_cons( struct pso_pointer fp, struct pso_pointer env); #endif diff --git a/src/c/payloads/exception.c b/src/c/payloads/exception.c index a732610..e29e684 100644 --- a/src/c/payloads/exception.c +++ b/src/c/payloads/exception.c @@ -11,10 +11,31 @@ #include "memory/node.h" #include "memory/pointer.h" #include "memory/pso.h" +#include "memory/pso4.h" +#include "memory/tags.h" #include "payloads/exception.h" -struct pso_pointer make_exception( struct pso_pointer message, struct pso_pointer frame_pointer, struct pso_pointer cause) { +struct pso_pointer make_exception( struct pso_pointer message, + struct pso_pointer frame_pointer, struct pso_pointer cause) { // TODO: not yet implemented return nil; -} \ No newline at end of file +} + +/** + * @brief When an exception is freed, all its pointers must be decremented. + * + * Lisp calling conventions; one expected arg, the pointer to the object to + * be destroyed. + */ +struct pso_pointer destroy_exception( struct pso_pointer fp, + struct pso_pointer env) { + if (stackp(fp)) { + struct pso4 *frame = pointer_to_pso4( fp); + struct pso_pointer p = frame->payload.stack_frame.arg[0]; + + // TODO: decrement every pointer indicated by an exception. + } + + return nil; +} diff --git a/src/c/payloads/exception.h b/src/c/payloads/exception.h index bb1777f..a0514e1 100644 --- a/src/c/payloads/exception.h +++ b/src/c/payloads/exception.h @@ -27,4 +27,7 @@ struct exception_payload { struct pso_pointer make_exception( struct pso_pointer message, struct pso_pointer frame_pointer, struct pso_pointer cause); +struct pso_pointer destroy_exception( struct pso_pointer fp, + struct pso_pointer env); + #endif diff --git a/src/c/payloads/psse_string.c b/src/c/payloads/psse_string.c index 21753c8..e998cc3 100644 --- a/src/c/payloads/psse_string.c +++ b/src/c/payloads/psse_string.c @@ -18,8 +18,28 @@ #include "memory/node.h" #include "memory/pointer.h" +#include "memory/pso.h" #include "memory/pso2.h" +#include "memory/pso4.h" #include "memory/tags.h" #include "ops/string_ops.h" #include "ops/truth.h" + +/** + * @brief When an string is freed, its cdr pointer must be decremented. + * + * Lisp calling conventions; one expected arg, the pointer to the object to + * be destroyed. + */ +struct pso_pointer destroy_string( struct pso_pointer fp, + struct pso_pointer env) { + if (stackp(fp)) { + struct pso4 *frame = pointer_to_pso4( fp); + struct pso_pointer p = frame->payload.stack_frame.arg[0]; + + dec_ref( cdr(p)); + } + + return nil; +} diff --git a/src/c/payloads/psse_string.h b/src/c/payloads/psse_string.h index 9af3e78..7997a1a 100644 --- a/src/c/payloads/psse_string.h +++ b/src/c/payloads/psse_string.h @@ -35,4 +35,7 @@ struct string_payload { struct pso_pointer make_string( wint_t c, struct pso_pointer tail ); +struct pso_pointer destroy_string( struct pso_pointer fp, + struct pso_pointer env); + #endif diff --git a/src/c/payloads/read_stream.c b/src/c/payloads/read_stream.c index c710ba0..b70d41b 100644 --- a/src/c/payloads/read_stream.c +++ b/src/c/payloads/read_stream.c @@ -13,6 +13,9 @@ #include "io/fopen.h" #include "memory/pointer.h" +#include "memory/pso.h" +#include "memory/pso2.h" +#include "memory/tags.h" /** @@ -23,7 +26,7 @@ */ struct pso_pointer make_read_stream( URL_FILE *input, struct pso_pointer metadata ) { - struct pso_pointer pointer = allocate( READTV, 2); + struct pso_pointer pointer = allocate( READTAG, 2); struct pso2 *cell = pointer_to_object( pointer ); cell->payload.stream.stream = input; diff --git a/src/c/payloads/read_stream.h b/src/c/payloads/read_stream.h index bb0e000..47167c2 100644 --- a/src/c/payloads/read_stream.h +++ b/src/c/payloads/read_stream.h @@ -29,4 +29,7 @@ struct stream_payload { struct pso_pointer meta; }; +struct pso_pointer make_read_stream( URL_FILE *input, + struct pso_pointer metadata ); + #endif diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index 7008b20..aeef298 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -44,7 +44,7 @@ struct pso_pointer make_frame( struct pso_pointer previous, ...) { for ( ; cursor < count && cursor < args_in_frame; cursor++) { struct pso_pointer argument = va_arg( args, struct pso_pointer); - frame->payload.stack_frame.arg[cursor] = argument; + frame->payload.stack_frame.arg[cursor] = inc_ref( argument); } if ( cursor < count) { struct pso_pointer more_args = nil; @@ -64,3 +64,31 @@ struct pso_pointer make_frame( struct pso_pointer previous, ...) { return frame_pointer; } + +/** + * @brief When a stack frame is freed, all its pointers must be decremented. + * + * Lisp calling conventions; one expected arg, the pointer to the object to + * be destroyed. + */ +struct pso_pointer destroy_stack_frame( struct pso_pointer fp, + struct pso_pointer env) { + if (stackp(fp)) { + struct pso4 *frame = pointer_to_pso4( fp); + struct pso4 * casualty = + pointer_to_pso4( frame->payload.stack_frame.arg[0]); + + dec_ref( casualty->payload.stack_frame.previous); + dec_ref( casualty->payload.stack_frame.function); + dec_ref( casualty->payload.stack_frame.more); + + for (int i = 0; i < args_in_frame; i++) { + dec_ref( casualty->payload.stack_frame.arg[0]); + } + + casualty->payload.stack_frame.args = 0; + casualty->payload.stack_frame.depth = 0; + } + + return nil; +} diff --git a/src/c/payloads/stack.h b/src/c/payloads/stack.h index a43b1e8..a2840ad 100644 --- a/src/c/payloads/stack.h +++ b/src/c/payloads/stack.h @@ -39,4 +39,7 @@ struct stack_frame_payload { struct pso_pointer make_frame( struct pso_pointer previous, ...); +struct pso_pointer destroy_stack_frame( struct pso_pointer fp, + struct pso_pointer env); + #endif diff --git a/src/c/psse.c b/src/c/psse.c index fc1293b..3b95d7e 100644 --- a/src/c/psse.c +++ b/src/c/psse.c @@ -13,8 +13,11 @@ */ #include "psse.h" +#include "io/io.h" #include "memory/node.h" + #include "ops/stack_ops.h" +#include "ops/truth.h" void print_banner( ) { fwprintf( stdout, L"Post-Scarcity Software Environment version %s\n\n", @@ -63,10 +66,10 @@ int main( int argc, char *argv[] ) { char *infilename = NULL; setlocale( LC_ALL, "" ); - // if ( io_init( ) != 0 ) { - // fputs( "Failed to initialise I/O subsystem\n", stderr ); - // exit( 1 ); - // } + 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 ) { @@ -98,7 +101,10 @@ int main( int argc, char *argv[] ) { } } - initialise_node( 0 ); + if ( nilp( initialise_node( 0 ))) { + fputs( "Failed to initialise node\n", stderr ); + exit( 1 ); + } // repl( );