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

Converted everything to the new lisp calling convention.

Browse source 
Fixes #19
This commit is contained in:
Simon Brooke 2026-04-01 17:11:10 +01:00
parent f3a26bc02e
commit b6480aebd5
53 changed files with 590 additions and 520 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -34,25 +34,23 @@
* return the binding.
*/
struct pso_pointer search( struct pso_pointer key,
struct pso_pointer store,
bool return_key ) {
struct pso_pointer result = nil;
bool found = false;
struct pso_pointer store, bool return_key ) {
struct pso_pointer result = nil;
bool found = false;
if (consp( store)) {
for ( struct pso_pointer cursor = store;
consp( store) && found == false;
cursor = cdr( cursor)) {
struct pso_pointer pair = car( cursor);
if ( consp( store ) ) {
for ( struct pso_pointer cursor = store;
consp( store ) && found == false; cursor = cdr( cursor ) ) {
struct pso_pointer pair = car( cursor );
if (consp(pair) && equal(car(pair), key)) {
found = true;
result = return_key ? car(pair) : cdr( pair);
}
}
}
if ( consp( pair ) && c_equal( car( pair ), key ) ) {
found = true;
result = return_key ? car( pair ) : cdr( pair );
}
}
}
return result;
return result;
}
/**
@ -63,8 +61,8 @@ 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) {
return search( key, store, false);
struct pso_pointer assoc( struct pso_pointer key, struct pso_pointer store ) {
return search( key, store, false );
}
/**
@ -75,8 +73,8 @@ 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) {
return search( key, store, true);
struct pso_pointer interned( struct pso_pointer key, struct pso_pointer store ) {
return search( key, store, true );
}
/**
@ -87,6 +85,6 @@ 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) {
return !nilp( search( key, store, true));
bool internedp( struct pso_pointer key, struct pso_pointer store ) {
return !nilp( search( key, store, true ) );
}

10
src/c/ops/assoc.h
View file

@ -17,12 +17,12 @@
#include "memory/pointer.h"
struct cons_pointer search( struct pso_pointer key,
struct pso_pointer store,
bool return_key );
struct pso_pointer store, bool return_key );
struct pso_pointer assoc( struct pso_pointer key, struct pso_pointer store);
struct pso_pointer assoc( struct pso_pointer key, struct pso_pointer store );
struct pso_pointer interned(struct pso_pointer key, struct pso_pointer store);
struct pso_pointer interned( struct pso_pointer key,
struct pso_pointer store );
bool internedp(struct pso_pointer key, struct pso_pointer store);
bool internedp( struct pso_pointer key, struct pso_pointer store );
#endif

29
src/c/ops/bind.c
View file

@ -22,24 +22,23 @@
#include "payloads/stack.h"
struct pso_pointer bind( struct pso_pointer frame_pointer,
struct pso_pointer env) {
struct pso4 *frame = pointer_to_pso4( frame_pointer);
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 env ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
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 cons( cons( key, value ), store );
}
struct pso_pointer c_bind( struct pso_pointer key,
struct pso_pointer value,
struct pso_pointer store) {
struct pso_pointer result = nil;
struct pso_pointer next = make_frame( nil, key, value, store);
inc_ref( next);
result = bind( next, nil);
dec_ref( next);
struct pso_pointer value,
struct pso_pointer store ) {
struct pso_pointer result = nil;
struct pso_pointer next = make_frame( nil, key, value, store );
inc_ref( next );
result = bind( next, nil );
dec_ref( next );
return result;
return result;
}

6
src/c/ops/bind.h
View file

@ -16,10 +16,10 @@
#include "memory/pointer.h"
struct pso_pointer bind( struct pso_pointer frame_pointer,
struct pso_pointer env);
struct pso_pointer env );
struct pso_pointer c_bind( struct pso_pointer key,
struct pso_pointer value,
struct pso_pointer store);
struct pso_pointer value,
struct pso_pointer store );
#endif

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

@ -33,47 +33,49 @@
* @param b another pointer;
* @return `true` if they are the same, else `false`
*/
bool eq( struct pso_pointer a, struct pso_pointer b ) {
bool c_eq( struct pso_pointer a, struct pso_pointer b ) {
return ( a.node == b.node && a.page == b.page && a.offset == b.offset );
}
bool equal( struct pso_pointer a, struct pso_pointer b) {
bool result = false;
bool c_equal( struct pso_pointer a, struct pso_pointer b ) {
bool result = false;
if ( eq( a, b)) {
result = true;
} else if ( get_tag_value(a) == get_tag_value(b)) {
struct pso2 *oa = pointer_to_object(a);
struct pso2 *ob = pointer_to_object(b);
if ( c_eq( a, b ) ) {
result = true;
} else if ( get_tag_value( a ) == get_tag_value( b ) ) {
struct pso2 *oa = pointer_to_object( a );
struct pso2 *ob = pointer_to_object( b );
switch ( get_tag_value(a)) {
case CHARACTERTV :
result = (oa->payload.character.character == ob->payload.character.character);
break;
case CONSTV :
result = (equal( car(a), car(b)) && equal( cdr(a), cdr(b)));
break;
case INTEGERTV :
result = (oa->payload.integer.value
==
ob->payload.integer.value);
break;
case KEYTV:
case STRINGTV :
case SYMBOLTV :
while (result == false && !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);
}
}
result = nilp(a) && nilp(b);
break;
}
}
switch ( get_tag_value( a ) ) {
case CHARACTERTV:
result =
( oa->payload.character.character ==
ob->payload.character.character );
break;
case CONSTV:
result = ( c_equal( car( a ), car( b ) )
&& c_equal( cdr( a ), cdr( b ) ) );
break;
case INTEGERTV:
result = ( oa->payload.integer.value
== ob->payload.integer.value );
break;
case KEYTV:
case STRINGTV:
case SYMBOLTV:
while ( result == false && !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 );
}
}
result = nilp( a ) && nilp( b );
break;
}
}
return result;
return result;
}
@ -89,9 +91,10 @@ bool equal( struct pso_pointer a, struct pso_pointer b) {
* @param env my environment (ignored).
* @return `t` if all args are pointers to the same object, else `nil`;
*/
struct pso_pointer lisp_eq( struct pso4 *frame,
struct pso_pointer frame_pointer,
struct pso_pointer env ) {
struct pso_pointer eq( struct pso_pointer frame_pointer,
struct pso_pointer env ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer result = t;
if ( frame->payload.stack_frame.args > 1 ) {
@ -99,11 +102,9 @@ struct pso_pointer lisp_eq( struct pso4 *frame,
( truep( result ) ) && ( b < frame->payload.stack_frame.args );
b++ ) {
result =
eq( fetch_arg( frame, 0 ), fetch_arg( frame, b ) ) ? t : nil;
c_eq( fetch_arg( frame, 0 ), fetch_arg( frame, b ) ) ? t : nil;
}
}
return result;
}

9
src/c/ops/eq.h
View file

@ -16,11 +16,10 @@
#include "memory/pointer.h"
#include "memory/pso4.h"
bool eq( struct pso_pointer a, struct pso_pointer b );
bool c_eq( struct pso_pointer a, struct pso_pointer b );
struct pso_pointer lisp_eq( struct pso4 *frame,
struct pso_pointer frame_pointer,
struct pso_pointer env );
struct pso_pointer eq( struct pso_pointer frame_pointer,
struct pso_pointer env );
bool equal( struct pso_pointer a, struct pso_pointer b);
bool c_equal( struct pso_pointer a, struct pso_pointer b );
#endif

30
src/c/ops/eval.c
View file

@ -10,7 +10,9 @@
*/
#include "memory/pointer.h"
#include "memory/pso.h"
#include "memory/pso2.h"
#include "memory/pso3.h"
#include "memory/pso4.h"
#include "memory/tags.h"
@ -23,6 +25,8 @@
#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.
*
@ -31,9 +35,9 @@
* @param env the evaluation environment.
* @return struct pso_pointer
*/
struct pso_pointer eval_despatch( struct pso4 *frame,
struct pso_pointer frame_pointer,
struct pso_pointer env ) {
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)) {
@ -55,17 +59,17 @@ struct pso_pointer eval_despatch( struct pso4 *frame,
// break;
// }
return result;
}
struct pso_pointer lisp_eval( struct pso4 *frame,
struct pso_pointer frame_pointer,
struct pso_pointer env ) {
struct pso_pointer result = eval_despatch( frame, frame_pointer, env );
if ( exceptionp( result ) ) {
// todo: if result doesn't have a stack frame, create a new exception wrapping
// result with this stack frame.
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;

2
src/c/ops/repl.h
View file

@ -12,4 +12,4 @@
// struct pso_pointer repl( struct pso_pointer prompt, struct pso_pointer readtable);
#endif
#endif

60
src/c/ops/reverse.c
View file

@ -35,31 +35,41 @@
* @return a sequence like the `sequence` passed, but reversed; or `nil` if
* the argument was not a sequence.
*/
struct pso_pointer reverse( struct pso_pointer sequence) {
struct pso_pointer result = nil;
struct pso_pointer reverse( struct pso_pointer sequence ) {
struct pso_pointer result = nil;
for (struct pso_pointer cursor = sequence; !nilp( sequence); cursor = cdr(cursor)) {
struct pso2* object = pointer_to_object( cursor);
switch (get_tag_value(cursor)) {
case CONSTV :
result = cons( car(cursor), result);
break;
case KEYTV :
result = make_string_like_thing( object->payload.string.character, result, KEYTAG);
break;
case STRINGTV :
result = make_string_like_thing( object->payload.string.character, result, STRINGTAG);
break;
case SYMBOLTV :
result = make_string_like_thing( object->payload.string.character, result, SYMBOLTAG);
break;
default :
result = make_exception( c_string_to_lisp_string(L"Invalid object in sequence"), nil, nil);
goto exit;
break;
}
}
exit:
for ( struct pso_pointer cursor = sequence; !nilp( sequence );
cursor = cdr( cursor ) ) {
struct pso2 *object = pointer_to_object( cursor );
switch ( get_tag_value( cursor ) ) {
case CONSTV:
result = cons( car( cursor ), result );
break;
case KEYTV:
result =
make_string_like_thing( object->payload.string.character,
result, KEYTAG );
break;
case STRINGTV:
result =
make_string_like_thing( object->payload.string.character,
result, STRINGTAG );
break;
case SYMBOLTV:
result =
make_string_like_thing( object->payload.string.character,
result, SYMBOLTAG );
break;
default:
result =
make_exception( c_string_to_lisp_string
( L"Invalid object in sequence" ), nil,
nil );
goto exit;
break;
}
}
exit:
return result;
return result;
}

2
src/c/ops/reverse.h
View file

@ -16,6 +16,6 @@
#include "memory/pointer.h"
struct pso_pointer reverse( struct pso_pointer sequence);
struct pso_pointer reverse( struct pso_pointer sequence );
#endif

10
src/c/ops/string_ops.c
View file

@ -42,7 +42,7 @@ uint32_t calculate_hash( wint_t c, struct pso_pointer ptr ) {
struct pso2 *cell = pointer_to_object( ptr );
uint32_t result = 0;
switch ( get_tag_value(ptr)) {
switch ( get_tag_value( ptr ) ) {
case KEYTV:
case STRINGTV:
case SYMBOLTV:
@ -70,22 +70,22 @@ uint32_t calculate_hash( wint_t c, struct pso_pointer ptr ) {
* (and thus simpler).
*/
struct pso_pointer make_string_like_thing( wint_t c, struct pso_pointer tail,
char* tag ) {
char *tag ) {
struct pso_pointer pointer = nil;
if ( check_type( tail, tag ) || check_tag( tail, NILTV ) ) {
pointer = allocate( tag, CONS_SIZE_CLASS);
pointer = allocate( tag, CONS_SIZE_CLASS );
struct pso2 *cell = pointer_to_object( pointer );
cell->payload.string.character = c;
cell->payload.string.cdr = tail;
cell->payload.string.hash = calculate_hash( c, tail);
cell->payload.string.hash = calculate_hash( c, tail );
debug_dump_object( pointer, DEBUG_ALLOC, 0 );
debug_println( DEBUG_ALLOC );
} else {
// \todo should throw an exception!
debug_printf( DEBUG_ALLOC, 0,
debug_printf( DEBUG_ALLOC, 0,
L"Warning: only %4.4s can be prepended to %4.4s\n",
tag, tag );
}

2
src/c/ops/string_ops.h
View file

@ -17,7 +17,7 @@
#include <wctype.h>
struct pso_pointer make_string_like_thing( wint_t c, struct pso_pointer tail,
char* tag );
char *tag );
struct pso_pointer make_string( wint_t c, struct pso_pointer tail );

28
src/c/ops/truth.c
View file

@ -13,6 +13,7 @@
#include "memory/node.h"
#include "memory/pointer.h"
#include "memory/pso4.h"
#include "ops/stack_ops.h"
/**
@ -64,10 +65,11 @@ bool truep( struct pso_pointer p ) {
* @param env the evaluation environment.
* @return `t` if the first argument in this frame is `nil`, else `t`
*/
struct pso_pointer lisp_nilp( struct pso4 *frame,
struct pso_pointer frame_pointer,
struct pso_pointer env ) {
return ( nilp( fetch_arg( frame, 0 )) ? t : nil );
struct pso_pointer lisp_nilp( struct pso_pointer frame_pointer,
struct pso_pointer env ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
return ( nilp( fetch_arg( frame, 0 ) ) ? t : nil );
}
/**
@ -78,10 +80,11 @@ return ( nilp( fetch_arg( frame, 0 )) ? t : nil );
* @param env the evaluation environment.
* @return `t` if the first argument in this frame is `t`, else `nil`.
*/
struct pso_pointer lisp_truep( struct pso4 *frame,
struct pso_pointer frame_pointer,
struct pso_pointer env ) {
return ( truep( fetch_arg( frame, 0 ) ) ? t : nil );
struct pso_pointer lisp_truep( struct pso_pointer frame_pointer,
struct pso_pointer env ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
return ( truep( fetch_arg( frame, 0 ) ) ? t : nil );
}
/**
@ -93,8 +96,9 @@ struct pso_pointer lisp_truep( struct pso4 *frame,
* @param env the evaluation environment.
* @return `t` if the first argument in this frame is not `nil`, else `t`.
*/
struct pso_pointer lisp_not( struct pso4 *frame,
struct pso_pointer frame_pointer,
struct pso_pointer env ) {
return ( not( fetch_arg( frame, 0 ) ) ? t : nil );
struct pso_pointer lisp_not( struct pso_pointer frame_pointer,
struct pso_pointer env ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
return ( not( fetch_arg( frame, 0 ) ) ? t : nil );
}

15
src/c/ops/truth.h
View file

@ -18,20 +18,17 @@
bool nilp( struct pso_pointer p );
struct pso_pointer lisp_nilp( struct pso4 *frame,
struct pso_pointer frame_pointer,
struct pso_pointer env );
struct pso_pointer lisp_nilp( struct pso_pointer frame_pointer,
struct pso_pointer env );
bool not( struct pso_pointer p );
struct pso_pointer lisp_not( struct pso4 *frame,
struct pso_pointer frame_pointer,
struct pso_pointer env );
struct pso_pointer lisp_not( struct pso_pointer frame_pointer,
struct pso_pointer env );
bool truep( struct pso_pointer p );
struct pso_pointer lisp_truep( struct pso4 *frame,
struct pso_pointer frame_pointer,
struct pso_pointer env );
struct pso_pointer lisp_truep( struct pso_pointer frame_pointer,
struct pso_pointer env );
#endif