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

Woohoo! Huge decrease in cells not cleaned up, with fixing one stupid bug.

Browse source
This commit is contained in:
Simon Brooke 2026-02-13 12:50:02 +00:00
parent 004ff6737c
commit f6d7fcea1e
12 changed files with 93 additions and 293 deletions
Download patch file Download diff file Expand all files Collapse all files

3
src/arith/integer.c
View file

@ -272,9 +272,12 @@ struct cons_pointer add_integers( struct cons_pointer a,
return result;
}
// TODO: I have really no idea what I was trying to do here, or why it could possibly be a good idea.
struct cons_pointer base_partial( int depth ) {
struct cons_pointer result = NIL;
debug_printf( DEBUG_ARITH, L"base_partial: depth = %d\n", depth);
for ( int i = 0; i < depth; i++ ) {
result = acquire_integer( 0, result );
}

40
src/init.c
View file

@ -37,6 +37,34 @@
#include "io/fopen.h"
#include "time/psse_time.h"
/**
* @brief If `pointer` is an exception, display that exception to stderr,
* decrement that exception, and return NIL; else return the pointer.
*
* @param pointer a cons pointer.
* @param location_descriptor a description of where the pointer was caught.
* @return struct cons_pointer
*/
struct cons_pointer check_exception( struct cons_pointer pointer, char * location_descriptor) {
struct cons_pointer result = NIL;
struct cons_space_object * object = &pointer2cell( pointer);
if ( exceptionp( pointer)) {
fprintf( stderr, "ERROR: Exception at %s: ", location_descriptor);
URL_FILE *ustderr = file_to_url_file( stderr );
fwide( stderr, 1 );
print( ustderr, object->payload.exception.payload );
free( ustderr );
dec_ref( pointer);
} else {
result = pointer;
}
return result;
}
/**
* Bind this compiled `executable` function, as a Lisp function, to
@ -55,7 +83,8 @@ void bind_function( wchar_t *name, struct cons_pointer ( *executable )
n ),
NIL ) );
deep_bind( n, make_function( meta, executable ) );
check_exception( deep_bind( n, make_function( meta, executable ) ),
"bind_function");
}
/**
@ -72,14 +101,17 @@ void bind_special( wchar_t *name, struct cons_pointer ( *executable )
n ),
NIL ) );
deep_bind( n, make_special( meta, executable ) );
check_exception(deep_bind( n, make_special( meta, executable ) ),
"bind_special");
}
/**
* Bind this `value` to this `name` in the `oblist`.
*/
struct cons_pointer bind_value( wchar_t *name, struct cons_pointer value ) {
return deep_bind( c_string_to_lisp_symbol( name ), value );
return check_exception(
deep_bind( c_string_to_lisp_symbol( name ), value ),
"bind_value");
}
void print_banner( ) {
@ -227,7 +259,7 @@ int main( int argc, char *argv[] ) {
/*
* the default prompt
*/
bind_value( L"*prompt*",
prompt_name = bind_value( L"*prompt*",
show_prompt ? c_string_to_lisp_symbol( L":: " ) : NIL );
/*
* primitive function operations

8
src/io/print.c
View file

@ -169,9 +169,11 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) {
print( output, cell.payload.function.meta );
url_fputwc( L'>', output );
break;
case INTEGERTV:{
case INTEGERTV:
if ( nilp( cell.payload.integer.more)) {
url_fwprintf( output, L"%ld", cell.payload.integer.value);
} else {
struct cons_pointer s = integer_to_string( pointer, 10 );
inc_ref( s );
print_string_contents( output, s );
dec_ref( s );
}
@ -186,7 +188,6 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) {
make_cons( c_string_to_lisp_symbol( L"\u03bb" ),
make_cons( cell.payload.lambda.args,
cell.payload.lambda.body ) );
inc_ref( to_print );
print( output, to_print );
@ -203,7 +204,6 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) {
make_cons( c_string_to_lisp_symbol( L"n\u03bb" ),
make_cons( cell.payload.lambda.args,
cell.payload.lambda.body ) );
inc_ref( to_print );
print( output, to_print );

8
src/memory/consspaceobject.c
View file

@ -201,7 +201,6 @@ struct cons_pointer make_exception( struct cons_pointer message,
struct cons_pointer pointer = allocate_cell( EXCEPTIONTV );
struct cons_space_object *cell = &pointer2cell( pointer );
inc_ref( message );
inc_ref( frame_pointer );
cell->payload.exception.payload = message;
cell->payload.exception.frame = frame_pointer;
@ -237,9 +236,6 @@ struct cons_pointer make_lambda( struct cons_pointer args,
struct cons_pointer pointer = allocate_cell( LAMBDATV );
struct cons_space_object *cell = &pointer2cell( pointer );
inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do
this, but if I don't the cell gets freed */
inc_ref( args );
inc_ref( body );
cell->payload.lambda.args = args;
@ -256,9 +252,6 @@ struct cons_pointer make_nlambda( struct cons_pointer args,
struct cons_pointer body ) {
struct cons_pointer pointer = allocate_cell( NLAMBDATV );
inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do
this, but if I don't the cell gets freed */
struct cons_space_object *cell = &pointer2cell( pointer );
inc_ref( args );
inc_ref( body );
@ -312,7 +305,6 @@ struct cons_pointer make_string_like_thing( wint_t c, struct cons_pointer tail,
pointer = allocate_cell( tag );
struct cons_space_object *cell = &pointer2cell( pointer );
inc_ref( tail );
cell->payload.string.character = c;
cell->payload.string.cdr.page = tail.page;
/* \todo There's a problem here. Sometimes the offsets on

4
src/memory/hashmap.c
View file

@ -87,9 +87,9 @@ struct cons_pointer lisp_make_hashmap( struct stack_frame *frame,
&( map->payload ) )->n_buckets;
map->payload.hashmap.buckets[bucket_no] =
inc_ref( make_cons( make_cons( key, val ),
make_cons( make_cons( key, val ),
map->payload.hashmap.
buckets[bucket_no] ) );
buckets[bucket_no] );
}
}
}

17
src/ops/intern.c
View file

@ -292,7 +292,7 @@ internedp( struct cons_pointer key, struct cons_pointer store ) {
// if ( equal( key, entry.payload.cons.car ) ) {
// result = entry.payload.cons.car;
// }
if (!nilp( c_assoc( store, key))) {
if (!nilp( c_assoc( key, store))) {
result = key;
}
} else {
@ -340,18 +340,23 @@ struct cons_pointer c_assoc( struct cons_pointer key,
result = hashmap_get( entry_ptr, key );
break;
default:
throw_exception( c_string_to_lisp_string
( L"Store entry is of unknown type" ),
NIL );
throw_exception( c_append(
c_string_to_lisp_string( L"Store entry is of unknown type: " ),
c_type( entry_ptr)), NIL);
}
}
}
} else if ( hashmapp( store ) ) {
result = hashmap_get( store, key );
} else if ( !nilp( store ) ) {
debug_print( L"c_assoc; store is of unknown type `", DEBUG_BIND );
debug_print_object( c_type( store), DEBUG_BIND );
debug_print( L"`\n", DEBUG_BIND );
result =
throw_exception( c_string_to_lisp_string
( L"Store is of unknown type" ), NIL );
throw_exception(
c_append(
c_string_to_lisp_string( L"Store is of unknown type: " ),
c_type( store)), NIL );
}
debug_print( L"c_assoc returning ", DEBUG_BIND );

72
src/ops/lispops.c
View file

@ -38,6 +38,13 @@
#include "memory/stack.h"
#include "memory/vectorspace.h"
/**
* @brief the name of the symbol to which the prompt is bound;
*
* Set in init to `*prompt*`
*/
struct cons_pointer prompt_name;
/*
* also to create in this section:
* struct cons_pointer lisp_let( struct cons_pointer args, struct cons_pointer env,
@ -46,7 +53,6 @@
* and others I haven't thought of yet.
*/
/**
* Useful building block; evaluate this single form in the context of this
* parent stack frame and this environment.
@ -1263,7 +1269,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
struct cons_pointer input = get_default_stream( true, env );
struct cons_pointer output = get_default_stream( false, env );
struct cons_pointer prompt_name = c_string_to_lisp_symbol( L"*prompt*" );
// struct cons_pointer prompt_name = c_string_to_lisp_symbol( L"*prompt*" );
struct cons_pointer old_oblist = oblist;
struct cons_pointer new_env = env;
@ -1558,43 +1564,35 @@ struct cons_pointer lisp_let( struct stack_frame *frame,
}
// /**
// * Function; print the internal representation of the object indicated by `frame->arg[0]` to the
// * (optional, defaults to the value of `*out*` in the environment) stream indicated by `frame->arg[1]`.
// *
// * * (inspect expression)
// * * (inspect expression <write-stream>)
// *
// * @param frame my stack frame.
// * @param frame_pointer a pointer to my stack_frame.
// * @param env the environment.
// * @return the value of the first argument - `expression`.
// */
// struct cons_pointer lisp_inspect( struct stack_frame *frame,
// struct cons_pointer frame_pointer,
// struct cons_pointer env ) {
// debug_print( L"Entering print\n", DEBUG_IO );
// URL_FILE *output;
// struct cons_pointer out_stream = writep( frame->arg[1] ) ?
// frame->arg[1] : get_default_stream( false, env );
// struct cons_pointer c_concat( struct cons_pointer a, struct cons_pointer b) {
// struct cons_pointer result = b;
// if ( writep( out_stream ) ) {
// debug_print( L"lisp_print: setting output stream\n", DEBUG_IO );
// debug_dump_object( out_stream, DEBUG_IO );
// output = pointer2cell( out_stream ).payload.stream.stream;
// inc_ref( out_stream );
// if ( nilp( b.tag.value)) {
// result = make_cons( a, b);
// } else {
// output = file_to_url_file( stdout );
// if ( ! nilp( a)) {
// if (a.tag.value == b.tag.value) {
// struct cons_pointer tail = c_concat( c_cdr( a), b);
// switch ( a.tag.value) {
// case CONSTV:
// result = make_cons( c_car( a), tail);
// break;
// case KEYTV:
// case STRINGTV:
// case SYMBOLTV:
// result = make_string_like_thing()
// }
// } else {
// // throw an exception
// }
// }
// }
// dump_object( output, frame->arg[0] );
// url_fputws( L"\n", output );
// if ( writep( out_stream ) ) {
// dec_ref( out_stream );
// } else {
// free( output );
// }
// return frame->arg[0];
// }
// return result;
// }

2
src/ops/lispops.h
View file

@ -22,6 +22,8 @@
#ifndef __psse_lispops_h
#define __psse_lispops_h
extern struct cons_pointer prompt_name;
/*
* utilities
*/

2
src/repl.c
View file

@ -41,8 +41,6 @@ void repl( ) {
struct cons_pointer frame_pointer = make_stack_frame( NIL, NIL, env );
if ( !nilp( frame_pointer ) ) {
inc_ref( frame_pointer );
lisp_repl( get_stack_frame( frame_pointer ), frame_pointer, env );
dec_ref( frame_pointer );