From ef59563e258d4a00e4fc80b23e18cf21e30b432c Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 21 Apr 2026 14:43:09 +0100 Subject: [PATCH] Still in progress. Nothing workds. --- src/c/ops/assoc.c | 21 +++--- src/c/ops/bind.c | 14 ++-- src/c/ops/eq.c | 6 +- src/c/ops/eq.h | 9 +-- src/c/ops/eval_apply.c | 8 +-- src/c/ops/list_ops.c | 69 ++++-------------- src/c/ops/list_ops.h | 22 +----- src/c/ops/stack_ops.c | 15 ++++ src/c/ops/stack_ops.h | 2 + src/c/payloads/cons.c | 48 ++++++++----- src/c/payloads/cons.h | 9 +-- src/c/payloads/exception.c | 13 ++-- src/c/payloads/function.h | 6 +- src/c/payloads/stack.c | 144 +++++++++++++++++++++++++++---------- 14 files changed, 206 insertions(+), 180 deletions(-) diff --git a/src/c/ops/assoc.c b/src/c/ops/assoc.c index 100806d..625912b 100644 --- a/src/c/ops/assoc.c +++ b/src/c/ops/assoc.c @@ -17,6 +17,7 @@ #include "memory/tags.h" #include "payloads/cons.h" +#include "payloads/stack.h" #include "ops/eq.h" #include "ops/stack_ops.h" @@ -100,13 +101,13 @@ struct pso_pointer assoc( #ifndef MANAGED_POINTER_ONLY struct pso4 *frame, #endif - struct pso_pointer frame_pointer, - struct pso_pointer env ) { + struct pso_pointer frame_pointer) { #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 ); + struct pso_pointer store = or( make_frame( 2, frame_pointer, + fetch_arg( frame, 1 ), frame->payload.stack_frame.env)); return c_assoc( key, store ); } @@ -120,13 +121,13 @@ struct pso_pointer interned( #ifndef MANAGED_POINTER_ONLY struct pso4 *frame, #endif - struct pso_pointer frame_pointer, - struct pso_pointer env ) { + struct pso_pointer frame_pointer) { #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 ); + struct pso_pointer store = or( make_frame( 2, frame_pointer, + fetch_arg( frame, 1 ), frame->payload.stack_frame.env)); return c_interned( key, store ); } @@ -140,13 +141,13 @@ struct pso_pointer internedp( #ifndef MANAGED_POINTER_ONLY struct pso4 *frame, #endif - struct pso_pointer frame_pointer, - struct pso_pointer env ) { + struct pso_pointer frame_pointer) { #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 ); + struct pso_pointer store = or( make_frame( 2, frame_pointer, + fetch_arg( frame, 1 ), frame->payload.stack_frame.env)); - return c_interned( key, store ); + return c_internedp( key, store ); } diff --git a/src/c/ops/bind.c b/src/c/ops/bind.c index 32e1f4e..4c552ed 100644 --- a/src/c/ops/bind.c +++ b/src/c/ops/bind.c @@ -22,25 +22,19 @@ #include "payloads/function.h" #include "payloads/stack.h" -struct pso_pointer lisp_bind( +struct pso_pointer bind( #ifndef MANAGED_POINTER_ONLY struct pso4 *frame, #endif - struct pso_pointer frame_pointer, - struct pso_pointer env ) { + struct pso_pointer frame_pointer) { #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 ); + struct pso_pointer binding = cons( make_frame( 2, frame_pointer, key, value)); - return make_cons( make_cons( key, value ), store ); + return cons( make_frame( 2, frame_pointer, binding, store)); } -struct pso_pointer c_bind( struct pso_pointer key, - struct pso_pointer value, - struct pso_pointer store ) { - // todo: issue #21: must have stack frame passed in. - return make_cons( make_cons( key, value ), store ); -} diff --git a/src/c/ops/eq.c b/src/c/ops/eq.c index 101ea51..5725ce4 100644 --- a/src/c/ops/eq.c +++ b/src/c/ops/eq.c @@ -99,8 +99,7 @@ struct pso_pointer eq( #ifndef MANAGED_POINTER_ONLY struct pso4 *frame, #endif - struct pso_pointer frame_pointer, - struct pso_pointer env ) { + struct pso_pointer frame_pointer ) { #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); @@ -139,8 +138,7 @@ struct pso_pointer equal( #ifndef MANAGED_POINTER_ONLY struct pso4 *frame, #endif - struct pso_pointer frame_pointer, - struct pso_pointer env ) { + struct pso_pointer frame_pointer ) { #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); diff --git a/src/c/ops/eq.h b/src/c/ops/eq.h index a669a10..98e8ddc 100644 --- a/src/c/ops/eq.h +++ b/src/c/ops/eq.h @@ -20,24 +20,19 @@ 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 frame_pointer ); struct pso_pointer equal( #ifndef MANAGED_POINTER_ONLY struct pso4 *frame, #endif - struct pso_pointer frame_pointer, - struct pso_pointer env ); + struct pso_pointer frame_pointer); #endif diff --git a/src/c/ops/eval_apply.c b/src/c/ops/eval_apply.c index 7d39ca2..3ff6ce8 100644 --- a/src/c/ops/eval_apply.c +++ b/src/c/ops/eval_apply.c @@ -35,8 +35,7 @@ struct pso_pointer apply( #ifndef MANAGED_POINTER_ONLY struct pso4 *frame, #endif - struct pso_pointer frame_pointer, - struct pso_pointer env ) { + struct pso_pointer frame_pointer) { #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); #endif @@ -54,8 +53,7 @@ struct pso_pointer eval( #ifndef MANAGED_POINTER_ONLY struct pso4 *frame, #endif - struct pso_pointer frame_pointer, - struct pso_pointer env ) { + struct pso_pointer frame_pointer) { #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); #endif @@ -71,7 +69,7 @@ struct pso_pointer eval( // self evaluating break; case SYMBOLTV: - result = c_assoc( result, env ); + result = c_assoc( result, fetch_env(frame_pointer) ); break; // case LAMBDATV: // result = eval_lambda( frame, frame_pointer, env); diff --git a/src/c/ops/list_ops.c b/src/c/ops/list_ops.c index 8036c47..a4dc20a 100644 --- a/src/c/ops/list_ops.c +++ b/src/c/ops/list_ops.c @@ -1,5 +1,5 @@ /** - * ops/list_ops.h + * ops/list_ops.c * * Post Scarcity Software Environment: list_ops. * @@ -8,65 +8,22 @@ * (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/pso2.h" #include "memory/pso4.h" -#include "memory/tags.h" -#include "ops/stack_ops.h" - -#include "payloads/cons.h" #include "payloads/stack.h" +#include "ops/truth.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 length( struct pso_pointer frame_pointer) { + struct pso_pointer list = fetch_arg( frame_pointer, 0); + int count = 0; + + for ( struct pso_pointer cursor = list; !nilp( cursor); + cursor = cdr( make_frame( 1, frame_pointer, list))) { + count++; + } + + return make_integer( pointer_to_pso4(frame_pointer), count); } - -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( frame, 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 make_cons( frame, 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 index 0121b57..502577f 100644 --- a/src/c/ops/list_ops.h +++ b/src/c/ops/list_ops.h @@ -17,25 +17,5 @@ #include "payloads/function.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 ); - +struct pso_pointer length( struct pso_pointer frame_pointer); #endif diff --git a/src/c/ops/stack_ops.c b/src/c/ops/stack_ops.c index 0fd28c5..ccadf42 100644 --- a/src/c/ops/stack_ops.c +++ b/src/c/ops/stack_ops.c @@ -10,6 +10,7 @@ #include "memory/node.h" #include "memory/pso2.h" #include "memory/pso4.h" +#include "memory/tags.h" #include "payloads/stack.h" /** @@ -21,6 +22,8 @@ uint32_t stack_limit = 0; /** * Fetch a pointer to the value of the local variable at this index. + * + * TODO: I think the first argument would be better as a pso_pointer. */ struct pso_pointer fetch_arg( struct pso4 *frame, unsigned int index ) { struct pso_pointer result = nil; @@ -40,3 +43,15 @@ struct pso_pointer fetch_arg( struct pso4 *frame, unsigned int index ) { return result; } + +/** + * @brief Return the environment from the stack frame identified by this + * `frame_pointer` + * + * @param frame_pointer a pointer to a stack frame. + */ +struct pso_pointer fetch_env( struct pso_pointer frame_pointer) { + return stackp(frame_pointer) ? + pointer_to_pso4(frame_pointer)->payload.stack_frame.env : + nil; +} diff --git a/src/c/ops/stack_ops.h b/src/c/ops/stack_ops.h index 837d49a..3601724 100644 --- a/src/c/ops/stack_ops.h +++ b/src/c/ops/stack_ops.h @@ -27,4 +27,6 @@ extern uint32_t stack_limit; struct pso_pointer fetch_arg( struct pso4 *frame, unsigned int index ); +struct pso_pointer fetch_env( struct pso_pointer frame_pointer); + #endif diff --git a/src/c/payloads/cons.c b/src/c/payloads/cons.c index 730c14b..6963fbb 100644 --- a/src/c/payloads/cons.c +++ b/src/c/payloads/cons.c @@ -26,11 +26,12 @@ * @brief allocate a cons cell with this car and this cdr, and return a pointer * to it. * - * @param car the pointer which should form the car of this cons cell; - * @param cdr the pointer which should form the cdr of this cons cell. + * (cons object object) + * + * @param frame_pointer a pointer to a stack frame. * @return struct pso_pointer a pointer to the newly allocated cons cell. */ -struct pso_pointer make_cons( struct pso_pointer frame_pointer ) { +struct pso_pointer cons( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer result = allocate( frame, CONSTAG, 2 ); @@ -49,18 +50,28 @@ struct pso_pointer make_cons( struct pso_pointer frame_pointer ) { /** * @brief return the car of this cons cell. * - * @param cons a pointer to the cell. + * (car cell) + * + * @param frame_pointer a pointer to a stack frame. * @return the car of the indicated cell. * @exception if the pointer does not indicate a cons cell. */ -struct pso_pointer c_car( struct pso_pointer cons ) { +struct pso_pointer car( struct pso_pointer frame_pointer ) { struct pso_pointer result = nil; + struct pso_pointer cons = fetch_arg( pointer_to_pso4( frame_pointer), 0); struct pso2 *object = pointer_to_object( cons ); if ( consp( cons ) ) { result = object->payload.cons.car; - } - // TODO: else throw an exception + } else { + result = + make_exception( make_frame( 2, frame_pointer, + c_string_to_lisp_string( frame_pointer, L"Invalid type for car" ), + make_cons( + make_cons( frame_pointer, + c_string_to_lisp_keyword( frame_pointer, L"type" ), + get_tag_string( cons )), nil))); + } return result; } @@ -68,14 +79,17 @@ struct pso_pointer c_car( struct pso_pointer cons ) { /** * @brief return the cdr of this cons (or other sequence) cell. * - * @param cons a pointer to the cell. + * (cdr cell) + * + * @param frame_pointer a pointer to a stack frame. * @return the cdr of the indicated cell. * @exception if the pointer does not indicate a cons cell. */ -struct pso_pointer c_cdr( struct pso4 *stack_pointer, struct pso_pointer p ) { - // todo: issue #21: must have stack frame passed in. +struct pso_pointer cdr( struct pso_pointer frame_pointer ) { struct pso_pointer result = nil; - struct pso2 *object = pointer_to_object( p ); + struct pso4 *sp = pointer_to_pso4(frame_pointer); + struct pso_pointer cons = fetch_arg(sp, 0); + struct pso2 *object = pointer_to_object( cons ); switch ( get_tag_value( p ) ) { case CONSTV: @@ -88,15 +102,15 @@ struct pso_pointer c_cdr( struct pso4 *stack_pointer, struct pso_pointer p ) { break; default: result = - make_exception( make_cons - ( stack_pointer, c_string_to_lisp_string - ( stack_pointer, L"Invalid type for cdr" ), - get_tag_string( p ) ), nil, nil, nil ); + make_exception( make_frame( 2, frame_pointer, + c_string_to_lisp_string( frame_pointer, L"Invalid type for cdr" ), + make_cons( + make_cons( frame_pointer, + c_string_to_lisp_keyword( frame_pointer, L"type" ), + get_tag_string( cons )), nil))); break; } - // TODO: else throw an exception - return result; } diff --git a/src/c/payloads/cons.h b/src/c/payloads/cons.h index 21b2334..62fd5ff 100644 --- a/src/c/payloads/cons.h +++ b/src/c/payloads/cons.h @@ -27,14 +27,11 @@ struct cons_payload { struct pso_pointer cdr; }; -struct pso_pointer c_car( struct pso_pointer cons ); +struct pso_pointer car( struct pso_pointer frame_pointer ); -struct pso_pointer c_cdr( struct pso4 *stack_pointer, - struct pso_pointer cons ); +struct pso_pointer cdr( struct pso_pointer frame_pointer ); -// todo: issue #21: must have stack frame passed in. -struct pso_pointer make_cons( struct pso4 *stack_pointer, - struct pso_pointer car, struct pso_pointer cdr ); +struct pso_pointer cons( struct pso_pointer frame_pointer ); struct pso_pointer destroy_cons( struct pso_pointer fp, struct pso_pointer env ); diff --git a/src/c/payloads/exception.c b/src/c/payloads/exception.c index 28da143..bf7a225 100644 --- a/src/c/payloads/exception.c +++ b/src/c/payloads/exception.c @@ -23,6 +23,8 @@ * @brief allocate an exception object, and, if successful, return a pointer * to it. * + * (exception message meta cause) + * * Throwing an exception while generating an exception is meaningless. If * allocation fails utterly (i.e. out of heap, out of page space) this will * have to return `nil`, which might give rise to hard to trace bugs. But @@ -34,10 +36,13 @@ * or `nil` * @param cause the exception that caused this exception to be `thrown`. */ -struct pso_pointer make_exception( struct pso_pointer message, - struct pso_pointer frame, - struct pso_pointer meta, - struct pso_pointer cause ) { +struct pso_pointer make_exception( struct pso_pointer frame_pointer) { + struct pso4* frame = pointer_to_pso4( frame_pointer); + struct pso_pointer message = fetch_arg(frame, 0); + struct pso_pointer previous = frame->payload.stack_frame.previous; + struct pso_pointer meta = fetch_arg( frame, 1); + struct pso_pointer cause = fetch_arg( frame, 2); + struct pso_pointer result = allocate( pointer_to_pso4( frame ), EXCEPTIONTAG, 3 ); diff --git a/src/c/payloads/function.h b/src/c/payloads/function.h index 94bbb61..2ab1a54 100644 --- a/src/c/payloads/function.h +++ b/src/c/payloads/function.h @@ -37,8 +37,7 @@ struct function_payload { * to the Lisp function are assumed to be loaded into the frame before * invocation. */ - struct pso_pointer ( *executable ) ( struct pso_pointer frame_pointer, - struct pso_pointer env ); + struct pso_pointer ( *executable ) ( struct pso_pointer frame_pointer ); #else /** * pointer to a C function which takes an unmanaged pointer to a stack frame, @@ -47,8 +46,7 @@ struct function_payload { * loaded into the frame before invocation. */ struct pso_pointer ( *executable ) ( struct pso4 * frame, - struct pso_pointer frame_pointer, - struct pso_pointer env ); + struct pso_pointer frame_pointer ); #endif }; diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index c2acfb2..916c5c6 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -37,63 +37,63 @@ * passed to the Lisp function. */ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, - struct pso_pointer env, ... ) { + ... ) { va_list args; - va_start( args, env ); + va_start( args, previous ); - struct pso4 *frame = pointer_to_pso4( previous ); - struct pso_pointer frame_pointer = + struct pso4 *prev_frame = pointer_to_pso4( previous ); + struct pso_pointer new_pointer = allocate( pointer_to_pso4( previous ), STACKTAG, 4 ); + struct pso4* new_frame = pointer_to_pso4(new_pointer); #ifdef DEBUG debug_printf( DEBUG_ALLOC, 0, L"\nAllocating stack frame with %d arguments at page %d, " L"offset %d...\n", - arg_count, frame_pointer.page, frame_pointer.offset ); + arg_count, new_pointer.page, new_pointer.offset ); #endif - frame->payload.stack_frame.previous = previous; + prev_frame->payload.stack_frame.previous = previous; if ( stackp( previous ) ) { - struct pso4 *op = pointer_to_pso4( previous ); - frame->payload.stack_frame.depth = op->payload.stack_frame.depth + 1; - frame->payload.stack_frame.env = op->payload.stack_frame.env; + new_frame->payload.stack_frame.depth = prev_frame->payload.stack_frame.depth + 1; + new_frame->payload.stack_frame.env = prev_frame->payload.stack_frame.env; } else { - frame->payload.stack_frame.depth = 0; + new_frame->payload.stack_frame.depth = 0; } debug_printf( DEBUG_ALLOC, 1, L"depth is %d...\n", - frame->payload.stack_frame.depth ); + new_frame->payload.stack_frame.depth ); int cursor = 0; - frame->payload.stack_frame.args = arg_count; + new_frame->payload.stack_frame.args = arg_count; for ( ; cursor < arg_count && cursor < args_in_frame; cursor++ ) { struct pso_pointer argument = va_arg( args, struct pso_pointer ); - frame->payload.stack_frame.arg[cursor] = inc_ref( argument ); + new_frame->payload.stack_frame.arg[cursor] = inc_ref( argument ); } if ( cursor < arg_count ) { struct pso_pointer more_args = nil; for ( ; cursor < arg_count; cursor++ ) { more_args = - make_cons( frame, va_arg( args, struct pso_pointer ), + make_cons( prev_frame, va_arg( args, struct pso_pointer ), more_args ); } - frame->payload.stack_frame.more = c_reverse( more_args ); + new_frame->payload.stack_frame.more = c_reverse( more_args ); } else { for ( ; cursor < args_in_frame; cursor++ ) { - frame->payload.stack_frame.arg[cursor] = nil; + new_frame->payload.stack_frame.arg[cursor] = nil; } } debug_printf( DEBUG_ALLOC, 1, - L"Allocation of frame at page %d, offset %d completed.\n", - frame_pointer.page, frame_pointer.offset ); + L"Allocation of stack frame at page %d, offset %d completed.\n", + new_pointer.page, new_pointer.offset ); - return frame_pointer; + return new_pointer; } /** @@ -115,59 +115,131 @@ struct pso_pointer make_frame_with_env( int arg_count, va_list args; va_start( args, env ); - struct pso4 *frame = pointer_to_pso4( previous ); - struct pso_pointer frame_pointer = + struct pso4 *prev_frame = pointer_to_pso4( previous ); + struct pso_pointer new_pointer = allocate( pointer_to_pso4( previous ), STACKTAG, 4 ); + struct pso4* new_frame = pointer_to_pso4(new_pointer); #ifdef DEBUG debug_printf( DEBUG_ALLOC, 0, L"\nAllocating stack frame with %d arguments at page %d, " L"offset %d...\n", - arg_count, frame_pointer.page, frame_pointer.offset ); + arg_count, new_pointer.page, new_pointer.offset ); #endif - frame->payload.stack_frame.previous = previous; + prev_frame->payload.stack_frame.previous = previous; if ( stackp( previous ) ) { - struct pso4 *op = pointer_to_pso4( previous ); - frame->payload.stack_frame.depth = op->payload.stack_frame.depth + 1; - frame->payload.stack_frame.env = env; + new_frame->payload.stack_frame.depth = prev_frame->payload.stack_frame.depth + 1; + new_frame->payload.stack_frame.env = env; } else { - frame->payload.stack_frame.depth = 0; + new_frame->payload.stack_frame.depth = 0; } debug_printf( DEBUG_ALLOC, 1, L"depth is %d...\n", - frame->payload.stack_frame.depth ); + new_frame->payload.stack_frame.depth ); int cursor = 0; - frame->payload.stack_frame.args = arg_count; + new_frame->payload.stack_frame.args = arg_count; for ( ; cursor < arg_count && cursor < args_in_frame; cursor++ ) { struct pso_pointer argument = va_arg( args, struct pso_pointer ); - frame->payload.stack_frame.arg[cursor] = inc_ref( argument ); + new_frame->payload.stack_frame.arg[cursor] = inc_ref( argument ); } if ( cursor < arg_count ) { struct pso_pointer more_args = nil; for ( ; cursor < arg_count; cursor++ ) { more_args = - make_cons( frame, va_arg( args, struct pso_pointer ), + make_cons( prev_frame, va_arg( args, struct pso_pointer ), more_args ); } - frame->payload.stack_frame.more = c_reverse( more_args ); + new_frame->payload.stack_frame.more = c_reverse( more_args ); } else { for ( ; cursor < args_in_frame; cursor++ ) { - frame->payload.stack_frame.arg[cursor] = nil; + new_frame->payload.stack_frame.arg[cursor] = nil; } } debug_printf( DEBUG_ALLOC, 1, - L"Allocation of frame at page %d, offset %d completed.\n", - frame_pointer.page, frame_pointer.offset ); + L"Allocation of stack frame at page %d, offset %d completed.\n", + new_pointer.page, new_pointer.offset ); - return frame_pointer; + return new_pointer; +} + +/** + * @brief variant make_frame where arg values are available as a Lisp list, + * and an explicit (because modified) environment is to be passed.. + * + * @param previous pointer to the previous stack frame. + * @param argvalues values for the arguments to be placed in the frame. + * @param end the environment to be linked in the new frame. + * + * @return pointer to the new frame. + */ +struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer previous, struct pso_pointer argvalues, + struct pso_pointer env) { + struct pso4 *prev_frame = pointer_to_pso4( previous ); + struct pso_pointer new_pointer = + allocate( pointer_to_pso4( previous ), STACKTAG, 4 ); + struct pso4* new_frame = pointer_to_pso4(new_pointer); + int arg_count = c_length(argvalues); + +#ifdef DEBUG + debug_printf( DEBUG_ALLOC, 0, + L"\nAllocating stack frame with %d arguments at page %d, " + L"offset %d...\n", + arg_count, new_pointer.page, new_pointer.offset ); +#endif + + prev_frame->payload.stack_frame.previous = previous; + + if ( stackp( previous ) ) { + new_frame->payload.stack_frame.depth = prev_frame->payload.stack_frame.depth + 1; + new_frame->payload.stack_frame.env = inc_ref( prev_frame->payload.stack_frame.env); + } else { + new_frame->payload.stack_frame.depth = 0; + } + + debug_printf( DEBUG_ALLOC, 1, L"depth is %d...\n", + new_frame->payload.stack_frame.depth ); + + int cursor = 0; + new_frame->payload.stack_frame.args = arg_count; + + for ( ; cursor < arg_count && cursor < args_in_frame; cursor++ ) { + + new_frame->payload.stack_frame.arg[cursor] = inc_ref( make_frame( 1, previous, car(argvalues))); + argvalues = cdr( make_frame( 1, previous, argvalues)); + } + if ( cursor < arg_count ) { + new_frame->payload.stack_frame.more = inc_ref( cursor); + } else { + for ( ; cursor < args_in_frame; cursor++ ) { + new_frame->payload.stack_frame.arg[cursor] = nil; + } + } + + debug_printf( DEBUG_ALLOC, 1, + L"Allocation of stack frame at page %d, offset %d completed.\n", + new_pointer.page, new_pointer.offset ); + + return new_pointer; +} + +/** + * @brief variant make_frame where arg values are available as a Lisp list. + * + * @param previous pointer to the previous stack frame. + * @param argvalues values for the arguments to be placed in the frame. + * + * @return pointer to the new frame. + */ +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); }