simon/post-scarcity
1
0
Fork 0
Code Issues 14 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

10
archive/c/ops/equal.c
View file

@ -272,7 +272,7 @@ bool equal_map_map( struct cons_pointer a, struct cons_pointer b ) {
for ( struct cons_pointer i = keys_a; !nilp( i ); i = c_cdr( i ) ) {
struct cons_pointer key = c_car( i );
if ( !equal
if ( !c_equal
( hashmap_get( a, key, false ),
hashmap_get( b, key, false ) ) ) {
result = false;
@ -331,7 +331,7 @@ bool equal_vector_vector( struct cons_pointer a, struct cons_pointer b ) {
* Deep, and thus expensive, equality: true if these two objects have
* identical structure, else false.
*/
bool equal( struct cons_pointer a, struct cons_pointer b ) {
bool c_equal( struct cons_pointer a, struct cons_pointer b ) {
debug_print( L"\nequal: ", DEBUG_EQUAL );
debug_print_object( a, DEBUG_EQUAL );
debug_print( L" = ", DEBUG_EQUAL );
@ -353,8 +353,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
* structures can be of indefinite extent. It *must* be done by
* iteration (and even that is problematic) */
result =
equal( cell_a->payload.cons.car, cell_b->payload.cons.car )
&& equal( cell_a->payload.cons.cdr,
c_equal( cell_a->payload.cons.car, cell_b->payload.cons.car )
&& c_equal( cell_a->payload.cons.cdr,
cell_b->payload.cons.cdr );
break;
case KEYTV:
@ -401,7 +401,7 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
* isn't sufficient. So we recurse at least once. */
result = ( wcsncmp( a_buff, b_buff, i ) == 0 )
&& equal( c_cdr( a ), c_cdr( b ) );
&& c_equal( c_cdr( a ), c_cdr( b ) );
}
break;
case VECTORPOINTTV:

2
archive/c/ops/equal.h
View file

@ -31,6 +31,6 @@ bool eq( struct cons_pointer a, struct cons_pointer b );
* Deep, and thus expensive, equality: true if these two objects have
* identical structure, else false.
*/
bool equal( struct cons_pointer a, struct cons_pointer b );
bool c_equal( struct cons_pointer a, struct cons_pointer b );
#endif

4
archive/c/ops/intern.c
View file

@ -334,7 +334,7 @@ struct cons_pointer search_store( struct cons_pointer key,
switch ( get_tag_value( entry_ptr ) ) {
case CONSTV:
if ( equal( key, c_car( entry_ptr ) ) ) {
if ( c_equal( key, c_car( entry_ptr ) ) ) {
result =
return_key ? c_car( entry_ptr )
: c_cdr( entry_ptr );
@ -441,7 +441,7 @@ struct cons_pointer internedp( struct cons_pointer key,
for ( struct cons_pointer pair = c_car( store );
eq( result, NIL ) && !nilp( pair ); pair = c_car( store ) ) {
if ( consp( pair ) ) {
if ( equal( c_car( pair ), key ) ) {
if ( c_equal( c_car( pair ), key ) ) {
// yes, this should be `eq`, but if symbols are correctly
// interned this will work efficiently, and if not it will
// still work.

2
archive/c/ops/lispops.c
View file

@ -987,7 +987,7 @@ lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer,
if ( frame->args > 1 ) {
for ( int b = 1; ( truep( result ) ) && ( b < frame->args ); b++ ) {
result =
equal( frame->arg[0], fetch_arg( frame, b ) ) ? TRUE : NIL;
c_equal( frame->arg[0], fetch_arg( frame, b ) ) ? TRUE : NIL;
}
}

44
src/c/io/io.c
View file

@ -114,8 +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 = cdr( c ) ) {
len++;
}
@ -124,8 +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 = cdr( c ) ) {
buffer[i++] = pointer_to_object( c )->payload.string.character;
}
@ -265,7 +263,10 @@ struct pso_pointer get_character( struct pso_pointer read_stream ) {
struct pso_pointer result = nil;
if ( readp( read_stream ) ) {
result = make_character( url_fgetwc( pointer_to_object_of_size_class(read_stream, 2)->payload.stream.stream));
result =
make_character( url_fgetwc
( pointer_to_object_of_size_class
( read_stream, 2 )->payload.stream.stream ) );
}
return result;
@ -279,12 +280,16 @@ struct pso_pointer get_character( struct pso_pointer read_stream ) {
*
* @return `t` on success, else `nil`.
*/
struct pso_pointer push_back_character( struct pso_pointer c, struct pso_pointer r) {
struct pso_pointer push_back_character( struct pso_pointer c,
struct pso_pointer r ) {
struct pso_pointer result = nil;
if ( characterp( c ) && readp( r ) ) {
if (url_ungetwc( (wint_t)(pointer_to_object(c)->payload.character.character),
pointer_to_object(r)->payload.stream.stream) >= 0) {
if ( url_ungetwc( ( wint_t )
( pointer_to_object( c )->payload.character.
character ),
pointer_to_object( r )->payload.stream.stream ) >=
0 ) {
result = t;
}
}
@ -304,12 +309,14 @@ struct pso_pointer push_back_character( struct pso_pointer c, struct pso_pointer
* @return T if the stream was successfully closed, else nil.
*/
struct pso_pointer
lisp_close( struct pso4 *frame, struct pso_pointer frame_pointer,
struct pso_pointer env ) {
lisp_close( struct pso_pointer frame_pointer, struct pso_pointer env ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer result = nil;
if ( readp( fetch_arg( frame, 0 ) ) || writep( fetch_arg( frame, 0 ) ) ) {
if ( url_fclose( pointer_to_object( fetch_arg( frame, 0) )->payload.stream.stream )
if ( url_fclose
( pointer_to_object( fetch_arg( frame, 0 ) )->payload.
stream.stream )
== 0 ) {
result = t;
}
@ -489,8 +496,8 @@ struct pso_pointer get_default_stream( bool inputp, struct pso_pointer env ) {
* on my stream, if any, else nil.
*/
struct pso_pointer
lisp_open( struct pso4 *frame, struct pso_pointer frame_pointer,
struct pso_pointer env ) {
lisp_open( struct pso_pointer frame_pointer, struct pso_pointer env ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer result = nil;
// if ( stringp( fetch_arg( frame, 0) ) ) {
@ -556,8 +563,8 @@ lisp_open( struct pso4 *frame, struct pso_pointer frame_pointer,
* on my stream, if any, else nil.
*/
struct pso_pointer
lisp_read_char( struct pso4 *frame, struct pso_pointer frame_pointer,
struct pso_pointer env ) {
lisp_read_char( struct pso_pointer frame_pointer, struct pso_pointer env ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer result = nil;
if ( readp( fetch_arg( frame, 0 ) ) ) {
@ -585,12 +592,13 @@ lisp_read_char( struct pso4 *frame, struct pso_pointer frame_pointer,
* on my stream, if any, else nil.
*/
struct pso_pointer
lisp_slurp( struct pso4 *frame, struct pso_pointer frame_pointer,
struct pso_pointer env ) {
lisp_slurp( struct pso_pointer frame_pointer, struct pso_pointer env ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer result = nil;
if ( readp( fetch_arg( frame, 0 ) ) ) {
URL_FILE *stream = pointer_to_object( fetch_arg( frame, 0) )->payload.stream.stream;
URL_FILE *stream =
pointer_to_object( fetch_arg( frame, 0 ) )->payload.stream.stream;
struct pso_pointer cursor = make_string( url_fgetwc( stream ), nil );
result = cursor;

19
src/c/io/io.h
View file

@ -8,8 +8,8 @@
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __psse_io_h
#define __psse_io_h
#ifndef __psse_io_io_h
#define __psse_io_io_h
#include <curl/curl.h>
#include "memory/pointer.h"
@ -32,22 +32,19 @@ wint_t url_ungetwc( wint_t wc, URL_FILE * input );
struct pso_pointer get_character( struct pso_pointer read_stream );
struct pso_pointer push_back_character( struct pso_pointer c, struct pso_pointer r);
struct pso_pointer push_back_character( struct pso_pointer c,
struct pso_pointer r );
struct pso_pointer get_default_stream( bool inputp, struct pso_pointer env );
struct pso_pointer
lisp_close( struct pso4 *frame, struct pso_pointer frame_pointer,
struct pso_pointer env );
lisp_close( struct pso_pointer frame_pointer, struct pso_pointer env );
struct pso_pointer
lisp_open( struct pso4 *frame, struct pso_pointer frame_pointer,
struct pso_pointer env );
lisp_open( struct pso_pointer frame_pointer, struct pso_pointer env );
struct pso_pointer
lisp_read_char( struct pso4 *frame, struct pso_pointer frame_pointer,
struct pso_pointer env );
lisp_read_char( struct pso_pointer frame_pointer, struct pso_pointer env );
struct pso_pointer
lisp_slurp( struct pso4 *frame, struct pso_pointer frame_pointer,
struct pso_pointer env );
lisp_slurp( struct pso_pointer frame_pointer, struct pso_pointer env );
char *lisp_string_to_c_string( struct pso_pointer s );
#endif

14
src/c/io/print.c
View file

@ -47,7 +47,8 @@ struct pso_pointer print_list_content( struct pso_pointer p, URL_FILE * output)
result = in_print( object->payload.cons.car, output );
if (exceptionp(result)) break;
if ( exceptionp( result ) )
break;
switch ( get_tag_value( object->payload.cons.cdr ) ) {
case NILTV:
@ -83,7 +84,8 @@ struct pso_pointer in_print( struct pso_pointer p, URL_FILE * output) {
url_fputwc( L')', output );
break;
case INTEGERTV:
url_fwprintf( output, L"%d", (int64_t)(object->payload.integer.value));
url_fwprintf( output, L"%d",
( int64_t ) ( object->payload.integer.value ) );
break;
case TRUETV:
url_fputwc( L't', output );
@ -112,11 +114,15 @@ struct pso_pointer print( struct pso_pointer p, struct pso_pointer stream) {
pointer_to_object( stream )->payload.stream.stream :
file_to_url_file( stdout );
if ( writep( stream)) { inc_ref( stream); }
if ( writep( stream ) ) {
inc_ref( stream );
}
struct pso_pointer result = in_print( p, output );
if ( writep( stream)) { dec_ref( stream); }
if ( writep( stream ) ) {
dec_ref( stream );
}
return result;
}

16
src/c/io/read.c
View file

@ -113,8 +113,7 @@ struct pso_pointer read_number( struct pso_pointer frame_pointer,
pointer_to_object( character )->payload.character.character;
URL_FILE *input = pointer_to_object( stream )->payload.stream.stream;
for ( ; iswdigit( c );
c = url_fgetwc( input ) ){
for ( ; iswdigit( c ); c = url_fgetwc( input ) ) {
value = ( value * base ) + ( ( int ) c - ( int ) L'0' );
}
@ -142,8 +141,7 @@ struct pso_pointer read_symbol( struct pso_pointer frame_pointer,
pointer_to_object( character )->payload.character.character;
URL_FILE *input = pointer_to_object( stream )->payload.stream.stream;
for ( ; iswalnum( c );
c = url_fgetwc( input ) ){
for ( ; iswalnum( c ); c = url_fgetwc( input ) ) {
result = make_string_like_thing( c, result, SYMBOLTAG );
}
@ -192,7 +190,8 @@ struct pso_pointer read( struct pso_pointer frame_pointer,
if ( !nilp( readmacro ) ) {
// invoke the read macro on the stream
} else if ( readp( stream ) && characterp( character ) ) {
wchar_t c = pointer_to_object( character)->payload.character.character;
wchar_t c =
pointer_to_object( character )->payload.character.character;
URL_FILE *input = pointer_to_object( stream )->payload.stream.stream;
switch ( c ) {
@ -208,11 +207,12 @@ struct pso_pointer read( struct pso_pointer frame_pointer,
// frame_pointer );
break;
default:
struct pso_pointer next = make_frame( frame_pointer, stream, readtable, make_character(c));
struct pso_pointer next =
make_frame( frame_pointer, stream, readtable,
make_character( c ) );
inc_ref( next );
if ( iswdigit( c ) ) {
result =
read_number( next, env );
result = read_number( next, env );
} else if ( iswalpha( c ) ) {
result = read_symbol( next, env );
} else {

25
src/c/io/read.h
View file

@ -0,0 +1,25 @@
/**
* read.h
*
* Read basic Lisp objects..This is :bootstrap layer print; it needs to be
* able to read characters, symbols, integers, lists and dotted pairs. I
* don't think it needs to be able to read anything else. It must, however,
* take a readtable as argument and expand reader macros.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __psse_io_read_h
#define __psse_io_read_h
struct pso_pointer read_number( struct pso_pointer frame_pointer,
struct pso_pointer env );
struct pso_pointer read_symbol( struct pso_pointer frame_pointer,
struct pso_pointer env );
struct pso_pointer read( struct pso_pointer frame_pointer,
struct pso_pointer env );
#endif

17
src/c/memory/destroy.c
View file

@ -43,16 +43,23 @@ struct pso_pointer destroy( struct pso_pointer p) {
inc_ref( f );
switch ( get_tag_value( p ) ) {
case CONSTV: destroy_cons(f, nil); break;
case EXCEPTIONTV: destroy_exception(f, nil); break;
case CONSTV:
destroy_cons( f, nil );
break;
case EXCEPTIONTV:
destroy_exception( f, nil );
break;
case KEYTV:
case STRINGTV:
case SYMBOLTV: destroy_string(f, nil); break;
case STACKTV: destroy_stack_frame(f, nil); break;
case SYMBOLTV:
destroy_string( f, nil );
break;
case STACKTV:
destroy_stack_frame( f, nil );
break;
// TODO: others.
}
dec_ref( f );
return result;
}

2
src/c/memory/node.c
View file

@ -57,7 +57,7 @@ struct pso_pointer initialise_node( uint32_t index ) {
struct pso_pointer result = initialise_memory( index );
if ( eq( result, t ) ) {
if ( c_eq( result, t ) ) {
result = initialise_environment( index );
}

1
src/c/memory/node.h
View file

@ -34,4 +34,3 @@ extern struct pso_pointer t;
struct pso_pointer initialise_node( uint32_t index );
#endif

10
src/c/memory/pointer.c
View file

@ -54,7 +54,8 @@ struct pso2 *pointer_to_object( struct pso_pointer p ) {
struct pso2 *result = NULL;
if ( p.node == node_index ) {
if (p.page < get_pages_allocated() && p.offset < (PAGE_BYTES / 8)) {
if ( p.page < get_pages_allocated( )
&& p.offset < ( PAGE_BYTES / 8 ) ) {
// TODO: that's not really a safe test of whether this is a valid pointer.
union page *pg = pages[p.page];
result = ( struct pso2 * ) &pg->words[p.offset];
@ -85,7 +86,8 @@ struct pso2 *pointer_to_object( struct pso_pointer p ) {
* @return the memory address of the object, provided it is a valid object and
* of the specified size class, else NULL.
*/
struct pso2 * pointer_to_object_of_size_class( struct pso_pointer p, uint8_t size_class) {
struct pso2 *pointer_to_object_of_size_class( struct pso_pointer p,
uint8_t size_class ) {
struct pso2 *result = pointer_to_object( p );
if ( result->header.tag.bytes.size_class != size_class ) {
@ -103,7 +105,8 @@ struct pso2 * pointer_to_object_of_size_class( struct pso_pointer p, uint8_t siz
* exception back from this function. Consequently, if anything goes wrong
* we return NULL. The caller *should* check for that and throw an exception.
*/
struct pso2 * pointer_to_object_with_tag_value( struct pso_pointer p, uint32_t tag_value) {
struct pso2 *pointer_to_object_with_tag_value( struct pso_pointer p,
uint32_t tag_value ) {
struct pso2 *result = pointer_to_object( p );
if ( ( result->header.tag.value & 0xffffff ) != tag_value ) {
@ -112,4 +115,3 @@ struct pso2 * pointer_to_object_with_tag_value( struct pso_pointer p, uint32_t t
return result;
}

9
src/c/memory/pointer.h
View file

@ -39,12 +39,15 @@ struct pso_pointer {
};
struct pso_pointer make_pointer( uint32_t node, uint16_t page, uint16_t offset);
struct pso_pointer make_pointer( uint32_t node, uint16_t page,
uint16_t offset );
struct pso2 *pointer_to_object( struct pso_pointer pointer );
struct pso2 * pointer_to_object_of_size_class( struct pso_pointer p, uint8_t size_class);
struct pso2 *pointer_to_object_of_size_class( struct pso_pointer p,
uint8_t size_class );
struct pso2 * pointer_to_object_with_tag_value( struct pso_pointer p, uint32_t tag_value);
struct pso2 *pointer_to_object_with_tag_value( struct pso_pointer p,
uint32_t tag_value );
#endif

3
src/c/memory/pso.c
View file

@ -181,7 +181,8 @@ struct pso_pointer free_object( struct pso_pointer p ) {
strncpy( ( char * ) ( obj->header.tag.bytes.mnemonic ), FREETAG,
TAGLENGTH );
#ifdef DEBUG
debug_printf( DEBUG_ALLOC, 0, L"Freeing object of size class %d at {%d, %d, %d}",
debug_printf( DEBUG_ALLOC, 0,
L"Freeing object of size class %d at {%d, %d, %d}",
size_class, p.node, p.page, p.offset );
#endif

3
src/c/memory/pso4.c
View file

@ -13,5 +13,6 @@
#include "memory/pso4.h"
struct pso4 *pointer_to_pso4( struct pso_pointer p ) {
struct pso4* result = (struct pso4*)pointer_to_object_of_size_class( p, 4);
struct pso4 *result =
( struct pso4 * ) pointer_to_object_of_size_class( p, 4 );
}

5
src/c/memory/tags.c
View file

@ -47,7 +47,8 @@ bool check_tag( struct pso_pointer p, uint32_t v) {
* @return false otherwise.
*/
bool check_type( struct pso_pointer p, char *s ) {
return (strncmp(
&(pointer_to_object(p)->header.tag.bytes.mnemonic[0]), s, TAGLENGTH)
return ( strncmp
( &( pointer_to_object( p )->header.tag.bytes.mnemonic[0] ), s,
TAGLENGTH )
== 0 );
}

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

@ -34,18 +34,16 @@
* return the binding.
*/
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 result = nil;
bool found = false;
if ( consp( store ) ) {
for ( struct pso_pointer cursor = store;
consp( store) && found == false;
cursor = cdr( cursor)) {
consp( store ) && found == false; cursor = cdr( cursor ) ) {
struct pso_pointer pair = car( cursor );
if (consp(pair) && equal(car(pair), key)) {
if ( consp( pair ) && c_equal( car( pair ), key ) ) {
found = true;
result = return_key ? car( pair ) : cdr( pair );
}

6
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 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 );
#endif

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

@ -42,4 +42,3 @@ struct pso_pointer c_bind( struct pso_pointer key,
return result;
}

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

@ -33,14 +33,14 @@
* @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 c_equal( struct pso_pointer a, struct pso_pointer b ) {
bool result = false;
if ( eq( a, 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 );
@ -48,15 +48,17 @@ bool equal( struct pso_pointer a, struct pso_pointer b) {
switch ( get_tag_value( a ) ) {
case CHARACTERTV:
result = (oa->payload.character.character == ob->payload.character.character);
result =
( oa->payload.character.character ==
ob->payload.character.character );
break;
case CONSTV:
result = (equal( car(a), car(b)) && equal( cdr(a), cdr(b)));
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);
== ob->payload.integer.value );
break;
case KEYTV:
case STRINGTV:
@ -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 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;
}

7
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 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

28
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 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;

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

@ -38,23 +38,33 @@
struct pso_pointer reverse( struct pso_pointer sequence ) {
struct pso_pointer result = nil;
for (struct pso_pointer cursor = sequence; !nilp( sequence); cursor = cdr(cursor)) {
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);
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);
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);
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);
result =
make_exception( c_string_to_lisp_string
( L"Invalid object in sequence" ), nil,
nil );
goto exit;
break;
}

16
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,9 +65,10 @@ 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 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,9 +80,10 @@ 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 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 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 );
}

9
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 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 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 lisp_truep( struct pso_pointer frame_pointer,
struct pso_pointer env );
#endif

3
src/c/payloads/character.c
View file

@ -27,7 +27,8 @@ struct pso_pointer make_character( wint_t c) {
struct pso_pointer result = allocate( CHARACTERTAG, 2 );
if ( !nilp( result ) ) {
pointer_to_object(result)->payload.character.character = (wchar_t) c;
pointer_to_object( result )->payload.character.character =
( wchar_t ) c;
}
return result;

17
src/c/payloads/cons.c
View file

@ -71,15 +71,19 @@ struct pso_pointer cdr( struct pso_pointer p ) {
struct pso2 *object = pointer_to_object( result );
switch ( get_tag_value( p ) ) {
case CONSTV : result = object->payload.cons.cdr; break;
case CONSTV:
result = object->payload.cons.cdr;
break;
case KEYTV:
case STRINGTV:
case SYMBOLTV:
result = object->payload.string.cdr; break;
result = object->payload.string.cdr;
break;
default:
result = make_exception(
cons(c_string_to_lisp_string(L"Invalid type for cdr"), p),
nil, nil);
result =
make_exception( cons
( c_string_to_lisp_string
( L"Invalid type for cdr" ), p ), nil, nil );
break;
}
@ -95,7 +99,8 @@ struct pso_pointer cdr( struct pso_pointer p ) {
* Lisp calling conventions; one expected arg, the pointer to the cell to
* be destroyed.
*/
struct pso_pointer destroy_cons( struct pso_pointer fp, struct pso_pointer env) {
struct pso_pointer destroy_cons( struct pso_pointer fp,
struct pso_pointer env ) {
if ( stackp( fp ) ) {
struct pso4 *frame = pointer_to_pso4( fp );
struct pso_pointer p = frame->payload.stack_frame.arg[0];

3
src/c/payloads/cons.h
View file

@ -32,6 +32,7 @@ struct pso_pointer cdr( struct pso_pointer cons );
struct pso_pointer cons( struct pso_pointer car, struct pso_pointer cdr );
struct pso_pointer destroy_cons( struct pso_pointer fp, struct pso_pointer env);
struct pso_pointer destroy_cons( struct pso_pointer fp,
struct pso_pointer env );
#endif

3
src/c/payloads/exception.c
View file

@ -17,7 +17,8 @@
#include "payloads/exception.h"
struct pso_pointer make_exception( struct pso_pointer message,
struct pso_pointer frame_pointer, struct pso_pointer cause) {
struct pso_pointer frame_pointer,
struct pso_pointer cause ) {
// TODO: not yet implemented
return nil;
}

3
src/c/payloads/exception.h
View file

@ -25,7 +25,8 @@ struct exception_payload {
};
struct pso_pointer make_exception( struct pso_pointer message,
struct pso_pointer frame_pointer, struct pso_pointer cause);
struct pso_pointer frame_pointer,
struct pso_pointer cause );
struct pso_pointer destroy_exception( struct pso_pointer fp,
struct pso_pointer env );

1
src/c/psse.c
View file

@ -105,7 +105,6 @@ int main( int argc, char *argv[] ) {
fputs( "Failed to initialise node\n", stderr );
exit( 1 );
}
// repl( );
exit( 0 );