From c9f50572ab7f011d92c75b675a36336479fb74a2 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 15 Apr 2026 19:50:10 +0100 Subject: [PATCH 1/4] Many more ops written, and it compiles. Nothing works yet. --- docs/Compiler.md | 2 +- docs/State-of-play.md | 76 ++++++++++++++++++++++++++++++++++++ src/c/io/io.c | 21 +++++----- src/c/io/print.c | 2 +- src/c/io/read.c | 2 +- src/c/ops/assoc.c | 72 ++++++++++++++++++++++++++++++---- src/c/ops/assoc.h | 8 ++-- src/c/ops/bind.c | 17 ++++++-- src/c/ops/bind.h | 11 ++++-- src/c/ops/eq.c | 53 ++++++++++++++++++++----- src/c/ops/eq.h | 20 ++++++++++ src/c/ops/reverse.c | 6 ++- src/c/payloads/cons.c | 13 +++--- src/c/payloads/cons.h | 6 +-- src/c/payloads/function.h | 44 ++++++++++++++------- src/c/payloads/psse_string.c | 2 +- src/c/payloads/stack.c | 6 ++- 17 files changed, 290 insertions(+), 71 deletions(-) diff --git a/docs/Compiler.md b/docs/Compiler.md index e6c8c3e..2894e4f 100644 --- a/docs/Compiler.md +++ b/docs/Compiler.md @@ -67,7 +67,7 @@ That's the list of things I've found so far that look useful to me. If I find ot ### Tag location -Objects in Lisp have to know that they are. This is what makes it possible to compute with an 'untyped' language: the type is not encoded in the program but in the data. In most conventional Lisp systems, things are typed by having a tag. Back in the day, when we had hardware specially built to run Lisp, Lisp specific hardware often had a word size — and thus registers, and a data bus — wider than the address bus, wider by the number of bits in the tag, and stored the tag on the pointer. +Objects in Lisp have to know what they are. This is what makes it possible to compute with an 'untyped' language: the type is not encoded in the program but in the data. In most conventional Lisp systems, things are typed by having a tag. Back in the day, when we had hardware specially built to run Lisp, Lisp specific hardware often had a word size — and thus registers, and a data bus — wider than the address bus, wider by the number of bits in the tag, and stored the tag on the pointer. Modern Lisps still, I think, mostly store the tag on the pointer, but they run on commodity hardware which doesn't have those extra bits in the word size. That means that the size of an integer, or the precision of a real, that you can store in one word of memory is much less. It also means either that they can address much less memory than other programming languages on the same hardware, because for every bit you steal out of the address bus you halve the amount of memory you can address; or else that they bit shift up every address before they fetch it. diff --git a/docs/State-of-play.md b/docs/State-of-play.md index 45d553d..f6985aa 100644 --- a/docs/State-of-play.md +++ b/docs/State-of-play.md @@ -1,5 +1,81 @@ # State of Play +## 20260415 + +OK, I have been diverted down a side-project on a side-project. I decided +that since Post Scarcity definitely needs a compiler, I should learn to write +a compiler, and so I should start by writing one for a simpler Lisp than Post +Scarcity. So I started to write +[one in Guile Scheme for Beowulf](https://git.journeyman.cc/simon/naegling). +This is started but a long way from finished. I'm also not very enamoured of +Guile Scheme, and am starting to wonder whether in fact I should be writing +if in [Beowulf](https://git.journeyman.cc/simon/beowulf) for Beowulf. + +I do believe I can complete the Naegling/Beowulf compiler, and that having +written it, I can write a Post Scarcity compiler in Post Scarcity. But to do +that I still need to have to have at least all of + +* apply +* assoc +* bind! (or put! or set!, but I *think* I prefer `bind!`) +* car +* cdr +* cons +* cond +* eq? +* equal? +* eval +* λ +* nil +* print +* read +* t + +and, essentially, have all the parts of a working REPL. + +My brain is not working very well at present; I can't do more than a very few +hours of focussed work a day, and jumping between Naegling and Post Scarcity +is probably not a good plan; but in periods when I need to do thinking about +where I'm going with Naegling I may switch to Post Scarcity (and vice versa). + +### Standard signature for compiled functions + +While I'm on this, I'm wondering whether I've got the standard signature for +compiled functions right. What we've inherited from the `0.0.X` branch is +documented as: + +```c + /** + * pointer to a function which takes a cons pointer (representing + * its argument list) and a cons pointer (representing its environment) and a + * stack frame (representing the previous stack frame) as arguments and returns + * a cons pointer (representing its result). + * \todo check this documentation is current! + */ + struct cons_pointer ( *executable ) ( struct stack_frame *, + struct cons_pointer, + struct cons_pointer ); +``` + +But actually the documentation here is wrong, because what we actually pass +is a C pointer to a stack frame object (which in `0.0.X` is in vector space), +a cons pointer to the cons space object which is the vector pointer to that +stack frame, and a cons pointer to the environment. + +We definitely don't need to pass a pointer to the argument list (and in fact +we didn't before, the documentation is *wrong*); we also don't need to pass +both a C pointer and a cons pointer to the frame, since the frame is now in +paged space, so passing our managed pointer is enough. + +It *might be* that passing both an unmanaged and a managed pointer is worth +doing, since recovering the managed pointer from the unmanaged pointer is +very expensive, and while recovering the unmanaged pointer from the +managed pointer is cheap, it isn't free. + +But it's worth thinking about. + + + ## 20260331 Substrate layer `print` is written; all the building blocks for substrate diff --git a/src/c/io/io.c b/src/c/io/io.c index e9b40e1..3f31d2c 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -114,7 +114,7 @@ char *lisp_string_to_c_string( struct pso_pointer s ) { if ( stringp( s ) || symbolp( s ) ) { int len = 0; - for ( struct pso_pointer c = s; !nilp( c ); c = cdr( c ) ) { + for ( struct pso_pointer c = s; !nilp( c ); c = c_cdr( c ) ) { len++; } @@ -123,7 +123,7 @@ char *lisp_string_to_c_string( struct pso_pointer s ) { result = calloc( ( len * 4 ) + 1, sizeof( char ) ); int i = 0; - for ( struct pso_pointer c = s; !nilp( c ); c = cdr( c ) ) { + for ( struct pso_pointer c = s; !nilp( c ); c = c_cdr( c ) ) { buffer[i++] = pointer_to_object( c )->payload.string.character; } @@ -286,8 +286,8 @@ struct pso_pointer push_back_character( struct pso_pointer c, 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; @@ -315,8 +315,8 @@ lisp_close( struct pso_pointer frame_pointer, struct pso_pointer env ) { 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; } @@ -328,8 +328,7 @@ lisp_close( struct pso_pointer frame_pointer, struct pso_pointer env ) { struct pso_pointer add_meta_integer( struct pso_pointer meta, wchar_t *key, long int value ) { return - cons( cons - ( c_string_to_lisp_keyword( key ), + c_cons( c_cons( c_string_to_lisp_keyword( key ), make_integer( value ) ), meta ); } @@ -339,7 +338,7 @@ struct pso_pointer add_meta_string( struct pso_pointer meta, wchar_t *key, wchar_t buffer[strlen( value ) + 1]; mbstowcs( buffer, value, strlen( value ) + 1 ); - return cons( cons( c_string_to_lisp_keyword( key ), + return c_cons( c_cons( c_string_to_lisp_keyword( key ), c_string_to_lisp_string( buffer ) ), meta ); } @@ -570,8 +569,8 @@ lisp_read_char( struct pso_pointer frame_pointer, struct pso_pointer env ) { if ( readp( fetch_arg( frame, 0 ) ) ) { result = make_string( url_fgetwc - ( pointer_to_object( fetch_arg( frame, 0 ) )->payload. - stream.stream ), nil ); + ( pointer_to_object( fetch_arg( frame, 0 ) )-> + payload.stream.stream ), nil ); } return result; diff --git a/src/c/io/print.c b/src/c/io/print.c index e56babf..e22d48b 100644 --- a/src/c/io/print.c +++ b/src/c/io/print.c @@ -42,7 +42,7 @@ struct pso_pointer print_list_content( struct pso_pointer p, URL_FILE *output ) struct pso_pointer result = nil; if ( consp( p ) ) { - for ( ; consp( p ); p = cdr( p ) ) { + for ( ; consp( p ); p = c_cdr( p ) ) { struct pso2 *object = pointer_to_object( p ); result = in_print( object->payload.cons.car, output ); diff --git a/src/c/io/read.c b/src/c/io/read.c index 71c96f8..f49368d 100644 --- a/src/c/io/read.c +++ b/src/c/io/read.c @@ -185,7 +185,7 @@ struct pso_pointer read( struct pso_pointer frame_pointer, character = get_character( stream ); } - struct pso_pointer readmacro = assoc( character, readtable ); + struct pso_pointer readmacro = c_assoc( character, readtable ); if ( !nilp( readmacro ) ) { // invoke the read macro on the stream diff --git a/src/c/ops/assoc.c b/src/c/ops/assoc.c index b1d6acb..004fa3e 100644 --- a/src/c/ops/assoc.c +++ b/src/c/ops/assoc.c @@ -19,6 +19,7 @@ #include "payloads/cons.h" #include "ops/eq.h" +#include "ops/stack_ops.h" #include "ops/truth.h" /** @@ -40,12 +41,12 @@ struct pso_pointer search( struct pso_pointer key, if ( consp( store ) ) { for ( struct pso_pointer cursor = store; - consp( store ) && found == false; cursor = cdr( cursor ) ) { - struct pso_pointer pair = car( cursor ); + consp( store ) && found == false; cursor = c_cdr( cursor ) ) { + struct pso_pointer pair = c_car( cursor ); - if ( consp( pair ) && c_equal( car( pair ), key ) ) { + if ( consp( pair ) && c_equal( c_car( pair ), key ) ) { found = true; - result = return_key ? car( pair ) : cdr( pair ); + result = return_key ? c_car( pair ) : c_cdr( pair ); } } } @@ -61,7 +62,7 @@ struct pso_pointer search( struct pso_pointer key, * * @return a pointer to the value of the key in the store, or nil if not found */ -struct pso_pointer assoc( struct pso_pointer key, struct pso_pointer store ) { +struct pso_pointer c_assoc( struct pso_pointer key, struct pso_pointer store ) { return search( key, store, false ); } @@ -73,7 +74,7 @@ struct pso_pointer assoc( struct pso_pointer key, struct pso_pointer store ) { * * @return a pointer to the copy of the key in the store, or nil if not found. */ -struct pso_pointer interned( struct pso_pointer key, struct pso_pointer store ) { +struct pso_pointer c_interned( struct pso_pointer key, struct pso_pointer store ) { return search( key, store, true ); } @@ -85,6 +86,63 @@ struct pso_pointer interned( struct pso_pointer key, struct pso_pointer store ) * * @return `true` if a pointer the key was found in the store.. */ -bool internedp( struct pso_pointer key, struct pso_pointer store ) { +bool c_internedp( struct pso_pointer key, struct pso_pointer store ) { return !nilp( search( key, store, true ) ); } + +/** + * @prief: bootstap layer assoc; Lisp calling signature. + * + * @return a pointer to the value of the key in the store, or nil if not found + */ +struct pso_pointer assoc( +#ifndef MANAGED_POINTER_ONLY + struct pso4 * frame, +#endif + struct pso_pointer frame_pointer, struct pso_pointer env) { +#ifdef MANAGED_POINTER_ONLY + struct pso4 *frame = pointer_to_pso4( frame_pointer ); +#endif + struct pso_pointer key = fetch_arg( frame, 0 ); + struct pso_pointer store = fetch_arg( frame, 1 ); + + return c_assoc( key, store ); +} + +/** + * @prief: bootstap layer interned; Lisp calling signature. + * + * @return a pointer to the copy of the key in the store, or nil if not found. + */ +struct pso_pointer interned( +#ifndef MANAGED_POINTER_ONLY + struct pso4 * frame, +#endif + struct pso_pointer frame_pointer, struct pso_pointer env) { +#ifdef MANAGED_POINTER_ONLY + struct pso4 *frame = pointer_to_pso4( frame_pointer ); +#endif + struct pso_pointer key = fetch_arg( frame, 0 ); + struct pso_pointer store = fetch_arg( frame, 1 ); + + return c_interned( key, store ); +} + +/** + * @prief: bootstap layer interned?; Lisp calling signature. + * + * @return `t` if a pointer to a copy of `key` is found in the store, or `nil` if not found. + */ +struct pso_pointer internedp( +#ifndef MANAGED_POINTER_ONLY + struct pso4 * frame, +#endif + struct pso_pointer frame_pointer, struct pso_pointer env) { +#ifdef MANAGED_POINTER_ONLY + struct pso4 *frame = pointer_to_pso4( frame_pointer ); +#endif + struct pso_pointer key = fetch_arg( frame, 0 ); + struct pso_pointer store = fetch_arg( frame, 1 ); + + return c_interned( key, store ); +} \ No newline at end of file diff --git a/src/c/ops/assoc.h b/src/c/ops/assoc.h index 52d8d08..ab59c40 100644 --- a/src/c/ops/assoc.h +++ b/src/c/ops/assoc.h @@ -16,13 +16,13 @@ #include "memory/pointer.h" -struct cons_pointer search( struct pso_pointer key, +struct pso_pointer search( struct pso_pointer key, struct pso_pointer store, bool return_key ); -struct pso_pointer assoc( struct pso_pointer key, struct pso_pointer store ); +struct pso_pointer c_assoc( struct pso_pointer key, struct pso_pointer store ); -struct pso_pointer interned( struct pso_pointer key, +struct pso_pointer c_interned( struct pso_pointer key, struct pso_pointer store ); -bool internedp( struct pso_pointer key, struct pso_pointer store ); +bool c_internedp( struct pso_pointer key, struct pso_pointer store ); #endif diff --git a/src/c/ops/bind.c b/src/c/ops/bind.c index f812c43..75aa476 100644 --- a/src/c/ops/bind.c +++ b/src/c/ops/bind.c @@ -21,14 +21,19 @@ #include "payloads/cons.h" #include "payloads/stack.h" -struct pso_pointer bind( struct pso_pointer frame_pointer, - struct pso_pointer env ) { +struct pso_pointer bind( +#ifndef MANAGED_POINTER_ONLY + struct pso4 * frame, +#endif + struct pso_pointer frame_pointer, struct pso_pointer env) { +#ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); +#endif struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer value = fetch_arg( frame, 1 ); struct pso_pointer store = fetch_arg( frame, 2 ); - return cons( cons( key, value ), store ); + return c_cons( c_cons( key, value ), store ); } struct pso_pointer c_bind( struct pso_pointer key, @@ -37,7 +42,11 @@ struct pso_pointer c_bind( struct pso_pointer key, struct pso_pointer result = nil; struct pso_pointer next = make_frame( nil, key, value, store ); inc_ref( next ); - result = bind( next, nil ); + result = bind( +#ifndef MANAGED_POINTER_ONLY + pointer_to_pso4( next), +#endif + next, nil ); dec_ref( next ); return result; diff --git a/src/c/ops/bind.h b/src/c/ops/bind.h index d7cdf42..e8e6839 100644 --- a/src/c/ops/bind.h +++ b/src/c/ops/bind.h @@ -15,11 +15,16 @@ #include "memory/pointer.h" -struct pso_pointer bind( struct pso_pointer frame_pointer, - struct pso_pointer env ); - struct pso_pointer c_bind( struct pso_pointer key, struct pso_pointer value, struct pso_pointer store ); +struct pso_pointer bind( +#ifndef MANAGED_POINTER_ONLY + struct pso4 * frame, +#endif + struct pso_pointer frame_pointer, + struct pso_pointer env +); + #endif diff --git a/src/c/ops/eq.c b/src/c/ops/eq.c index b3789e5..ab8702c 100644 --- a/src/c/ops/eq.c +++ b/src/c/ops/eq.c @@ -16,6 +16,7 @@ #include "memory/tags.h" #include "payloads/cons.h" +#include "payloads/function.h" #include "payloads/integer.h" #include "payloads/stack.h" #include "ops/stack_ops.h" @@ -26,6 +27,8 @@ * * Shallow, cheap equality. * + * Bootstrap function: only knows about character, cons, integer, and + * string-like-thing equality. * TODO: if either of these pointers points to a cache cell, then what * we need to check is the cached value, which is not so cheap. Ouch! * @@ -53,8 +56,8 @@ bool c_equal( struct pso_pointer a, struct pso_pointer b ) { ob->payload.character.character ); break; case CONSTV: - result = ( c_equal( car( a ), car( b ) ) - && c_equal( cdr( a ), cdr( b ) ) ); + result = ( c_equal( c_car( a ), c_car( b ) ) + && c_equal( c_cdr( a ), c_cdr( b ) ) ); break; case INTEGERTV: result = ( oa->payload.integer.value @@ -63,11 +66,11 @@ bool c_equal( struct pso_pointer a, struct pso_pointer b ) { case KEYTV: case STRINGTV: case SYMBOLTV: - while ( result == false && !nilp( a ) && !nilp( b ) ) { + while ( !nilp( a ) && !nilp( b ) ) { if ( pointer_to_object( a )->payload.string.character == pointer_to_object( b )->payload.string.character ) { - a = cdr( a ); - b = cdr( b ); + a = c_cdr( a ); + b = c_cdr( b ); } } result = nilp( a ) && nilp( b ); @@ -86,14 +89,17 @@ bool c_equal( struct pso_pointer a, struct pso_pointer b ) { * * * (eq? args...) * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (ignored). * @return `t` if all args are pointers to the same object, else `nil`; */ -struct pso_pointer eq( struct pso_pointer frame_pointer, - struct pso_pointer env ) { +struct pso_pointer eq( +#ifndef MANAGED_POINTER_ONLY + struct pso4 * frame, +#endif + struct pso_pointer frame_pointer, struct pso_pointer env) { +#ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); + +#endif struct pso_pointer result = t; @@ -108,3 +114,30 @@ struct pso_pointer eq( struct pso_pointer frame_pointer, return result; } + + +/** + * Function; do all arguments to this finction point to the same object? + * + * Deep, expensive equality. Bootstrap version: only knows + * * cons cells + * * integers + * * keywords + * * symbols + * * strings + * + * * (equal? arg1 qrg2) + * + * @return `t` if all args are pointers to the same object, else `nil`; + */ +struct pso_pointer equal( +#ifndef MANAGED_POINTER_ONLY + struct pso4 * frame, +#endif + struct pso_pointer frame_pointer, struct pso_pointer env) { +#ifdef MANAGED_POINTER_ONLY + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + +#endif + return c_equal( fetch_arg( frame, 0), fetch_arg( frame, 1)) ? t : nil; +} diff --git a/src/c/ops/eq.h b/src/c/ops/eq.h index 854e40c..90885c5 100644 --- a/src/c/ops/eq.h +++ b/src/c/ops/eq.h @@ -16,10 +16,30 @@ #include "memory/pointer.h" #include "memory/pso4.h" +#include "payloads/function.h" + bool c_eq( struct pso_pointer a, struct pso_pointer b ); struct pso_pointer eq( struct pso_pointer frame_pointer, struct pso_pointer env ); bool c_equal( struct pso_pointer a, struct pso_pointer b ); + +struct pso_pointer eq( +#ifndef MANAGED_POINTER_ONLY + struct pso4 * frame, +#endif + struct pso_pointer frame_pointer, + struct pso_pointer env +); + +struct pso_pointer equal( +#ifndef MANAGED_POINTER_ONLY + struct pso4 * frame, +#endif + struct pso_pointer frame_pointer, + struct pso_pointer env +); + + #endif diff --git a/src/c/ops/reverse.c b/src/c/ops/reverse.c index 5f59004..f4385e5 100644 --- a/src/c/ops/reverse.c +++ b/src/c/ops/reverse.c @@ -39,13 +39,14 @@ struct pso_pointer reverse( struct pso_pointer sequence ) { struct pso_pointer result = nil; for ( struct pso_pointer cursor = sequence; !nilp( sequence ); - cursor = cdr( cursor ) ) { + cursor = c_cdr( cursor ) ) { struct pso2 *object = pointer_to_object( cursor ); switch ( get_tag_value( cursor ) ) { case CONSTV: - result = cons( car( cursor ), result ); + result = c_cons( c_car( cursor ), result ); break; case KEYTV: + // TODO: should you be able to reverse keywords and symbols? result = make_string_like_thing( object->payload.string.character, result, KEYTAG ); @@ -56,6 +57,7 @@ struct pso_pointer reverse( struct pso_pointer sequence ) { result, STRINGTAG ); break; case SYMBOLTV: + // TODO: should you be able to reverse keywords and symbols? result = make_string_like_thing( object->payload.string.character, result, SYMBOLTAG ); diff --git a/src/c/payloads/cons.c b/src/c/payloads/cons.c index 607cca4..5e8a4ea 100644 --- a/src/c/payloads/cons.c +++ b/src/c/payloads/cons.c @@ -19,6 +19,7 @@ #include "payloads/cons.h" #include "payloads/exception.h" +#include "ops/stack_ops.h" #include "ops/string_ops.h" /** @@ -29,7 +30,7 @@ * @param cdr the pointer which should form the cdr of this cons cell. * @return struct pso_pointer a pointer to the newly allocated cons cell. */ -struct pso_pointer cons( struct pso_pointer car, struct pso_pointer cdr ) { +struct pso_pointer c_cons( struct pso_pointer car, struct pso_pointer cdr ) { struct pso_pointer result = allocate( CONSTAG, 2 ); struct pso2 *object = pointer_to_object( result ); @@ -47,7 +48,7 @@ struct pso_pointer cons( struct pso_pointer car, struct pso_pointer cdr ) { * @return the car of the indicated cell. * @exception if the pointer does not indicate a cons cell. */ -struct pso_pointer car( struct pso_pointer cons ) { +struct pso_pointer c_car( struct pso_pointer cons ) { struct pso_pointer result = nil; struct pso2 *object = pointer_to_object( result ); @@ -66,7 +67,7 @@ struct pso_pointer car( struct pso_pointer cons ) { * @return the cdr of the indicated cell. * @exception if the pointer does not indicate a cons cell. */ -struct pso_pointer cdr( struct pso_pointer p ) { +struct pso_pointer c_cdr( struct pso_pointer p ) { struct pso_pointer result = nil; struct pso2 *object = pointer_to_object( result ); @@ -81,7 +82,7 @@ struct pso_pointer cdr( struct pso_pointer p ) { break; default: result = - make_exception( cons + make_exception( c_cons ( c_string_to_lisp_string ( L"Invalid type for cdr" ), p ), nil, nil ); break; @@ -104,7 +105,7 @@ struct pso_pointer destroy_cons( struct pso_pointer fp, 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 ) ); + dec_ref( c_car( p ) ); + dec_ref( c_cdr( p ) ); } } diff --git a/src/c/payloads/cons.h b/src/c/payloads/cons.h index 9ba768f..c7dd21c 100644 --- a/src/c/payloads/cons.h +++ b/src/c/payloads/cons.h @@ -26,11 +26,11 @@ struct cons_payload { struct pso_pointer cdr; }; -struct pso_pointer car( struct pso_pointer cons ); +struct pso_pointer c_car( struct pso_pointer cons ); -struct pso_pointer cdr( struct pso_pointer cons ); +struct pso_pointer c_cdr( struct pso_pointer cons ); -struct pso_pointer cons( struct pso_pointer car, struct pso_pointer cdr ); +struct pso_pointer c_cons( struct pso_pointer car, struct pso_pointer cdr ); struct pso_pointer destroy_cons( struct pso_pointer fp, struct pso_pointer env ); diff --git a/src/c/payloads/function.h b/src/c/payloads/function.h index ea54051..94bbb61 100644 --- a/src/c/payloads/function.h +++ b/src/c/payloads/function.h @@ -13,29 +13,43 @@ #include "memory/pointer.h" #include "memory/pso4.h" +/** + * I don't think it's necessary to pass both an unmanaged and a managed + * frame pointer into a function, but it may prove to be more efficient to do + * so. For the present we'll assume not. See state of play for 15042026. + */ +#define MANAGED_POINTER_ONLY TRUE + /** * @brief Payload of a function cell. - * `source` points to the source from which the function was compiled, or NIL - * if it is a primitive. - * `executable` points to a function which takes a pointer to a stack frame - * (representing its stack frame) and a cons pointer (representing its - * environment) as arguments and returns a cons pointer (representing its - * result). */ struct function_payload { /** - * pointer to metadata (e.g. the source from which the function was compiled). + * pointer to metadata (e.g. the source from which the function was compiled, + * something to help estimate the cost of the function?). */ struct pso_pointer meta; - /** pointer to a function which takes a cons pointer (representing - * its argument list) and a cons pointer (representing its environment) and a - * stack frame (representing the previous stack frame) as arguments and returns - * a cons pointer (representing its result). - * \todo check this documentation is current! + +#ifdef MANAGED_POINTER_ONLY + /** + * pointer to a C function which takes a managed pointer to the same stack + * frame and a managed pointer to the environment as arguments. Arguments + * to the Lisp function are assumed to be loaded into the frame before + * invocation. */ - struct pso_pointer ( *executable ) ( struct pso4 *, - struct pso_pointer, - struct pso_pointer ); + struct pso_pointer ( *executable ) ( struct pso_pointer frame_pointer, + struct pso_pointer env ); +#else + /** + * pointer to a C function which takes an unmanaged pointer to a stack frame, + * a managed pointer to the same stack frame, and a managed pointer to the + * environment as arguments. Arguments to the Lisp function are assumed to be + * loaded into the frame before invocation. + */ + struct pso_pointer ( *executable ) ( struct pso4 * frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ); +#endif }; #endif diff --git a/src/c/payloads/psse_string.c b/src/c/payloads/psse_string.c index a75037b..8a4bdbe 100644 --- a/src/c/payloads/psse_string.c +++ b/src/c/payloads/psse_string.c @@ -38,7 +38,7 @@ struct pso_pointer destroy_string( struct pso_pointer fp, struct pso4 *frame = pointer_to_pso4( fp ); struct pso_pointer p = frame->payload.stack_frame.arg[0]; - dec_ref( cdr( p ) ); + dec_ref( c_cdr( p ) ); } return nil; diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index a0591ab..70abaa3 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -18,6 +18,8 @@ #include "memory/pso4.h" #include "memory/tags.h" +#include "payloads/cons.h" + /** * @brief Construct a stack frame with this `previous` pointer, and arguments * taken from the remaining arguments to this function, which should all be @@ -50,7 +52,7 @@ struct pso_pointer make_frame( struct pso_pointer previous, ... ) { struct pso_pointer more_args = nil; for ( ; cursor < count; cursor++ ) { - more_args = cons( va_arg( args, struct pso_pointer ), more_args ); + more_args = c_cons( va_arg( args, struct pso_pointer ), more_args ); } // should be frame->payload.stack_frame.more = reverse( more_args), but @@ -83,7 +85,7 @@ struct pso_pointer destroy_stack_frame( struct pso_pointer fp, dec_ref( casualty->payload.stack_frame.more ); for ( int i = 0; i < args_in_frame; i++ ) { - dec_ref( casualty->payload.stack_frame.arg[0] ); + dec_ref( casualty->payload.stack_frame.arg[i] ); } casualty->payload.stack_frame.args = 0; From f751fc8a09573b7960bd1e5c757694d22a88dc6a Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 15 Apr 2026 22:47:44 +0100 Subject: [PATCH 2/4] More code, closer to working, still builds. --- src/c/environment/environment.c | 55 +++++++++++++++++++++--- src/c/io/io.c | 4 +- src/c/memory/memory.c | 15 ++++++- src/c/memory/node.c | 6 +-- src/c/ops/assoc.c | 26 ++++++----- src/c/ops/assoc.h | 4 +- src/c/ops/bind.c | 13 +++--- src/c/ops/bind.h | 10 ++--- src/c/ops/eq.c | 20 +++++---- src/c/ops/eq.h | 18 ++++---- src/c/ops/eval.c | 76 --------------------------------- src/c/ops/string_ops.c | 19 +++++++++ src/c/ops/string_ops.h | 2 + src/c/payloads/stack.c | 3 +- 14 files changed, 138 insertions(+), 133 deletions(-) delete mode 100644 src/c/ops/eval.c diff --git a/src/c/environment/environment.c b/src/c/environment/environment.c index cf512c4..28c453f 100644 --- a/src/c/environment/environment.c +++ b/src/c/environment/environment.c @@ -9,8 +9,19 @@ #include +#include "memory/memory.h" #include "memory/node.h" #include "memory/pointer.h" +#include "memory/pso.h" +#include "memory/pso2.h" +#include "memory/tags.h" + +#include "ops/bind.h" +#include "ops/string_ops.h" + +#include "payloads/cons.h" +#include "payloads/exception.h" +#include "payloads/psse_string.h" /** * @brief Flag to prevent re-initialisation. @@ -25,11 +36,45 @@ bool environment_initialised = false; */ struct pso_pointer initialise_environment( uint32_t node ) { - struct pso_pointer result = t; - if ( environment_initialised ) { - // TODO: throw an exception "Attempt to reinitialise environment" - } else { - // TODO: actually initialise it. + struct pso_pointer result = initialise_memory( node ); + + if ( !exceptionp( result ) ) { + struct pso_pointer n = allocate( NILTAG, 2 ); + + if ( ( n.page == 0 ) && ( n.offset == 0 ) ) { + struct pso2 *object = pointer_to_object( n ); + object->payload.cons.car = nil; + object->payload.cons.cdr = nil; + + nil = n; + } else { + result = + make_exception( c_string_to_lisp_string + ( L"Unexpected cell while allocating `nil`." ), + nil, n ); + } + } + if ( !exceptionp( result ) ) { + struct pso_pointer n = allocate( TRUETAG, 2 ); + + if ( ( n.page == 0 ) && ( n.offset == 1 ) ) { + struct pso2 *object = pointer_to_object( n ); + object->payload.string.character = L't'; + object->payload.cons.cdr = t; + + t = n; + } else { + result = + make_exception( c_string_to_lisp_string + ( L"Unexpected cell while allocating `t`." ), + nil, n ); + } + } + if ( !exceptionp( result ) ) { + result = c_bind( c_string_to_lisp_symbol( L"nil" ), nil, nil ); + result = c_bind( c_string_to_lisp_symbol( L"t" ), t, result ); + + environment_initialised = true; } return result; diff --git a/src/c/io/io.c b/src/c/io/io.c index 3f31d2c..2a897f7 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -329,7 +329,7 @@ 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 ); + make_integer( value ) ), meta ); } struct pso_pointer add_meta_string( struct pso_pointer meta, wchar_t *key, @@ -339,7 +339,7 @@ struct pso_pointer add_meta_string( struct pso_pointer meta, wchar_t *key, mbstowcs( buffer, value, strlen( value ) + 1 ); return c_cons( c_cons( c_string_to_lisp_keyword( key ), - c_string_to_lisp_string( buffer ) ), meta ); + c_string_to_lisp_string( buffer ) ), meta ); } struct pso_pointer add_meta_time( struct pso_pointer meta, wchar_t *key, diff --git a/src/c/memory/memory.c b/src/c/memory/memory.c index ca41d67..6d48334 100644 --- a/src/c/memory/memory.c +++ b/src/c/memory/memory.c @@ -13,6 +13,14 @@ #include "memory/memory.h" #include "memory/node.h" #include "memory/pointer.h" +#include "memory/pso.h" +#include "memory/pso2.h" +#include "memory/tags.h" + +#include "payloads/exception.h" + +#include "ops/bind.h" +#include "ops/string_ops.h" /** * @brief Freelists for each size class. @@ -24,6 +32,7 @@ struct pso_pointer freelists[MAX_SIZE_CLASS]; */ bool memory_initialised = false; + /** * @brief Initialise the memory allocation system. * @@ -34,8 +43,12 @@ bool memory_initialised = false; * @return int */ struct pso_pointer initialise_memory( uint32_t node ) { + struct pso_pointer result = nil; if ( memory_initialised ) { - // TODO: throw an exception + result = + make_exception( c_string_to_lisp_string + ( L"Attenpt to reinitialise environment" ), nil, + nil ); } else { for ( uint8_t i = 0; i <= MAX_SIZE_CLASS; i++ ) { freelists[i] = nil; diff --git a/src/c/memory/node.c b/src/c/memory/node.c index 2a650a0..5c70ec5 100644 --- a/src/c/memory/node.c +++ b/src/c/memory/node.c @@ -55,11 +55,7 @@ struct pso_pointer t = ( struct pso_pointer ) { 0, 0, 1 }; struct pso_pointer initialise_node( uint32_t index ) { node_index = index; - struct pso_pointer result = initialise_memory( index ); - - if ( c_eq( result, t ) ) { - result = initialise_environment( index ); - } + struct pso_pointer result = initialise_environment( index ); return result; } diff --git a/src/c/ops/assoc.c b/src/c/ops/assoc.c index 004fa3e..fb63afc 100644 --- a/src/c/ops/assoc.c +++ b/src/c/ops/assoc.c @@ -74,7 +74,8 @@ struct pso_pointer c_assoc( struct pso_pointer key, struct pso_pointer store ) { * * @return a pointer to the copy of the key in the store, or nil if not found. */ -struct pso_pointer c_interned( struct pso_pointer key, struct pso_pointer store ) { +struct pso_pointer c_interned( struct pso_pointer key, + struct pso_pointer store ) { return search( key, store, true ); } @@ -95,11 +96,12 @@ bool c_internedp( struct pso_pointer key, struct pso_pointer store ) { * * @return a pointer to the value of the key in the store, or nil if not found */ -struct pso_pointer assoc( +struct pso_pointer assoc( #ifndef MANAGED_POINTER_ONLY - struct pso4 * frame, + struct pso4 *frame, #endif - struct pso_pointer frame_pointer, struct pso_pointer env) { + struct pso_pointer frame_pointer, + struct pso_pointer env ) { #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); #endif @@ -114,11 +116,12 @@ struct pso_pointer assoc( * * @return a pointer to the copy of the key in the store, or nil if not found. */ -struct pso_pointer interned( +struct pso_pointer interned( #ifndef MANAGED_POINTER_ONLY - struct pso4 * frame, + struct pso4 *frame, #endif - struct pso_pointer frame_pointer, struct pso_pointer env) { + struct pso_pointer frame_pointer, + struct pso_pointer env ) { #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); #endif @@ -133,11 +136,12 @@ struct pso_pointer interned( * * @return `t` if a pointer to a copy of `key` is found in the store, or `nil` if not found. */ -struct pso_pointer internedp( +struct pso_pointer internedp( #ifndef MANAGED_POINTER_ONLY - struct pso4 * frame, + struct pso4 *frame, #endif - struct pso_pointer frame_pointer, struct pso_pointer env) { + struct pso_pointer frame_pointer, + struct pso_pointer env ) { #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); #endif @@ -145,4 +149,4 @@ struct pso_pointer internedp( struct pso_pointer store = fetch_arg( frame, 1 ); return c_interned( key, store ); -} \ No newline at end of file +} diff --git a/src/c/ops/assoc.h b/src/c/ops/assoc.h index ab59c40..746a6ea 100644 --- a/src/c/ops/assoc.h +++ b/src/c/ops/assoc.h @@ -17,12 +17,12 @@ #include "memory/pointer.h" struct pso_pointer search( struct pso_pointer key, - struct pso_pointer store, bool return_key ); + struct pso_pointer store, bool return_key ); struct pso_pointer c_assoc( struct pso_pointer key, struct pso_pointer store ); struct pso_pointer c_interned( struct pso_pointer key, - struct pso_pointer store ); + struct pso_pointer store ); bool c_internedp( struct pso_pointer key, struct pso_pointer store ); #endif diff --git a/src/c/ops/bind.c b/src/c/ops/bind.c index 75aa476..799c418 100644 --- a/src/c/ops/bind.c +++ b/src/c/ops/bind.c @@ -21,11 +21,12 @@ #include "payloads/cons.h" #include "payloads/stack.h" -struct pso_pointer bind( +struct pso_pointer lisp_bind( #ifndef MANAGED_POINTER_ONLY - struct pso4 * frame, + struct pso4 *frame, #endif - struct pso_pointer frame_pointer, struct pso_pointer env) { + struct pso_pointer frame_pointer, + struct pso_pointer env ) { #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); #endif @@ -42,11 +43,11 @@ struct pso_pointer c_bind( struct pso_pointer key, struct pso_pointer result = nil; struct pso_pointer next = make_frame( nil, key, value, store ); inc_ref( next ); - result = bind( + result = lisp_bind( #ifndef MANAGED_POINTER_ONLY - pointer_to_pso4( next), + pointer_to_pso4( next ), #endif - next, nil ); + next, nil ); dec_ref( next ); return result; diff --git a/src/c/ops/bind.h b/src/c/ops/bind.h index e8e6839..f2a799f 100644 --- a/src/c/ops/bind.h +++ b/src/c/ops/bind.h @@ -14,17 +14,17 @@ #include #include "memory/pointer.h" +#include "memory/pso4.h" struct pso_pointer c_bind( struct pso_pointer key, struct pso_pointer value, struct pso_pointer store ); -struct pso_pointer bind( +struct pso_pointer lisp_bind( #ifndef MANAGED_POINTER_ONLY - struct pso4 * frame, + struct pso4 *frame, #endif - struct pso_pointer frame_pointer, - struct pso_pointer env -); + struct pso_pointer frame_pointer, + struct pso_pointer env ); #endif diff --git a/src/c/ops/eq.c b/src/c/ops/eq.c index ab8702c..d5b348e 100644 --- a/src/c/ops/eq.c +++ b/src/c/ops/eq.c @@ -91,14 +91,15 @@ bool c_equal( struct pso_pointer a, struct pso_pointer b ) { * * @return `t` if all args are pointers to the same object, else `nil`; */ -struct pso_pointer eq( +struct pso_pointer eq( #ifndef MANAGED_POINTER_ONLY - struct pso4 * frame, + struct pso4 *frame, #endif - struct pso_pointer frame_pointer, struct pso_pointer env) { + struct pso_pointer frame_pointer, + struct pso_pointer env ) { #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); - + #endif struct pso_pointer result = t; @@ -130,14 +131,15 @@ struct pso_pointer eq( * * @return `t` if all args are pointers to the same object, else `nil`; */ -struct pso_pointer equal( +struct pso_pointer equal( #ifndef MANAGED_POINTER_ONLY - struct pso4 * frame, + struct pso4 *frame, #endif - struct pso_pointer frame_pointer, struct pso_pointer env) { + struct pso_pointer frame_pointer, + struct pso_pointer env ) { #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); - + #endif - return c_equal( fetch_arg( frame, 0), fetch_arg( frame, 1)) ? t : nil; + return c_equal( fetch_arg( frame, 0 ), fetch_arg( frame, 1 ) ) ? t : nil; } diff --git a/src/c/ops/eq.h b/src/c/ops/eq.h index 90885c5..a669a10 100644 --- a/src/c/ops/eq.h +++ b/src/c/ops/eq.h @@ -25,21 +25,19 @@ struct pso_pointer eq( struct pso_pointer frame_pointer, bool c_equal( struct pso_pointer a, struct pso_pointer b ); -struct pso_pointer eq( +struct pso_pointer eq( #ifndef MANAGED_POINTER_ONLY - struct pso4 * frame, + struct pso4 *frame, #endif - struct pso_pointer frame_pointer, - struct pso_pointer env -); + struct pso_pointer frame_pointer, + struct pso_pointer env ); -struct pso_pointer equal( +struct pso_pointer equal( #ifndef MANAGED_POINTER_ONLY - struct pso4 * frame, + struct pso4 *frame, #endif - struct pso_pointer frame_pointer, - struct pso_pointer env -); + struct pso_pointer frame_pointer, + struct pso_pointer env ); #endif diff --git a/src/c/ops/eval.c b/src/c/ops/eval.c deleted file mode 100644 index 830cceb..0000000 --- a/src/c/ops/eval.c +++ /dev/null @@ -1,76 +0,0 @@ -/** - * ops/eval.c - * - * Post Scarcity Software Environment: eval. - * - * Evaluate an arbitrary Lisp expression. - * - * (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/pso3.h" -#include "memory/pso4.h" -#include "memory/tags.h" - -#include "payloads/cons.h" -#include "payloads/exception.h" -#include "payloads/function.h" -#include "payloads/keyword.h" -#include "payloads/lambda.h" -#include "payloads/nlambda.h" -#include "payloads/special.h" -#include "payloads/stack.h" - -#include "ops/truth.h" - -/** - * @brief Despatch eval based on tag of the form in the first position. - * - * @param frame The current stack frame; - * @param frame_pointer A pointer to the current stack frame; - * @param env the evaluation environment. - * @return struct pso_pointer - */ -struct pso_pointer lisp_eval( struct pso_pointer frame_pointer, - struct pso_pointer env ) { - struct pso4 *frame = pointer_to_pso4( frame_pointer ); - struct pso_pointer result = frame->payload.stack_frame.arg[0]; - - // switch ( get_tag_value( result)) { - // case CONSTV: - // result = eval_cons( frame, frame_pointer, env); - // break; - // case KEYTV: - // case SYMBOLTV: - // result = eval_symbol( frame, frame_pointer, env); - // break; - // case LAMBDATV: - // result = eval_lambda( frame, frame_pointer, env); - // break; - // case NLAMBDATV: - // result = eval_nlambda( frame, frame_pointer, env); - // break; - // case SPECIALTV: - // result = eval_special( frame, frame_pointer, env); - // break; - // } - - if ( exceptionp( result ) ) { - struct pso3 *x = - ( struct pso3 * ) pointer_to_object_with_tag_value( result, - EXCEPTIONTV ); - - if ( nilp( x->payload.exception.stack ) ) { - inc_ref( result ); - result = - make_exception( x->payload.exception.message, frame_pointer, - result ); - } - } - - return result; -} diff --git a/src/c/ops/string_ops.c b/src/c/ops/string_ops.c index 14d12a3..0f6741a 100644 --- a/src/c/ops/string_ops.c +++ b/src/c/ops/string_ops.c @@ -145,6 +145,25 @@ struct pso_pointer c_string_to_lisp_string( wchar_t *string ) { return result; } + +/** + * Return a lisp symbol representation of this wide character string. In + * symbols, I am accepting only lower case characters. + */ +struct pso_pointer c_string_to_lisp_symbol( wchar_t *symbol ) { + struct pso_pointer result = nil; + + for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) { + wchar_t c = towlower( symbol[i] ); + + if ( iswalpha( c ) || c == L'-' ) { + result = make_symbol( c, result ); + } + } + + return result; +} + /** * Return a lisp keyword representation of this wide character string. In * keywords, I am accepting only lower case characters and numbers. diff --git a/src/c/ops/string_ops.h b/src/c/ops/string_ops.h index 59ce837..e80692e 100644 --- a/src/c/ops/string_ops.h +++ b/src/c/ops/string_ops.h @@ -29,4 +29,6 @@ struct pso_pointer c_string_to_lisp_string( wchar_t *string ); struct pso_pointer c_string_to_lisp_keyword( wchar_t *symbol ); +struct pso_pointer c_string_to_lisp_symbol( wchar_t *symbol ); + #endif diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index 70abaa3..3f144df 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -52,7 +52,8 @@ struct pso_pointer make_frame( struct pso_pointer previous, ... ) { struct pso_pointer more_args = nil; for ( ; cursor < count; cursor++ ) { - more_args = c_cons( va_arg( args, struct pso_pointer ), more_args ); + more_args = + c_cons( va_arg( args, struct pso_pointer ), more_args ); } // should be frame->payload.stack_frame.more = reverse( more_args), but From 25c87aac6ed686ae59d07bb610439ed359f00ecd Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 16 Apr 2026 00:22:24 +0100 Subject: [PATCH 3/4] Added debug messages to initialisation functions, but getting a segfault. Not going to debug that tonight! --- src/c/environment/environment.c | 8 ++++++++ src/c/memory/memory.c | 7 ++++++- src/c/memory/page.c | 6 ++++++ src/c/memory/pso.c | 9 +++++++++ 4 files changed, 29 insertions(+), 1 deletion(-) diff --git a/src/c/environment/environment.c b/src/c/environment/environment.c index 28c453f..1c8ad1b 100644 --- a/src/c/environment/environment.c +++ b/src/c/environment/environment.c @@ -9,6 +9,8 @@ #include +#include "debug.h" + #include "memory/memory.h" #include "memory/node.h" #include "memory/pointer.h" @@ -39,6 +41,7 @@ struct pso_pointer initialise_environment( uint32_t node ) { struct pso_pointer result = initialise_memory( node ); if ( !exceptionp( result ) ) { + debug_print( L"Initialising `nil`... ", DEBUG_BOOTSTRAP, 0); struct pso_pointer n = allocate( NILTAG, 2 ); if ( ( n.page == 0 ) && ( n.offset == 0 ) ) { @@ -47,14 +50,17 @@ struct pso_pointer initialise_environment( uint32_t node ) { object->payload.cons.cdr = nil; nil = n; + debug_print( L"success\n", DEBUG_BOOTSTRAP, 0); } else { result = make_exception( c_string_to_lisp_string ( L"Unexpected cell while allocating `nil`." ), nil, n ); + debug_print( L"fail\n", DEBUG_BOOTSTRAP, 0); } } if ( !exceptionp( result ) ) { + debug_print( L"Initialising `t`... ", DEBUG_BOOTSTRAP, 0); struct pso_pointer n = allocate( TRUETAG, 2 ); if ( ( n.page == 0 ) && ( n.offset == 1 ) ) { @@ -63,11 +69,13 @@ struct pso_pointer initialise_environment( uint32_t node ) { object->payload.cons.cdr = t; t = n; + debug_print( L"success\n", DEBUG_BOOTSTRAP, 0); } else { result = make_exception( c_string_to_lisp_string ( L"Unexpected cell while allocating `t`." ), nil, n ); + debug_print( L"fail\n", DEBUG_BOOTSTRAP, 0); } } if ( !exceptionp( result ) ) { diff --git a/src/c/memory/memory.c b/src/c/memory/memory.c index 6d48334..fa49bf1 100644 --- a/src/c/memory/memory.c +++ b/src/c/memory/memory.c @@ -10,6 +10,8 @@ #include #include +#include "debug.h" + #include "memory/memory.h" #include "memory/node.h" #include "memory/pointer.h" @@ -47,12 +49,15 @@ struct pso_pointer initialise_memory( uint32_t node ) { if ( memory_initialised ) { result = make_exception( c_string_to_lisp_string - ( L"Attenpt to reinitialise environment" ), nil, + ( L"Attenpt to reinitialise memory." ), nil, nil ); } else { for ( uint8_t i = 0; i <= MAX_SIZE_CLASS; i++ ) { freelists[i] = nil; } +#ifdef DEBUG + debug_print(L"Memory initialised", DEBUG_BOOTSTRAP, 0); +#endif memory_initialised = true; } diff --git a/src/c/memory/page.c b/src/c/memory/page.c index 60771b4..74ae5c7 100644 --- a/src/c/memory/page.c +++ b/src/c/memory/page.c @@ -68,6 +68,10 @@ struct pso_pointer initialise_page( union page *page_addr, uint16_t page_index, int obj_bytes = obj_size * sizeof( uint64_t ); int objs_in_page = PAGE_BYTES / obj_bytes; + debug_printf(DEBUG_ALLOC, 0, + L"Initialising page %d for objects of size class %d...", + page_index, size_class); + // we do this backwards (i--) so that object {0, 0, 0} will be first on the // freelist when the first page is initiated, so we can grab that one for // `nil` and the next on for `t`. @@ -86,6 +90,8 @@ struct pso_pointer initialise_page( union page *page_addr, uint16_t page_index, ( uint16_t ) ( i * obj_size ) ); } + debug_print( L"page allocated.\n", DEBUG_ALLOC, 0); + return result; } diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index 7409e51..16ded6e 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" @@ -39,6 +40,10 @@ struct pso_pointer allocate( char *tag, uint8_t size_class ) { struct pso_pointer result = nil; +#ifdef DEBUG + debug_printf( DEBUG_ALLOC, 0, L"Allocating object of size class %d with tag `%s`... ", size_class, tag); +#endif + if ( size_class <= MAX_SIZE_CLASS ) { if ( nilp( freelists[size_class] ) ) { result = allocate_page( size_class ); @@ -66,6 +71,10 @@ struct pso_pointer allocate( char *tag, uint8_t size_class ) { } } // TODO: else throw exception +#ifdef DEBUG + debug_print(exceptionp(result)? L"fail\n" : L"success\n", DEBUG_ALLOC, 0); +#endif + return result; } From 04aa32bd5af36d48cb3f8d21f1474b9d7f5b490e Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 16 Apr 2026 00:24:03 +0100 Subject: [PATCH 4/4] Whoops! several new files missed from recent commits. --- src/c/ops/eval_apply.c | 106 +++++++++++++++++++++++++++++++++++++++++ src/c/ops/eval_apply.h | 36 ++++++++++++++ src/c/ops/list_ops.c | 72 ++++++++++++++++++++++++++++ src/c/ops/list_ops.h | 39 +++++++++++++++ 4 files changed, 253 insertions(+) create mode 100644 src/c/ops/eval_apply.c create mode 100644 src/c/ops/eval_apply.h create mode 100644 src/c/ops/list_ops.c create mode 100644 src/c/ops/list_ops.h diff --git a/src/c/ops/eval_apply.c b/src/c/ops/eval_apply.c new file mode 100644 index 0000000..b46aa99 --- /dev/null +++ b/src/c/ops/eval_apply.c @@ -0,0 +1,106 @@ +/** + * ops/apply.c + * + * Post Scarcity Software Environment: apply. + * + * Add a applying for a key/value pair to a store -- at this stage, just an + * association list. + * + * (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/pso3.h" +#include "memory/pso4.h" +#include "memory/tags.h" + +#include "ops/assoc.h" +#include "ops/stack_ops.h" +#include "ops/string_ops.h" +#include "ops/truth.h" + +#include "payloads/cons.h" +#include "payloads/stack.h" + +/** + * @brief Apply a function to arguments in an environment. + * + * * (apply fn args) + */ +struct pso_pointer apply( +#ifndef MANAGED_POINTER_ONLY + struct pso4 *frame, +#endif + struct pso_pointer frame_pointer, + struct pso_pointer env ) { +#ifdef MANAGED_POINTER_ONLY + struct pso4 *frame = pointer_to_pso4( frame_pointer ); +#endif + +// TODO. + +} + +/** + * @brief Evaluate a form, in an environment + * + * * (eval form) + */ +struct pso_pointer eval( +#ifndef MANAGED_POINTER_ONLY + struct pso4 *frame, +#endif + struct pso_pointer frame_pointer, + struct pso_pointer env ) { +#ifdef MANAGED_POINTER_ONLY + struct pso4 *frame = pointer_to_pso4( frame_pointer ); +#endif + struct pso_pointer result = fetch_arg( frame, 0 ); + + switch ( get_tag_value( result ) ) { + // case CONSTV: + // result = eval_cons( frame, frame_pointer, env); + // break; + case INTEGERTV: + case KEYTV: + case STRINGTV: + // self evaluating + break; + case SYMBOLTV: + result = c_assoc( result, env ); + break; + // case LAMBDATV: + // result = eval_lambda( frame, frame_pointer, env); + // break; + // case NLAMBDATV: + // result = eval_nlambda( frame, frame_pointer, env); + // break; + // case SPECIALTV: + // result = eval_special( frame, frame_pointer, env); + // break; + default: + result = + make_exception( c_cons + ( c_string_to_lisp_string + ( L"Can't yet evaluate things of this type: " ), + result ), frame_pointer, nil ); + } + + if ( exceptionp( result ) ) { + struct pso3 *x = + ( struct pso3 * ) pointer_to_object_with_tag_value( result, + EXCEPTIONTV ); + + if ( nilp( x->payload.exception.stack ) ) { + inc_ref( result ); + result = + make_exception( x->payload.exception.message, frame_pointer, + result ); + } + } + + return result; +} diff --git a/src/c/ops/eval_apply.h b/src/c/ops/eval_apply.h new file mode 100644 index 0000000..18b0f01 --- /dev/null +++ b/src/c/ops/eval_apply.h @@ -0,0 +1,36 @@ +/** + * ops/eval_apply.h + * + * Post Scarcity Software Environment: eval, apply. + * + * apply: Apply a function to arguments in an environment. + * eval: Evaluate a form in an environment. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_ops_eval_apply_h +#define __psse_ops_eval_apply_h + +#include "memory/pointer.h" +#include "memory/pso4.h" +#include "payloads/function.h" + +struct pso_pointer apply( +#ifndef MANAGED_POINTER_ONLY + struct pso4 *frame, +#endif + struct pso_pointer frame_pointer, + struct pso_pointer env ); + + +struct pso_pointer eval( +#ifndef MANAGED_POINTER_ONLY + struct pso4 *frame, +#endif + struct pso_pointer frame_pointer, + struct pso_pointer env ); + + +#endif diff --git a/src/c/ops/list_ops.c b/src/c/ops/list_ops.c new file mode 100644 index 0000000..10ccc60 --- /dev/null +++ b/src/c/ops/list_ops.c @@ -0,0 +1,72 @@ +/** + * ops/list_ops.h + * + * Post Scarcity Software Environment: list_ops. + * + * Operations on cons cells. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_ops_list_ops_h +#define __psse_ops_list_ops_h + +#include "memory/pointer.h" +#include "memory/pso.h" +#include "memory/pso4.h" +#include "memory/tags.h" + +#include "ops/stack_ops.h" + +#include "payloads/cons.h" +#include "payloads/stack.h" + + +struct pso_pointer car( +#ifndef MANAGED_POINTER_ONLY + struct pso4 *frame, +#endif + struct pso_pointer frame_pointer, + struct pso_pointer env ) { +#ifdef MANAGED_POINTER_ONLY + struct pso4 *frame = pointer_to_pso4( frame_pointer ); +#endif + return c_car( fetch_arg( frame, 0 ) ); +} + +struct pso_pointer cdr( +#ifndef MANAGED_POINTER_ONLY + struct pso4 *frame, +#endif + struct pso_pointer frame_pointer, + struct pso_pointer env ) { +#ifdef MANAGED_POINTER_ONLY + struct pso4 *frame = pointer_to_pso4( frame_pointer ); +#endif + return c_cdr( fetch_arg( frame, 0 ) ); +} + +/** + * @brief allocate a cons cell from the first two args in this frame, and + * return a pointer to it. + * + * Lisp calling conventions. + * + * @return struct pso_pointer a pointer to the newly allocated cons cell. + */ + +struct pso_pointer cons( +#ifndef MANAGED_POINTER_ONLY + struct pso4 *frame, +#endif + struct pso_pointer frame_pointer, + struct pso_pointer env ) { +#ifdef MANAGED_POINTER_ONLY + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + +#endif + return c_cons( fetch_arg( frame, 0 ), fetch_arg( frame, 1 ) ); +} + +#endif diff --git a/src/c/ops/list_ops.h b/src/c/ops/list_ops.h new file mode 100644 index 0000000..ae770cd --- /dev/null +++ b/src/c/ops/list_ops.h @@ -0,0 +1,39 @@ +/** + * ops/list_ops.h + * + * Post Scarcity Software Environment: list_ops. + * + * Operations on cons cells. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_ops_list_ops_h +#define __psse_ops_list_ops_h + +#include "memory/pointer.h" +#include "memory/pso4.h" + +struct pso_pointer car( +#ifndef MANAGED_POINTER_ONLY + struct pso4 *frame, +#endif + struct pso_pointer frame_pointer, + struct pso_pointer env ); + +struct pso_pointer cdr( +#ifndef MANAGED_POINTER_ONLY + struct pso4 *frame, +#endif + struct pso_pointer frame_pointer, + struct pso_pointer env ); + +struct pso_pointer cons( +#ifndef MANAGED_POINTER_ONLY + struct pso4 *frame, +#endif + struct pso_pointer frame_pointer, + struct pso_pointer env ); + +#endif