simon/post-scarcity
1
0
Fork 0
Code Issues 18 Pull requests Projects Releases Packages Wiki Activity Actions

Print is less badly broken. Read is less badly broken. GC is too aggressive.

Browse source
This commit is contained in:
Simon Brooke 2026-04-24 21:20:23 +01:00
parent 22b0160a26
commit 63906fe817
19 changed files with 489 additions and 303 deletions
Download patch file Download diff file Expand all files Collapse all files

17
src/c/ops/assoc.c
View file

@ -11,6 +11,7 @@
#include <stdbool.h>
#include "debug.h"
#include "memory/node.h"
#include "memory/pointer.h"
#include "memory/pso2.h"
@ -40,15 +41,31 @@ struct pso_pointer search( struct pso_pointer key,
struct pso_pointer result = nil;
bool found = false;
#ifdef DEBUG
debug_print( L"In search; key is: ", DEBUG_BIND, 0 );
debug_print_object( key, DEBUG_BIND, 0 );
debug_println( DEBUG_BIND );
#endif
if ( consp( store ) ) {
for ( struct pso_pointer cursor = store;
consp( cursor ) && found == false; cursor = c_cdr( cursor ) ) {
struct pso_pointer pair = c_car( cursor );
#ifdef DEBUG
debug_print( L"Checking ", DEBUG_BIND, 2 );
debug_print_object( pair, DEBUG_BIND, 0 );
#endif
if ( consp( pair ) && c_equal( c_car( pair ), key ) ) {
found = true;
result = return_key ? c_car( pair ) : c_cdr( pair );
#ifdef DEBUG
debug_print( L" ...found!", DEBUG_BIND, 0 );
#endif
}
#ifdef DEBUG
debug_println( DEBUG_BIND );
#endif
}
}

3
src/c/ops/eq.c
View file

@ -41,7 +41,7 @@ bool c_eq( struct pso_pointer a, struct pso_pointer b ) {
}
bool c_equal( struct pso_pointer a, struct pso_pointer b ) {
bool result = true;
bool result = false;
if ( c_eq( a, b ) ) {
result = true;
@ -73,6 +73,7 @@ bool c_equal( struct pso_pointer a, struct pso_pointer b ) {
b = c_cdr( b );
} else {
result = false;
break;
}
}
result = result && c_nilp( a ) && c_nilp( b );

112
src/c/ops/eval_apply.c
View file

@ -10,9 +10,11 @@
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include "debug.h"
#include "memory/node.h"
#include "memory/pointer.h"
#include "memory/pso.h"
#include "memory/pso2.h"
#include "memory/pso3.h"
#include "memory/pso4.h"
#include "memory/tags.h"
@ -48,57 +50,67 @@ struct pso_pointer eval( struct pso_pointer frame_pointer ) {
struct pso_pointer arg = fetch_arg( frame, 0 );
struct pso_pointer result = nil;
switch ( get_tag_value( arg ) ) {
// case CONSTV:
// result = eval_cons( frame, frame_pointer, env);
// break;
case INTEGERTV:
case KEYTV:
case STRINGTV:
// self evaluating
result = nil;
break;
case SYMBOLTV:
arg = c_assoc( arg, fetch_env( frame_pointer ) );
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:
arg =
make_exception( make_frame( 1, frame_pointer,
make_cons( frame_pointer,
c_string_to_lisp_string
( frame_pointer,
L"Can't yet evaluate things of this type: " ),
arg ),
make_cons( frame_pointer,
make_cons
( frame_pointer,
c_string_to_lisp_keyword
( frame_pointer,
L"tag" ),
get_tag_string
( frame_pointer,
arg ) ), nil ),
nil ) );
}
if ( exceptionp( arg ) ) {
struct pso3 *x =
( struct pso3 * ) pointer_to_object_with_tag_value( arg,
EXCEPTIONTV );
if ( c_nilp( x->payload.exception.stack ) ) {
if ( !c_nilp( arg ) ) {
switch ( get_tag_value( arg ) ) {
// case CONSTV:
// result = eval_cons( frame, frame_pointer, env);
// break;
case INTEGERTV:
case KEYTV:
case NILTV:
case STRINGTV:
// self evaluating
result = nil;
break;
case SYMBOLTV:
result = c_assoc( arg, fetch_env( frame_pointer ) );
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:
#ifdef DEBUG
struct pso2 *object = pointer_to_object( arg );
debug_printf( DEBUG_EVAL, 0,
L"Can't yet evaluate objects of type %3.3s\n",
object->header.tag.bytes.mnemonic[0] );
debug_print_object( arg, DEBUG_EVAL, 2 );
debug_println( DEBUG_EVAL );
#endif
result = make_exception( make_frame( 1, frame_pointer,
make_cons( frame_pointer,
c_string_to_lisp_string
( frame_pointer,
L"Can't yet evaluate things of this type: " ),
arg ),
make_cons( frame_pointer,
make_cons
( frame_pointer,
c_string_to_lisp_keyword
( frame_pointer,
L"tag" ),
get_tag_string
( frame_pointer,
arg ) ),
nil ), nil ) );
}
}
return arg;
if ( exceptionp( result ) ) {
struct pso3 *x =
( struct pso3 * ) pointer_to_object_with_tag_value( result,
EXCEPTIONTV );
if ( c_nilp( x->payload.exception.stack ) ) {
x->payload.exception.stack = frame_pointer;
}
}
return result;
}

25
src/c/ops/repl.c
View file

@ -72,10 +72,11 @@ void repl( struct pso_pointer frame_pointer ) {
while ( readp( input_stream ) &&
!url_feof( stream_get_url_file( input_stream ) ) ) {
if ( show_prompt )
if ( show_prompt ) {
princ( make_frame( 2, frame_pointer,
c_assoc( lisp_io_prompt, env ),
output_stream ) );
}
/* the reason for initialising a new stack for each REPL input is to
* be sure the old stack is fully torn down and reclaimed. Once I'm
@ -86,13 +87,21 @@ void repl( struct pso_pointer frame_pointer ) {
consp( oblist ) ? oblist :
make_cons( nil, oblist, nil ) ) );
print( make_frame
( 2, base_of_stack,
eval( make_frame
( 1, base_of_stack,
read( make_frame
( 1, base_of_stack, input_stream ) ) ) ),
output_stream ) );
struct pso_pointer next =
inc_ref( make_frame( 1, base_of_stack, input_stream ) );
struct pso_pointer read_value = inc_ref( read( next ) );
dec_ref( next );
next = inc_ref( make_frame( 1, base_of_stack, read_value ) );
struct pso_pointer eval_value = inc_ref( eval( next ) );
dec_ref( next );
dec_ref( read_value );
next =
inc_ref( make_frame
( 2, base_of_stack, eval_value, output_stream ) );
print( next );
dec_ref( next );
dec_ref( base_of_stack );
}

25
src/c/ops/stack_ops.c
View file

@ -8,9 +8,12 @@
*/
#include "memory/node.h"
#include "memory/pointer.h"
#include "memory/pso2.h"
#include "memory/pso4.h"
#include "memory/tags.h"
#include "payloads/cons.h"
#include "payloads/stack.h"
/**
@ -54,3 +57,25 @@ struct pso_pointer fetch_env( struct pso_pointer frame_pointer ) {
return stackp( frame_pointer ) ?
pointer_to_pso4( frame_pointer )->payload.stack_frame.env : nil;
}
/**
* Push a binding (and therefore a reference) for this `local` onto the
* stack_frame indicated by this `frame_pointer`, thereby protecting the
* `local` from garbage collection until the frame itself is disposed of.
*
* This is a hack. For Lisp functions, where the stack frames are set up
* and torn down by eval/apply, it shouldn't be necessary.
*/
struct pso_pointer push_local( struct pso_pointer frame_pointer,
struct pso_pointer local ) {
if ( stackp( frame_pointer ) ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer l =
make_cons( frame_pointer, local,
frame->payload.stack_frame.locals );
frame->payload.stack_frame.locals = l;
}
return local;
}

3
src/c/ops/stack_ops.h
View file

@ -29,4 +29,7 @@ struct pso_pointer fetch_arg( struct pso4 *frame, unsigned int index );
struct pso_pointer fetch_env( struct pso_pointer frame_pointer );
struct pso_pointer push_local( struct pso_pointer frame_pointer,
struct pso_pointer local );
#endif