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 ) ) { for ( struct cons_pointer i = keys_a; !nilp( i ); i = c_cdr( i ) ) {
struct cons_pointer key = c_car( i ); struct cons_pointer key = c_car( i );
if ( !equal if ( !c_equal
( hashmap_get( a, key, false ), ( hashmap_get( a, key, false ),
hashmap_get( b, key, false ) ) ) { hashmap_get( b, key, false ) ) ) {
result = 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 * Deep, and thus expensive, equality: true if these two objects have
* identical structure, else false. * 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( L"\nequal: ", DEBUG_EQUAL );
debug_print_object( a, DEBUG_EQUAL ); debug_print_object( a, DEBUG_EQUAL );
debug_print( L" = ", 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 * structures can be of indefinite extent. It *must* be done by
* iteration (and even that is problematic) */ * iteration (and even that is problematic) */
result = result =
equal( cell_a->payload.cons.car, cell_b->payload.cons.car ) c_equal( cell_a->payload.cons.car, cell_b->payload.cons.car )
&& equal( cell_a->payload.cons.cdr, && c_equal( cell_a->payload.cons.cdr,
cell_b->payload.cons.cdr ); cell_b->payload.cons.cdr );
break; break;
case KEYTV: 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. */ * isn't sufficient. So we recurse at least once. */
result = ( wcsncmp( a_buff, b_buff, i ) == 0 ) result = ( wcsncmp( a_buff, b_buff, i ) == 0 )
&& equal( c_cdr( a ), c_cdr( b ) ); && c_equal( c_cdr( a ), c_cdr( b ) );
} }
break; break;
case VECTORPOINTTV: 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 * Deep, and thus expensive, equality: true if these two objects have
* identical structure, else false. * 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 #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 ) ) { switch ( get_tag_value( entry_ptr ) ) {
case CONSTV: case CONSTV:
if ( equal( key, c_car( entry_ptr ) ) ) { if ( c_equal( key, c_car( entry_ptr ) ) ) {
result = result =
return_key ? c_car( entry_ptr ) return_key ? c_car( entry_ptr )
: c_cdr( 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 ); for ( struct cons_pointer pair = c_car( store );
eq( result, NIL ) && !nilp( pair ); pair = c_car( store ) ) { eq( result, NIL ) && !nilp( pair ); pair = c_car( store ) ) {
if ( consp( pair ) ) { 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 // yes, this should be `eq`, but if symbols are correctly
// interned this will work efficiently, and if not it will // interned this will work efficiently, and if not it will
// still work. // 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 ) { if ( frame->args > 1 ) {
for ( int b = 1; ( truep( result ) ) && ( b < frame->args ); b++ ) { for ( int b = 1; ( truep( result ) ) && ( b < frame->args ); b++ ) {
result = result =
equal( frame->arg[0], fetch_arg( frame, b ) ) ? TRUE : NIL; c_equal( frame->arg[0], fetch_arg( frame, b ) ) ? TRUE : NIL;
} }
} }

4
src/c/environment/environment.h
View file

@ -10,6 +10,6 @@
#ifndef __psse_environment_environment_h #ifndef __psse_environment_environment_h
#define __psse_environment_environment_h #define __psse_environment_environment_h
struct pso_pointer initialise_environment( uint32_t node); struct pso_pointer initialise_environment( uint32_t node );
#endif #endif

90
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 ) ) { if ( stringp( s ) || symbolp( s ) ) {
int len = 0; int len = 0;
for ( struct pso_pointer c = s; !nilp( c ); for ( struct pso_pointer c = s; !nilp( c ); c = cdr( c ) ) {
c = cdr(c)) {
len++; len++;
} }
@ -124,8 +123,7 @@ char *lisp_string_to_c_string( struct pso_pointer s ) {
result = calloc( ( len * 4 ) + 1, sizeof( char ) ); result = calloc( ( len * 4 ) + 1, sizeof( char ) );
int i = 0; int i = 0;
for ( struct pso_pointer c = s; !nilp( c ); for ( struct pso_pointer c = s; !nilp( c ); c = cdr( c ) ) {
c = cdr(c)) {
buffer[i++] = pointer_to_object( c )->payload.string.character; buffer[i++] = pointer_to_object( c )->payload.string.character;
} }
@ -134,7 +132,7 @@ char *lisp_string_to_c_string( struct pso_pointer s ) {
} }
debug_print( L"lisp_string_to_c_string( ", DEBUG_IO, 0 ); debug_print( L"lisp_string_to_c_string( ", DEBUG_IO, 0 );
debug_print_object( s, DEBUG_IO , 0); debug_print_object( s, DEBUG_IO, 0 );
debug_printf( DEBUG_IO, 0, L") => '%s'\n", result ); debug_printf( DEBUG_IO, 0, L") => '%s'\n", result );
return result; return result;
@ -262,13 +260,16 @@ wint_t url_ungetwc( wint_t wc, URL_FILE *input ) {
* @return a pointer to a character object on success, or `nil` on failure. * @return a pointer to a character object on success, or `nil` on failure.
*/ */
struct pso_pointer get_character( struct pso_pointer read_stream ) { struct pso_pointer get_character( struct pso_pointer read_stream ) {
struct pso_pointer result = nil; struct pso_pointer result = nil;
if (readp( read_stream)) { 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; return result;
} }
/** /**
@ -279,16 +280,20 @@ struct pso_pointer get_character( struct pso_pointer read_stream ) {
* *
* @return `t` on success, else `nil`. * @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 result = nil; struct pso_pointer r ) {
struct pso_pointer result = nil;
if (characterp(c) && readp(r)) { if ( characterp( c ) && readp( r ) ) {
if (url_ungetwc( (wint_t)(pointer_to_object(c)->payload.character.character), if ( url_ungetwc( ( wint_t )
pointer_to_object(r)->payload.stream.stream) >= 0) { ( pointer_to_object( c )->payload.character.
result = t; character ),
} pointer_to_object( r )->payload.stream.stream ) >=
} 0 ) {
return result; result = t;
}
}
return result;
} }
/** /**
@ -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. * @return T if the stream was successfully closed, else nil.
*/ */
struct pso_pointer struct pso_pointer
lisp_close( struct pso4 *frame, struct pso_pointer frame_pointer, lisp_close( struct pso_pointer frame_pointer, struct pso_pointer env ) {
struct pso_pointer env ) { struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer result = nil; struct pso_pointer result = nil;
if ( readp( fetch_arg( frame, 0) ) || writep( fetch_arg( frame, 0) ) ) { 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 ) { == 0 ) {
result = t; result = t;
} }
@ -319,25 +326,25 @@ lisp_close( struct pso4 *frame, struct pso_pointer frame_pointer,
} }
struct pso_pointer add_meta_integer( struct pso_pointer meta, wchar_t *key, struct pso_pointer add_meta_integer( struct pso_pointer meta, wchar_t *key,
long int value ) { long int value ) {
return return
cons( cons cons( cons
( c_string_to_lisp_keyword( key ), ( c_string_to_lisp_keyword( key ),
make_integer( value ) ), meta ); make_integer( value ) ), meta );
} }
struct pso_pointer add_meta_string( struct pso_pointer meta, wchar_t *key, struct pso_pointer add_meta_string( struct pso_pointer meta, wchar_t *key,
char *value ) { char *value ) {
value = trim( value ); value = trim( value );
wchar_t buffer[strlen( value ) + 1]; wchar_t buffer[strlen( value ) + 1];
mbstowcs( buffer, value, strlen( value ) + 1 ); mbstowcs( buffer, value, strlen( value ) + 1 );
return cons( cons( c_string_to_lisp_keyword( key ), return cons( cons( c_string_to_lisp_keyword( key ),
c_string_to_lisp_string( buffer ) ), meta ); c_string_to_lisp_string( buffer ) ), meta );
} }
struct pso_pointer add_meta_time( struct pso_pointer meta, wchar_t *key, struct pso_pointer add_meta_time( struct pso_pointer meta, wchar_t *key,
time_t *value ) { time_t *value ) {
/* I don't yet have a concept of a date-time object, which is a /* I don't yet have a concept of a date-time object, which is a
* bit of an oversight! */ * bit of an oversight! */
char datestring[256]; char datestring[256];
@ -409,7 +416,7 @@ static size_t write_meta_callback( char *string, size_t size, size_t nmemb,
// } // }
// free( s ); // free( s );
return 0; // strlen( string ); return 0; // strlen( string );
} }
void collect_meta( struct pso_pointer stream, char *url ) { void collect_meta( struct pso_pointer stream, char *url ) {
@ -489,8 +496,8 @@ struct pso_pointer get_default_stream( bool inputp, struct pso_pointer env ) {
* on my stream, if any, else nil. * on my stream, if any, else nil.
*/ */
struct pso_pointer struct pso_pointer
lisp_open( struct pso4 *frame, struct pso_pointer frame_pointer, lisp_open( struct pso_pointer frame_pointer, struct pso_pointer env ) {
struct pso_pointer env ) { struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer result = nil; struct pso_pointer result = nil;
// if ( stringp( fetch_arg( frame, 0) ) ) { // if ( stringp( fetch_arg( frame, 0) ) ) {
@ -556,14 +563,14 @@ lisp_open( struct pso4 *frame, struct pso_pointer frame_pointer,
* on my stream, if any, else nil. * on my stream, if any, else nil.
*/ */
struct pso_pointer struct pso_pointer
lisp_read_char( struct pso4 *frame, struct pso_pointer frame_pointer, lisp_read_char( struct pso_pointer frame_pointer, struct pso_pointer env ) {
struct pso_pointer env ) { struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer result = nil; struct pso_pointer result = nil;
if ( readp( fetch_arg( frame, 0) ) ) { if ( readp( fetch_arg( frame, 0 ) ) ) {
result = result =
make_string( url_fgetwc make_string( url_fgetwc
( pointer_to_object( fetch_arg( frame, 0) )->payload. ( pointer_to_object( fetch_arg( frame, 0 ) )->payload.
stream.stream ), nil ); stream.stream ), nil );
} }
@ -585,18 +592,19 @@ lisp_read_char( struct pso4 *frame, struct pso_pointer frame_pointer,
* on my stream, if any, else nil. * on my stream, if any, else nil.
*/ */
struct pso_pointer struct pso_pointer
lisp_slurp( struct pso4 *frame, struct pso_pointer frame_pointer, lisp_slurp( struct pso_pointer frame_pointer, struct pso_pointer env ) {
struct pso_pointer env ) { struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer result = nil; struct pso_pointer result = nil;
if ( readp( fetch_arg( frame, 0) ) ) { 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 ); struct pso_pointer cursor = make_string( url_fgetwc( stream ), nil );
result = cursor; result = cursor;
for ( wint_t c = url_fgetwc( stream ); !url_feof( stream ) && c != 0; for ( wint_t c = url_fgetwc( stream ); !url_feof( stream ) && c != 0;
c = url_fgetwc( stream ) ) { c = url_fgetwc( stream ) ) {
debug_print( L"slurp: cursor is: ", DEBUG_IO, 0); debug_print( L"slurp: cursor is: ", DEBUG_IO, 0 );
debug_dump_object( cursor, DEBUG_IO, 0 ); debug_dump_object( cursor, DEBUG_IO, 0 );
debug_print( L"; result is: ", DEBUG_IO, 0 ); debug_print( L"; result is: ", DEBUG_IO, 0 );
debug_dump_object( result, DEBUG_IO, 0 ); debug_dump_object( result, DEBUG_IO, 0 );

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. * Licensed under GPL version 2.0, or, at your option, any later version.
*/ */
#ifndef __psse_io_h #ifndef __psse_io_io_h
#define __psse_io_h #define __psse_io_io_h
#include <curl/curl.h> #include <curl/curl.h>
#include "memory/pointer.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 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 get_default_stream( bool inputp, struct pso_pointer env );
struct pso_pointer struct pso_pointer
lisp_close( struct pso4 *frame, struct pso_pointer frame_pointer, lisp_close( struct pso_pointer frame_pointer, struct pso_pointer env );
struct pso_pointer env );
struct pso_pointer struct pso_pointer
lisp_open( struct pso4 *frame, struct pso_pointer frame_pointer, lisp_open( struct pso_pointer frame_pointer, struct pso_pointer env );
struct pso_pointer env );
struct pso_pointer struct pso_pointer
lisp_read_char( struct pso4 *frame, struct pso_pointer frame_pointer, lisp_read_char( struct pso_pointer frame_pointer, struct pso_pointer env );
struct pso_pointer env );
struct pso_pointer struct pso_pointer
lisp_slurp( struct pso4 *frame, struct pso_pointer frame_pointer, lisp_slurp( struct pso_pointer frame_pointer, struct pso_pointer env );
struct pso_pointer env );
char *lisp_string_to_c_string( struct pso_pointer s ); char *lisp_string_to_c_string( struct pso_pointer s );
#endif #endif

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

@ -36,28 +36,29 @@
#include "payloads/cons.h" #include "payloads/cons.h"
#include "payloads/integer.h" #include "payloads/integer.h"
struct pso_pointer in_print( struct pso_pointer p, URL_FILE * output); struct pso_pointer in_print( struct pso_pointer p, URL_FILE * output );
struct pso_pointer print_list_content( struct pso_pointer p, URL_FILE * output) { struct pso_pointer print_list_content( struct pso_pointer p, URL_FILE *output ) {
struct pso_pointer result = nil; struct pso_pointer result = nil;
if (consp(p)) { if ( consp( p ) ) {
for (; consp( p); p = cdr(p)) { for ( ; consp( p ); p = cdr( p ) ) {
struct pso2* object = pointer_to_object(p); struct pso2 *object = pointer_to_object( p );
result = in_print( object->payload.cons.car, output);
if (exceptionp(result)) break; result = in_print( object->payload.cons.car, output );
switch (get_tag_value(object->payload.cons.cdr)) { if ( exceptionp( result ) )
case NILTV : break;
switch ( get_tag_value( object->payload.cons.cdr ) ) {
case NILTV:
break; break;
case CONSTV : case CONSTV:
url_fputwc( L' ', output ); url_fputwc( L' ', output );
break; break;
default : default:
url_fputws( L" . ", output); url_fputws( L" . ", output );
result = in_print( object->payload.cons.cdr, output); result = in_print( object->payload.cons.cdr, output );
} }
} }
@ -68,33 +69,34 @@ struct pso_pointer print_list_content( struct pso_pointer p, URL_FILE * output)
return result; return result;
} }
struct pso_pointer in_print( struct pso_pointer p, URL_FILE * output) { struct pso_pointer in_print( struct pso_pointer p, URL_FILE *output ) {
struct pso2* object = pointer_to_object(p); struct pso2 *object = pointer_to_object( p );
struct pso_pointer result = nil; struct pso_pointer result = nil;
if (object != NULL) { if ( object != NULL ) {
switch (get_tag_value( p)) { switch ( get_tag_value( p ) ) {
case CHARACTERTV : case CHARACTERTV:
url_fputwc( object->payload.character.character, output); url_fputwc( object->payload.character.character, output );
break; break;
case CONSTV : case CONSTV:
url_fputwc( L'(', output ); url_fputwc( L'(', output );
result = print_list_content( p, output); result = print_list_content( p, output );
url_fputwc( L')', output ); url_fputwc( L')', output );
break; break;
case INTEGERTV : 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; break;
case TRUETV : case TRUETV:
url_fputwc( L't', output ); url_fputwc( L't', output );
break; break;
case NILTV : case NILTV:
url_fputws( L"nil", output ); url_fputws( L"nil", output );
default : default:
// TODO: return exception // TODO: return exception
} }
} else { } else {
// TODO: return exception // TODO: return exception
} }
return result; return result;
@ -107,16 +109,20 @@ struct pso_pointer in_print( struct pso_pointer p, URL_FILE * output) {
* @param stream if a pointer to an open write stream, print to there. * @param stream if a pointer to an open write stream, print to there.
* @return struct pso_pointer `nil`, or an exception if some erroe occurred. * @return struct pso_pointer `nil`, or an exception if some erroe occurred.
*/ */
struct pso_pointer print( struct pso_pointer p, struct pso_pointer stream) { struct pso_pointer print( struct pso_pointer p, struct pso_pointer stream ) {
URL_FILE *output = writep( stream) ? URL_FILE *output = writep( stream ) ?
pointer_to_object( stream )->payload.stream.stream : pointer_to_object( stream )->payload.stream.stream :
file_to_url_file(stdout); 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); struct pso_pointer result = in_print( p, output );
if ( writep( stream)) { dec_ref( stream); } if ( writep( stream ) ) {
dec_ref( stream );
}
return result; return result;
} }

4
src/c/io/print.h
View file

@ -14,6 +14,6 @@
#ifndef __psse_io_print_h #ifndef __psse_io_print_h
#define __psse_io_print_h #define __psse_io_print_h
struct pso_pointer print( struct pso_pointer p, struct pso_pointer stream); struct pso_pointer print( struct pso_pointer p, struct pso_pointer stream );
#endif #endif

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

@ -73,14 +73,14 @@
* 2. The character most recently read from that stream. * 2. The character most recently read from that stream.
*/ */
struct pso_pointer read_example( struct pso_pointer frame_pointer, struct pso_pointer read_example( struct pso_pointer frame_pointer,
struct pso_pointer env) { struct pso_pointer env ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer); struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer stream = fetch_arg( frame, 0); struct pso_pointer stream = fetch_arg( frame, 0 );
struct pso_pointer readtable = fetch_arg( frame, 1); struct pso_pointer readtable = fetch_arg( frame, 1 );
struct pso_pointer character = fetch_arg( frame, 2); struct pso_pointer character = fetch_arg( frame, 2 );
struct pso_pointer result = nil; struct pso_pointer result = nil;
return result; return result;
} }
/** /**
@ -94,64 +94,62 @@ struct pso_pointer read_example( struct pso_pointer frame_pointer,
* 2. The character most recently read from that stream. * 2. The character most recently read from that stream.
*/ */
struct pso_pointer read_number( struct pso_pointer frame_pointer, struct pso_pointer read_number( struct pso_pointer frame_pointer,
struct pso_pointer env) { struct pso_pointer env ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer); struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer stream = fetch_arg( frame, 0); struct pso_pointer stream = fetch_arg( frame, 0 );
struct pso_pointer readtable = fetch_arg( frame, 1); struct pso_pointer readtable = fetch_arg( frame, 1 );
struct pso_pointer character = fetch_arg( frame, 2); struct pso_pointer character = fetch_arg( frame, 2 );
struct pso_pointer result = nil; struct pso_pointer result = nil;
int base = 10; int base = 10;
// TODO: should check for *read-base* in the environment // TODO: should check for *read-base* in the environment
int64_t value = 0; int64_t value = 0;
if (readp(stream)) { if ( readp( stream ) ) {
if (nilp( character)) { if ( nilp( character ) ) {
character = get_character( stream); character = get_character( stream );
} }
wchar_t c = nilp(character) ? 0 : wchar_t c = nilp( character ) ? 0 :
pointer_to_object( character)->payload.character.character; pointer_to_object( character )->payload.character.character;
URL_FILE * input = pointer_to_object(stream)->payload.stream.stream; URL_FILE *input = pointer_to_object( stream )->payload.stream.stream;
for ( ; iswdigit( c ); for ( ; iswdigit( c ); c = url_fgetwc( input ) ) {
c = url_fgetwc( input ) ){ value = ( value * base ) + ( ( int ) c - ( int ) L'0' );
value = (value * base) + ((int)c - (int)L'0'); }
}
url_ungetwc( c, input); url_ungetwc( c, input );
result = make_integer( value); result = make_integer( value );
} // else exception? } // else exception?
return result; return result;
} }
struct pso_pointer read_symbol( struct pso_pointer frame_pointer, struct pso_pointer read_symbol( struct pso_pointer frame_pointer,
struct pso_pointer env) { struct pso_pointer env ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer); struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer stream = fetch_arg( frame, 0); struct pso_pointer stream = fetch_arg( frame, 0 );
struct pso_pointer readtable = fetch_arg( frame, 1); struct pso_pointer readtable = fetch_arg( frame, 1 );
struct pso_pointer character = fetch_arg( frame, 2); struct pso_pointer character = fetch_arg( frame, 2 );
struct pso_pointer result = nil; struct pso_pointer result = nil;
if (readp(stream)) { if ( readp( stream ) ) {
if (nilp( character)) { if ( nilp( character ) ) {
character = get_character( stream); character = get_character( stream );
} }
wchar_t c = nilp(character) ? 0 : wchar_t c = nilp( character ) ? 0 :
pointer_to_object( character)->payload.character.character; pointer_to_object( character )->payload.character.character;
URL_FILE * input = pointer_to_object(stream)->payload.stream.stream; URL_FILE *input = pointer_to_object( stream )->payload.stream.stream;
for ( ; iswalnum( c ); for ( ; iswalnum( c ); c = url_fgetwc( input ) ) {
c = url_fgetwc( input ) ){ result = make_string_like_thing( c, result, SYMBOLTAG );
result = make_string_like_thing(c, result, SYMBOLTAG); }
}
url_ungetwc( c, input); url_ungetwc( c, input );
result = reverse( result); result = reverse( result );
} }
return result; return result;
} }
/** /**
@ -166,34 +164,35 @@ struct pso_pointer read_symbol( struct pso_pointer frame_pointer,
* 2. The character most recently read from that stream. * 2. The character most recently read from that stream.
*/ */
struct pso_pointer read( struct pso_pointer frame_pointer, struct pso_pointer read( struct pso_pointer frame_pointer,
struct pso_pointer env ) { struct pso_pointer env ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer); struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer stream = fetch_arg( frame, 0); struct pso_pointer stream = fetch_arg( frame, 0 );
struct pso_pointer readtable = fetch_arg( frame, 1); struct pso_pointer readtable = fetch_arg( frame, 1 );
struct pso_pointer character = fetch_arg( frame, 2); struct pso_pointer character = fetch_arg( frame, 2 );
struct pso_pointer result = nil; struct pso_pointer result = nil;
if (nilp(stream)) { if ( nilp( stream ) ) {
stream = make_read_stream( file_to_url_file(stdin), nil); stream = make_read_stream( file_to_url_file( stdin ), nil );
} }
if (nilp( readtable)) { if ( nilp( readtable ) ) {
// TODO: check for the value of `*read-table*` in the environment and // TODO: check for the value of `*read-table*` in the environment and
// use that. // use that.
} }
if (nilp( character)) { if ( nilp( character ) ) {
character = get_character( stream); character = get_character( stream );
} }
struct pso_pointer readmacro = assoc(character, readtable); struct pso_pointer readmacro = assoc( character, readtable );
if (!nilp( readmacro)) { if ( !nilp( readmacro ) ) {
// invoke the read macro on the stream // invoke the read macro on the stream
} else if (readp( stream) && characterp(character)) { } else if ( readp( stream ) && characterp( character ) ) {
wchar_t c = pointer_to_object( character)->payload.character.character; wchar_t c =
URL_FILE * input = pointer_to_object(stream)->payload.stream.stream; pointer_to_object( character )->payload.character.character;
URL_FILE *input = pointer_to_object( stream )->payload.stream.stream;
switch ( c ) { switch ( c ) {
case ';': case ';':
@ -208,11 +207,12 @@ struct pso_pointer read( struct pso_pointer frame_pointer,
// frame_pointer ); // frame_pointer );
break; break;
default: default:
struct pso_pointer next = make_frame( frame_pointer, stream, readtable, make_character(c)); struct pso_pointer next =
inc_ref( next); make_frame( frame_pointer, stream, readtable,
if ( iswdigit( c ) ) { make_character( c ) );
result = inc_ref( next );
read_number( next, env ); if ( iswdigit( c ) ) {
result = read_number( next, env );
} else if ( iswalpha( c ) ) { } else if ( iswalpha( c ) ) {
result = read_symbol( next, env ); result = read_symbol( next, env );
} else { } else {
@ -223,10 +223,10 @@ struct pso_pointer read( struct pso_pointer frame_pointer,
// make_string( c, NIL ) ), // make_string( c, NIL ) ),
// frame_pointer ); // frame_pointer );
} }
dec_ref( next); dec_ref( next );
break; break;
} }
} }
return result; return result;
} }

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

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

@ -37,22 +37,29 @@
* failure. This function returns that exception pointer. How we * failure. This function returns that exception pointer. How we
* handle that exception pointer I simply don't know yet. * handle that exception pointer I simply don't know yet.
*/ */
struct pso_pointer destroy( struct pso_pointer p) { struct pso_pointer destroy( struct pso_pointer p ) {
struct pso_pointer result = nil; struct pso_pointer result = nil;
struct pso_pointer f = make_frame( nil, p); struct pso_pointer f = make_frame( nil, p );
inc_ref( f); inc_ref( f );
switch (get_tag_value(p)) { switch ( get_tag_value( p ) ) {
case CONSTV: destroy_cons(f, nil); break; case CONSTV:
case EXCEPTIONTV: destroy_exception(f, nil); break; destroy_cons( f, nil );
case KEYTV : break;
case STRINGTV: case EXCEPTIONTV:
case SYMBOLTV: destroy_string(f, nil); break; destroy_exception( f, nil );
case STACKTV: destroy_stack_frame(f, nil); break; break;
// TODO: others. case KEYTV:
} case STRINGTV:
case SYMBOLTV:
destroy_string( f, nil );
break;
case STACKTV:
destroy_stack_frame( f, nil );
break;
// TODO: others.
}
dec_ref(f); dec_ref( f );
return result; return result;
} }

2
src/c/memory/destroy.h
View file

@ -12,6 +12,6 @@
#include "memory/pointer.h" #include "memory/pointer.h"
struct pso_pointer destroy( struct pso_pointer p); struct pso_pointer destroy( struct pso_pointer p );
#endif #endif

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 ); struct pso_pointer result = initialise_memory( index );
if ( eq( result, t ) ) { if ( c_eq( result, t ) ) {
result = initialise_environment( index ); 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 ); struct pso_pointer initialise_node( uint32_t index );
#endif #endif

12
src/c/memory/page.c
View file

@ -125,10 +125,10 @@ struct pso_pointer allocate_page( uint8_t size_class ) {
L"Initialised page %d; freelist for size class %x updated.\n", L"Initialised page %d; freelist for size class %x updated.\n",
npages_allocated, size_class ); npages_allocated, size_class );
if (npages_allocated == 0) { if ( npages_allocated == 0 ) {
// first page allocated; initialise nil and t // first page allocated; initialise nil and t
nil = lock_object( allocate(NILTAG, 2)); nil = lock_object( allocate( NILTAG, 2 ) );
t = lock_object( allocate(TRUETAG, 2)); t = lock_object( allocate( TRUETAG, 2 ) );
} }
npages_allocated++; npages_allocated++;
@ -164,6 +164,6 @@ struct pso_pointer allocate_page( uint8_t size_class ) {
* @brief allow other files to see the current value of npages_allocated, but not * @brief allow other files to see the current value of npages_allocated, but not
* change it. * change it.
*/ */
uint32_t get_pages_allocated() { uint32_t get_pages_allocated( ) {
return npages_allocated; return npages_allocated;
} }

2
src/c/memory/page.h
View file

@ -74,6 +74,6 @@ union page {
struct pso_pointer allocate_page( uint8_t size_class ); struct pso_pointer allocate_page( uint8_t size_class );
uint32_t get_pages_allocated(); uint32_t get_pages_allocated( );
#endif #endif

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

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

11
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( 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 #endif

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

@ -164,25 +164,26 @@ struct pso_pointer lock_object( struct pso_pointer pointer ) {
* clear its memory, and return it to the freelist. * clear its memory, and return it to the freelist.
*/ */
struct pso_pointer free_object( struct pso_pointer p ) { struct pso_pointer free_object( struct pso_pointer p ) {
struct pso_pointer result = nil; struct pso_pointer result = nil;
struct pso2 *obj = pointer_to_object( p ); struct pso2 *obj = pointer_to_object( p );
uint32_t array_size = payload_size( obj ); uint32_t array_size = payload_size( obj );
uint8_t size_class = obj->header.tag.bytes.size_class; uint8_t size_class = obj->header.tag.bytes.size_class;
result = destroy( p); result = destroy( p );
/* will C just let me cheerfully walk off the end of the array I've declared? */ /* will C just let me cheerfully walk off the end of the array I've declared? */
for ( int i = 0; i < array_size; i++ ) { for ( int i = 0; i < array_size; i++ ) {
obj->payload.words[i] = 0; obj->payload.words[i] = 0;
} }
strncpy( ( char * ) ( obj->header.tag.bytes.mnemonic ), FREETAG, strncpy( ( char * ) ( obj->header.tag.bytes.mnemonic ), FREETAG,
TAGLENGTH ); TAGLENGTH );
#ifdef DEBUG #ifdef DEBUG
debug_printf( DEBUG_ALLOC, 0, L"Freeing object of size class %d at {%d, %d, %d}", debug_printf( DEBUG_ALLOC, 0,
size_class, p.node, p.page, p.offset); L"Freeing object of size class %d at {%d, %d, %d}",
size_class, p.node, p.page, p.offset );
#endif #endif
/* TODO: obtain mutex on freelist */ /* TODO: obtain mutex on freelist */

4
src/c/memory/pso.h
View file

@ -15,13 +15,13 @@
#include "memory/header.h" #include "memory/header.h"
#include "memory/pointer.h" #include "memory/pointer.h"
struct pso_pointer allocate( char* tag, uint8_t size_class); struct pso_pointer allocate( char *tag, uint8_t size_class );
struct pso_pointer dec_ref( struct pso_pointer pointer ); struct pso_pointer dec_ref( struct pso_pointer pointer );
struct pso_pointer inc_ref( struct pso_pointer pointer ); struct pso_pointer inc_ref( struct pso_pointer pointer );
struct pso_pointer lock_object( struct pso_pointer pointer); struct pso_pointer lock_object( struct pso_pointer pointer );
struct pso_pointer free_object( struct pso_pointer p ); struct pso_pointer free_object( struct pso_pointer p );

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

@ -12,6 +12,7 @@
#include "memory/pso2.h" #include "memory/pso2.h"
#include "memory/pso4.h" #include "memory/pso4.h"
struct pso4* pointer_to_pso4( struct pso_pointer p) { 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 );
} }

2
src/c/memory/pso4.h
View file

@ -31,6 +31,6 @@ struct pso4 {
} payload; } payload;
}; };
struct pso4* pointer_to_pso4( struct pso_pointer p); struct pso4 *pointer_to_pso4( struct pso_pointer p );
#endif #endif

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

@ -16,10 +16,10 @@
#include "memory/pointer.h" #include "memory/pointer.h"
#include "memory/pso2.h" #include "memory/pso2.h"
uint32_t get_tag_value (struct pso_pointer p) { uint32_t get_tag_value( struct pso_pointer p ) {
struct pso2* object = pointer_to_object( p); struct pso2 *object = pointer_to_object( p );
return object->header.tag.value & 0xffffff; return object->header.tag.value & 0xffffff;
} }
/** /**
@ -31,8 +31,8 @@ uint32_t get_tag_value (struct pso_pointer p) {
* *
* @return true if the tag at p matches v, else false. * @return true if the tag at p matches v, else false.
*/ */
bool check_tag( struct pso_pointer p, uint32_t v) { bool check_tag( struct pso_pointer p, uint32_t v ) {
return get_tag_value(p) == v; return get_tag_value( p ) == v;
} }
/** /**
@ -46,8 +46,9 @@ bool check_tag( struct pso_pointer p, uint32_t v) {
* of the object. * of the object.
* @return false otherwise. * @return false otherwise.
*/ */
bool check_type( struct pso_pointer p, char* s) { bool check_type( struct pso_pointer p, char *s ) {
return (strncmp( return ( strncmp
&(pointer_to_object(p)->header.tag.bytes.mnemonic[0]), s, TAGLENGTH) ( &( pointer_to_object( p )->header.tag.bytes.mnemonic[0] ), s,
== 0); TAGLENGTH )
} == 0 );
}

6
src/c/memory/tags.h
View file

@ -82,7 +82,7 @@
* @return the numerical value of the tag, as a uint32_t. * @return the numerical value of the tag, as a uint32_t.
*/ */
// #define get_tag_value(p)((pointer_to_object(p)->header.tag.value) & 0xffffff) // #define get_tag_value(p)((pointer_to_object(p)->header.tag.value) & 0xffffff)
uint32_t get_tag_value (struct pso_pointer p); uint32_t get_tag_value( struct pso_pointer p );
/** /**
* @brief check that the tag of the object indicated by this poiner has this * @brief check that the tag of the object indicated by this poiner has this
@ -94,9 +94,9 @@ uint32_t get_tag_value (struct pso_pointer p);
* @return true if the tag at p matches v, else false. * @return true if the tag at p matches v, else false.
*/ */
// #define check_tag(p,v) (get_tag_value(p) == v) // #define check_tag(p,v) (get_tag_value(p) == v)
bool check_tag( struct pso_pointer p, uint32_t v); bool check_tag( struct pso_pointer p, uint32_t v );
bool check_type( struct pso_pointer p, char* s); bool check_type( struct pso_pointer p, char *s );
#define characterp(p) (check_tag(p, CHARACTERTV)) #define characterp(p) (check_tag(p, CHARACTERTV))
#define consp(p) (check_tag(p, CONSTV)) #define consp(p) (check_tag(p, CONSTV))

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

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

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

@ -17,12 +17,12 @@
#include "memory/pointer.h" #include "memory/pointer.h"
struct cons_pointer search( struct pso_pointer key, struct cons_pointer search( struct pso_pointer key,
struct pso_pointer store, struct pso_pointer store, bool return_key );
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 #endif

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

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

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

@ -16,10 +16,10 @@
#include "memory/pointer.h" #include "memory/pointer.h"
struct pso_pointer bind( struct pso_pointer frame_pointer, 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 c_bind( struct pso_pointer key,
struct pso_pointer value, struct pso_pointer value,
struct pso_pointer store); struct pso_pointer store );
#endif #endif

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

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

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

@ -16,11 +16,10 @@
#include "memory/pointer.h" #include "memory/pointer.h"
#include "memory/pso4.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 eq( struct pso_pointer frame_pointer,
struct pso_pointer frame_pointer, struct pso_pointer env );
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 #endif

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

@ -10,7 +10,9 @@
*/ */
#include "memory/pointer.h" #include "memory/pointer.h"
#include "memory/pso.h"
#include "memory/pso2.h" #include "memory/pso2.h"
#include "memory/pso3.h"
#include "memory/pso4.h" #include "memory/pso4.h"
#include "memory/tags.h" #include "memory/tags.h"
@ -23,6 +25,8 @@
#include "payloads/special.h" #include "payloads/special.h"
#include "payloads/stack.h" #include "payloads/stack.h"
#include "ops/truth.h"
/** /**
* @brief Despatch eval based on tag of the form in the first position. * @brief Despatch eval based on tag of the form in the first position.
* *
@ -31,9 +35,9 @@
* @param env the evaluation environment. * @param env the evaluation environment.
* @return struct pso_pointer * @return struct pso_pointer
*/ */
struct pso_pointer eval_despatch( struct pso4 *frame, struct pso_pointer lisp_eval( struct pso_pointer frame_pointer,
struct pso_pointer frame_pointer, struct pso_pointer env ) {
struct pso_pointer env ) { struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer result = frame->payload.stack_frame.arg[0]; struct pso_pointer result = frame->payload.stack_frame.arg[0];
// switch ( get_tag_value( result)) { // switch ( get_tag_value( result)) {
@ -55,17 +59,17 @@ struct pso_pointer eval_despatch( struct pso4 *frame,
// break; // 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 ) ) { if ( exceptionp( result ) ) {
// todo: if result doesn't have a stack frame, create a new exception wrapping struct pso3 *x =
// result with this stack frame. ( 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; 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); // 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 * @return a sequence like the `sequence` passed, but reversed; or `nil` if
* the argument was not a sequence. * the argument was not a sequence.
*/ */
struct pso_pointer reverse( struct pso_pointer sequence) { struct pso_pointer reverse( struct pso_pointer sequence ) {
struct pso_pointer result = nil; struct pso_pointer result = nil;
for (struct pso_pointer cursor = sequence; !nilp( sequence); cursor = cdr(cursor)) { for ( struct pso_pointer cursor = sequence; !nilp( sequence );
struct pso2* object = pointer_to_object( cursor); cursor = cdr( cursor ) ) {
switch (get_tag_value(cursor)) { struct pso2 *object = pointer_to_object( cursor );
case CONSTV : switch ( get_tag_value( cursor ) ) {
result = cons( car(cursor), result); case CONSTV:
break; result = cons( car( cursor ), result );
case KEYTV : break;
result = make_string_like_thing( object->payload.string.character, result, KEYTAG); case KEYTV:
break; result =
case STRINGTV : make_string_like_thing( object->payload.string.character,
result = make_string_like_thing( object->payload.string.character, result, STRINGTAG); result, KEYTAG );
break; break;
case SYMBOLTV : case STRINGTV:
result = make_string_like_thing( object->payload.string.character, result, SYMBOLTAG); result =
break; make_string_like_thing( object->payload.string.character,
default : result, STRINGTAG );
result = make_exception( c_string_to_lisp_string(L"Invalid object in sequence"), nil, nil); break;
goto exit; case SYMBOLTV:
break; result =
} make_string_like_thing( object->payload.string.character,
} result, SYMBOLTAG );
exit: 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" #include "memory/pointer.h"
struct pso_pointer reverse( struct pso_pointer sequence); struct pso_pointer reverse( struct pso_pointer sequence );
#endif #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 ); struct pso2 *cell = pointer_to_object( ptr );
uint32_t result = 0; uint32_t result = 0;
switch ( get_tag_value(ptr)) { switch ( get_tag_value( ptr ) ) {
case KEYTV: case KEYTV:
case STRINGTV: case STRINGTV:
case SYMBOLTV: case SYMBOLTV:
@ -70,22 +70,22 @@ uint32_t calculate_hash( wint_t c, struct pso_pointer ptr ) {
* (and thus simpler). * (and thus simpler).
*/ */
struct pso_pointer make_string_like_thing( wint_t c, struct pso_pointer tail, struct pso_pointer make_string_like_thing( wint_t c, struct pso_pointer tail,
char* tag ) { char *tag ) {
struct pso_pointer pointer = nil; struct pso_pointer pointer = nil;
if ( check_type( tail, tag ) || check_tag( tail, NILTV ) ) { 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 ); struct pso2 *cell = pointer_to_object( pointer );
cell->payload.string.character = c; cell->payload.string.character = c;
cell->payload.string.cdr = tail; 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_dump_object( pointer, DEBUG_ALLOC, 0 );
debug_println( DEBUG_ALLOC ); debug_println( DEBUG_ALLOC );
} else { } else {
// \todo should throw an exception! // \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", L"Warning: only %4.4s can be prepended to %4.4s\n",
tag, tag ); tag, tag );
} }

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

@ -17,7 +17,7 @@
#include <wctype.h> #include <wctype.h>
struct pso_pointer make_string_like_thing( wint_t c, struct pso_pointer tail, 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 ); 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/node.h"
#include "memory/pointer.h" #include "memory/pointer.h"
#include "memory/pso4.h"
#include "ops/stack_ops.h" #include "ops/stack_ops.h"
/** /**
@ -64,10 +65,11 @@ bool truep( struct pso_pointer p ) {
* @param env the evaluation environment. * @param env the evaluation environment.
* @return `t` if the first argument in this frame is `nil`, else `t` * @return `t` if the first argument in this frame is `nil`, else `t`
*/ */
struct pso_pointer lisp_nilp( struct pso4 *frame, struct pso_pointer lisp_nilp( struct pso_pointer frame_pointer,
struct pso_pointer frame_pointer, struct pso_pointer env ) {
struct pso_pointer env ) { struct pso4 *frame = pointer_to_pso4( frame_pointer );
return ( nilp( fetch_arg( frame, 0 )) ? t : nil );
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. * @param env the evaluation environment.
* @return `t` if the first argument in this frame is `t`, else `nil`. * @return `t` if the first argument in this frame is `t`, else `nil`.
*/ */
struct pso_pointer lisp_truep( struct pso4 *frame, struct pso_pointer lisp_truep( struct pso_pointer frame_pointer,
struct pso_pointer frame_pointer, struct pso_pointer env ) {
struct pso_pointer env ) { struct pso4 *frame = pointer_to_pso4( frame_pointer );
return ( truep( fetch_arg( frame, 0 ) ) ? t : nil );
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. * @param env the evaluation environment.
* @return `t` if the first argument in this frame is not `nil`, else `t`. * @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 lisp_not( struct pso_pointer frame_pointer,
struct pso_pointer frame_pointer, struct pso_pointer env ) {
struct pso_pointer env ) { struct pso4 *frame = pointer_to_pso4( frame_pointer );
return ( not( fetch_arg( frame, 0 ) ) ? t : nil );
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 ); bool nilp( struct pso_pointer p );
struct pso_pointer lisp_nilp( struct pso4 *frame, struct pso_pointer lisp_nilp( struct pso_pointer frame_pointer,
struct pso_pointer frame_pointer, struct pso_pointer env );
struct pso_pointer env );
bool not( struct pso_pointer p ); bool not( struct pso_pointer p );
struct pso_pointer lisp_not( struct pso4 *frame, struct pso_pointer lisp_not( struct pso_pointer frame_pointer,
struct pso_pointer frame_pointer, struct pso_pointer env );
struct pso_pointer env );
bool truep( struct pso_pointer p ); bool truep( struct pso_pointer p );
struct pso_pointer lisp_truep( struct pso4 *frame, struct pso_pointer lisp_truep( struct pso_pointer frame_pointer,
struct pso_pointer frame_pointer, struct pso_pointer env );
struct pso_pointer env );
#endif #endif

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

@ -23,12 +23,13 @@
#include "payloads/character.h" #include "payloads/character.h"
struct pso_pointer make_character( wint_t c) { struct pso_pointer make_character( wint_t c ) {
struct pso_pointer result = allocate( CHARACTERTAG, 2 ); struct pso_pointer result = allocate( CHARACTERTAG, 2 );
if (!nilp(result)) { 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; return result;
} }

2
src/c/payloads/character.h
View file

@ -36,5 +36,5 @@ struct character_payload {
wchar_t character; wchar_t character;
}; };
struct pso_pointer make_character( wint_t c); struct pso_pointer make_character( wint_t c );
#endif #endif

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

@ -14,7 +14,7 @@
#include "memory/pso.h" #include "memory/pso.h"
#include "memory/pso2.h" #include "memory/pso2.h"
#include "memory/pso4.h" #include "memory/pso4.h"
#include "memory/tags.h" #include "memory/tags.h"
#include "payloads/cons.h" #include "payloads/cons.h"
#include "payloads/exception.h" #include "payloads/exception.h"
@ -70,17 +70,21 @@ struct pso_pointer cdr( struct pso_pointer p ) {
struct pso_pointer result = nil; struct pso_pointer result = nil;
struct pso2 *object = pointer_to_object( result ); struct pso2 *object = pointer_to_object( result );
switch (get_tag_value( p)) { switch ( get_tag_value( p ) ) {
case CONSTV : result = object->payload.cons.cdr; break; case CONSTV:
case KEYTV : result = object->payload.cons.cdr;
case STRINGTV : break;
case SYMBOLTV : case KEYTV:
result = object->payload.string.cdr; break; case STRINGTV:
default : case SYMBOLTV:
result = make_exception( result = object->payload.string.cdr;
cons(c_string_to_lisp_string(L"Invalid type for cdr"), p), break;
nil, nil); default:
break; result =
make_exception( cons
( c_string_to_lisp_string
( L"Invalid type for cdr" ), p ), nil, nil );
break;
} }
// TODO: else throw an exception // TODO: else throw an exception
@ -95,11 +99,12 @@ struct pso_pointer cdr( struct pso_pointer p ) {
* Lisp calling conventions; one expected arg, the pointer to the cell to * Lisp calling conventions; one expected arg, the pointer to the cell to
* be destroyed. * be destroyed.
*/ */
struct pso_pointer destroy_cons( struct pso_pointer fp, struct pso_pointer env) { struct pso_pointer destroy_cons( struct pso_pointer fp,
if (stackp(fp)) { struct pso_pointer env ) {
struct pso4 *frame = pointer_to_pso4( fp); if ( stackp( fp ) ) {
struct pso_pointer p = frame->payload.stack_frame.arg[0]; struct pso4 *frame = pointer_to_pso4( fp );
dec_ref( car( p)); struct pso_pointer p = frame->payload.stack_frame.arg[0];
dec_ref( cdr( p)); dec_ref( car( p ) );
} dec_ref( cdr( p ) );
}
} }

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

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

@ -17,7 +17,8 @@
#include "payloads/exception.h" #include "payloads/exception.h"
struct pso_pointer make_exception( struct pso_pointer message, 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 // TODO: not yet implemented
return nil; return nil;
} }
@ -29,13 +30,13 @@ struct pso_pointer make_exception( struct pso_pointer message,
* be destroyed. * be destroyed.
*/ */
struct pso_pointer destroy_exception( struct pso_pointer fp, struct pso_pointer destroy_exception( struct pso_pointer fp,
struct pso_pointer env) { struct pso_pointer env ) {
if (stackp(fp)) { if ( stackp( fp ) ) {
struct pso4 *frame = pointer_to_pso4( fp); struct pso4 *frame = pointer_to_pso4( fp );
struct pso_pointer p = frame->payload.stack_frame.arg[0]; struct pso_pointer p = frame->payload.stack_frame.arg[0];
// TODO: decrement every pointer indicated by an exception. // TODO: decrement every pointer indicated by an exception.
} }
return nil; return nil;
} }

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

@ -25,9 +25,10 @@ struct exception_payload {
}; };
struct pso_pointer make_exception( struct pso_pointer message, 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 destroy_exception( struct pso_pointer fp,
struct pso_pointer env); struct pso_pointer env );
#endif #endif

10
src/c/payloads/integer.c
View file

@ -26,13 +26,13 @@
*/ */
struct pso_pointer make_integer( int64_t value ) { struct pso_pointer make_integer( int64_t value ) {
struct pso_pointer result = nil; struct pso_pointer result = nil;
debug_print( L"Entering make_integer\n", DEBUG_ALLOC , 0); debug_print( L"Entering make_integer\n", DEBUG_ALLOC, 0 );
result = allocate( INTEGERTAG, 2); result = allocate( INTEGERTAG, 2 );
struct pso2 *cell = pointer_to_object( result ); struct pso2 *cell = pointer_to_object( result );
cell->payload.integer.value = value; cell->payload.integer.value = value;
debug_print( L"make_integer: returning\n", DEBUG_ALLOC , 0); debug_print( L"make_integer: returning\n", DEBUG_ALLOC, 0 );
debug_dump_object( result, DEBUG_ALLOC, 0 ); debug_dump_object( result, DEBUG_ALLOC, 0 );
return result; return result;

18
src/c/payloads/psse_string.c
View file

@ -11,8 +11,8 @@
#include <stdint.h> #include <stdint.h>
/* /*
* wide characters * wide characters
*/ */
#include <wchar.h> #include <wchar.h>
#include <wctype.h> #include <wctype.h>
@ -33,13 +33,13 @@
* be destroyed. * be destroyed.
*/ */
struct pso_pointer destroy_string( struct pso_pointer fp, struct pso_pointer destroy_string( struct pso_pointer fp,
struct pso_pointer env) { struct pso_pointer env ) {
if (stackp(fp)) { if ( stackp( fp ) ) {
struct pso4 *frame = pointer_to_pso4( fp); struct pso4 *frame = pointer_to_pso4( fp );
struct pso_pointer p = frame->payload.stack_frame.arg[0]; struct pso_pointer p = frame->payload.stack_frame.arg[0];
dec_ref( cdr(p)); dec_ref( cdr( p ) );
} }
return nil; return nil;
} }

2
src/c/payloads/psse_string.h
View file

@ -36,6 +36,6 @@ struct string_payload {
struct pso_pointer make_string( wint_t c, struct pso_pointer tail ); struct pso_pointer make_string( wint_t c, struct pso_pointer tail );
struct pso_pointer destroy_string( struct pso_pointer fp, struct pso_pointer destroy_string( struct pso_pointer fp,
struct pso_pointer env); struct pso_pointer env );
#endif #endif

4
src/c/payloads/read_stream.c
View file

@ -25,8 +25,8 @@
* @return a pointer to the new read stream. * @return a pointer to the new read stream.
*/ */
struct pso_pointer make_read_stream( URL_FILE *input, struct pso_pointer make_read_stream( URL_FILE *input,
struct pso_pointer metadata ) { struct pso_pointer metadata ) {
struct pso_pointer pointer = allocate( READTAG, 2); struct pso_pointer pointer = allocate( READTAG, 2 );
struct pso2 *cell = pointer_to_object( pointer ); struct pso2 *cell = pointer_to_object( pointer );
cell->payload.stream.stream = input; cell->payload.stream.stream = input;

4
src/c/payloads/read_stream.h
View file

@ -29,7 +29,7 @@ struct stream_payload {
struct pso_pointer meta; struct pso_pointer meta;
}; };
struct pso_pointer make_read_stream( URL_FILE *input, struct pso_pointer make_read_stream( URL_FILE * input,
struct pso_pointer metadata ); struct pso_pointer metadata );
#endif #endif

90
src/c/payloads/stack.c
View file

@ -25,44 +25,44 @@
* *
* @return a pso_pointer to the stack frame. * @return a pso_pointer to the stack frame.
*/ */
struct pso_pointer make_frame( struct pso_pointer previous, ...) { struct pso_pointer make_frame( struct pso_pointer previous, ... ) {
va_list args; va_list args;
va_start(args, previous); va_start( args, previous );
int count = va_arg(args, int); int count = va_arg( args, int );
struct pso_pointer frame_pointer = allocate( STACKTAG, 4); struct pso_pointer frame_pointer = allocate( STACKTAG, 4 );
struct pso4* frame = (struct pso4*)pointer_to_object( frame_pointer); struct pso4 *frame = ( struct pso4 * ) pointer_to_object( frame_pointer );
frame->payload.stack_frame.previous = previous; frame->payload.stack_frame.previous = previous;
// I *think* the count starts with the number of args, so there are // I *think* the count starts with the number of args, so there are
// one fewer actual args. Need to test to verify this! // one fewer actual args. Need to test to verify this!
count --; count--;
int cursor = 0; int cursor = 0;
frame->payload.stack_frame.args = count; frame->payload.stack_frame.args = count;
for ( ; cursor < count && cursor < args_in_frame; cursor++) { for ( ; cursor < count && cursor < args_in_frame; cursor++ ) {
struct pso_pointer argument = va_arg( args, struct pso_pointer); struct pso_pointer argument = va_arg( args, struct pso_pointer );
frame->payload.stack_frame.arg[cursor] = inc_ref( argument); frame->payload.stack_frame.arg[cursor] = inc_ref( argument );
} }
if ( cursor < count) { if ( cursor < count ) {
struct pso_pointer more_args = nil; struct pso_pointer more_args = nil;
for (; cursor < count; cursor++) { for ( ; cursor < count; cursor++ ) {
more_args = cons( va_arg( args, struct pso_pointer), more_args); more_args = cons( va_arg( args, struct pso_pointer ), more_args );
} }
// should be frame->payload.stack_frame.more = reverse( more_args), but // should be frame->payload.stack_frame.more = reverse( more_args), but
// we don't have reverse yet. TODO: fix. // we don't have reverse yet. TODO: fix.
frame->payload.stack_frame.more = more_args; frame->payload.stack_frame.more = more_args;
} else { } else {
for (; cursor < args_in_frame; cursor++) { for ( ; cursor < args_in_frame; cursor++ ) {
frame->payload.stack_frame.arg[cursor] = nil; frame->payload.stack_frame.arg[cursor] = nil;
} }
} }
return frame_pointer; return frame_pointer;
} }
/** /**
@ -72,23 +72,23 @@ struct pso_pointer make_frame( struct pso_pointer previous, ...) {
* be destroyed. * be destroyed.
*/ */
struct pso_pointer destroy_stack_frame( struct pso_pointer fp, struct pso_pointer destroy_stack_frame( struct pso_pointer fp,
struct pso_pointer env) { struct pso_pointer env ) {
if (stackp(fp)) { if ( stackp( fp ) ) {
struct pso4 *frame = pointer_to_pso4( fp); struct pso4 *frame = pointer_to_pso4( fp );
struct pso4 * casualty = struct pso4 *casualty =
pointer_to_pso4( frame->payload.stack_frame.arg[0]); pointer_to_pso4( frame->payload.stack_frame.arg[0] );
dec_ref( casualty->payload.stack_frame.previous); dec_ref( casualty->payload.stack_frame.previous );
dec_ref( casualty->payload.stack_frame.function); dec_ref( casualty->payload.stack_frame.function );
dec_ref( casualty->payload.stack_frame.more); dec_ref( casualty->payload.stack_frame.more );
for (int i = 0; i < args_in_frame; i++) { for ( int i = 0; i < args_in_frame; i++ ) {
dec_ref( casualty->payload.stack_frame.arg[0]); dec_ref( casualty->payload.stack_frame.arg[0] );
} }
casualty->payload.stack_frame.args = 0; casualty->payload.stack_frame.args = 0;
casualty->payload.stack_frame.depth = 0; casualty->payload.stack_frame.depth = 0;
} }
return nil; return nil;
} }

4
src/c/payloads/stack.h
View file

@ -37,9 +37,9 @@ struct stack_frame_payload {
uint32_t depth; uint32_t depth;
}; };
struct pso_pointer make_frame( struct pso_pointer previous, ...); struct pso_pointer make_frame( struct pso_pointer previous, ... );
struct pso_pointer destroy_stack_frame( struct pso_pointer fp, struct pso_pointer destroy_stack_frame( struct pso_pointer fp,
struct pso_pointer env); struct pso_pointer env );
#endif #endif

3
src/c/psse.c
View file

@ -101,11 +101,10 @@ int main( int argc, char *argv[] ) {
} }
} }
if ( nilp( initialise_node( 0 ))) { if ( nilp( initialise_node( 0 ) ) ) {
fputs( "Failed to initialise node\n", stderr ); fputs( "Failed to initialise node\n", stderr );
exit( 1 ); exit( 1 );
} }
// repl( ); // repl( );
exit( 0 ); exit( 0 );