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

Still making progress. Dropped the archive because it was causing problems.

Browse source
This commit is contained in:
Simon Brooke 2026-04-22 21:09:15 +01:00
parent eed4711fee
commit 8d2acbeb0f
97 changed files with 490 additions and 13322 deletions
Download patch file Download diff file Expand all files Collapse all files

20
src/c/environment/environment.c
View file

@ -41,11 +41,11 @@ bool environment_initialised = false;
struct pso_pointer initialise_environment( uint32_t node ) {
struct pso_pointer result = initialise_memory( node );
struct pso_pointer frame = make_frame(0, nil);
struct pso_pointer frame_pointer = make_frame( 0, nil );
if ( c_truep( result ) ) {
debug_print( L"Initialising `nil`... ", DEBUG_BOOTSTRAP, 0 );
struct pso_pointer n = allocate( frame, NILTAG, 2 );
struct pso_pointer n = allocate( frame_pointer, NILTAG, 2 );
if ( ( n.page == 0 ) && ( n.offset == 0 ) ) {
struct pso2 *object = pointer_to_object( n );
@ -62,7 +62,7 @@ struct pso_pointer initialise_environment( uint32_t node ) {
}
if ( !c_nilp( result ) ) {
debug_print( L"Initialising `t`... ", DEBUG_BOOTSTRAP, 0 );
struct pso_pointer n = allocate( frame, TRUETAG, 2 );
struct pso_pointer n = allocate( frame_pointer, TRUETAG, 2 );
// offset is in words, and size of a pso2 is four words
if ( ( n.page == 0 ) && ( n.offset == 4 ) ) {
@ -79,11 +79,19 @@ struct pso_pointer initialise_environment( uint32_t node ) {
}
}
if ( !exceptionp( result ) ) {
result = c_bind( c_string_to_lisp_symbol( frame, L"nil" ), nil, nil );
result =
lisp_bind( make_frame
( 3, frame_pointer,
c_string_to_lisp_symbol( frame_pointer, L"nil" ), nil,
nil ) );
debug_print( L"Environment after binding `nil`: ", DEBUG_BOOTSTRAP,
0 );
debug_print_object( result, DEBUG_BOOTSTRAP, 0 );
result = c_bind( c_string_to_lisp_symbol( frame, L"t" ), t, result );
result =
lisp_bind( make_frame
( 3, frame_pointer,
c_string_to_lisp_symbol( frame_pointer, L"t" ), t,
result ) );
environment_initialised = true;
debug_print( L"Environment after binding `t`: ", DEBUG_BOOTSTRAP, 0 );
@ -93,5 +101,7 @@ struct pso_pointer initialise_environment( uint32_t node ) {
DEBUG_BOOTSTRAP, 0 );
}
dec_ref( frame_pointer );
return result;
}

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

@ -26,6 +26,7 @@
*/
#include <wchar.h>
#include <wctype.h>
#include <wctype.h>
#include <curl/curl.h>
@ -149,65 +150,79 @@ int initialise_io( ) {
return result;
}
struct pso_pointer initialise_default_streams( struct pso_pointer env ) {
struct pso_pointer initialise_default_streams( struct pso_pointer stack_frame,
struct pso_pointer env ) {
// todo: issue #21: should this have stack frame passed in?
// It's called in initialisation before everything else is set
// up, so **possibly** not?
lisp_io_in = c_string_to_lisp_symbol( C_IO_IN );
lisp_io_out = c_string_to_lisp_symbol( C_IO_OUT );
lisp_io_log = c_string_to_lisp_symbol( C_IO_LOG );
lisp_io_prompt = c_string_to_lisp_symbol( C_IO_PROMPT );
lisp_io_in = c_string_to_lisp_symbol( stack_frame, C_IO_IN );
lisp_io_out = c_string_to_lisp_symbol( stack_frame, C_IO_OUT );
lisp_io_log = c_string_to_lisp_symbol( stack_frame, C_IO_LOG );
lisp_io_prompt = c_string_to_lisp_symbol( stack_frame, C_IO_PROMPT );
debug_print( L"In initialise_default_streams; environment is: ", DEBUG_IO,
0 );
debug_print_object( env, DEBUG_IO, 0 );
env =
c_bind( lisp_io_prompt, c_string_to_lisp_string( INITIAL_PROMPT ),
env );
lisp_stdin = lock_object( make_read_stream( file_to_url_file( stdin ),
make_cons( make_cons
( c_string_to_lisp_keyword
( L"url" ),
c_string_to_lisp_string
( L"::system:standard-input" ) ),
nil ) ) );
env = c_bind( lisp_io_in, lisp_stdin, env );
lisp_bind( make_frame
( 3, stack_frame, lisp_io_prompt,
c_string_to_lisp_string( stack_frame, INITIAL_PROMPT ),
env ) );
lisp_stdin =
lock_object( make_read_stream
( stack_frame, file_to_url_file( stdin ),
make_cons( stack_frame,
make_cons( stack_frame,
c_string_to_lisp_keyword
( stack_frame, L"url" ),
c_string_to_lisp_string
( stack_frame,
L"::system:standard-input" ) ),
stack_frame ) ) );
env =
lisp_bind( make_frame( 3, stack_frame, lisp_io_in, lisp_stdin, env ) );
debug_print_object( env, DEBUG_IO, 0 );
if ( !nilp( env ) && !exceptionp( env ) ) {
if ( !c_nilp( env ) && !exceptionp( env ) ) {
lisp_stdout =
lock_object( make_write_stream
( file_to_url_file( stdout ),
make_cons( make_cons
( c_string_to_lisp_keyword( L"url" ),
c_string_to_lisp_string
( L"::system:standard-output" ) ),
nil ) ) );
env = c_bind( lisp_io_out, lisp_stdout, env );
lock_object( make_write_stream( stack_frame,
file_to_url_file( stdout ),
make_cons( stack_frame,
make_cons( stack_frame,
c_string_to_lisp_keyword
( stack_frame,
L"url" ),
c_string_to_lisp_string
( stack_frame,
L"::system:standard-output" ) ),
nil ) ) );
env =
lisp_bind( make_frame
( 3, stack_frame, lisp_io_out, lisp_stdout, env ) );
}
if ( !nilp( env ) && !exceptionp( env ) ) {
if ( !c_nilp( env ) && !exceptionp( env ) ) {
lisp_stderr =
lock_object( make_write_stream
( file_to_url_file( stderr ),
make_cons( make_cons
( c_string_to_lisp_keyword( L"url" ),
c_string_to_lisp_string
( L"::system:standard-output" ) ),
( stack_frame, file_to_url_file( stderr ),
make_cons( stack_frame,
make_cons( stack_frame,
c_string_to_lisp_keyword
( stack_frame, L"url" ),
c_string_to_lisp_string
( stack_frame,
L"::system:standard-output" ) ),
nil ) ) );
env = c_bind( lisp_io_log, lisp_stderr, env );
env =
lisp_bind( make_frame
( 3, frame_pointer, lisp_io_log, lisp_stderr, env ) );
}
debug_print( L"Leaving initialise_default_streams; environment is: ",
DEBUG_IO, 0 );
debug_print_object( env, DEBUG_IO, 0 );
return env;
}
@ -222,20 +237,17 @@ struct pso_pointer initialise_default_streams( struct pso_pointer env ) {
*/
char *lisp_string_to_c_string( struct pso_pointer s ) {
char *result = NULL;
if ( stringp( s ) || symbolp( s ) ) {
int len = 0;
for ( struct pso_pointer c = s; !nilp( c ); c = c_cdr( c ) ) {
for ( struct pso_pointer c = s; !c_nilp( c ); c = c_cdr( c ) ) {
len++;
}
char32_t *buffer = calloc( len + 1, sizeof( char32_t ) );
/* worst case, one wide char = four utf bytes */
result = calloc( ( len * 4 ) + 1, sizeof( char ) );
int i = 0;
for ( struct pso_pointer c = s; !nilp( c ); c = c_cdr( c ) ) {
for ( struct pso_pointer c = s; !c_nilp( c ); c = c_cdr( c ) ) {
buffer[i++] = pointer_to_object( c )->payload.string.character;
}
@ -246,7 +258,6 @@ char *lisp_string_to_c_string( struct pso_pointer s ) {
debug_print( L"lisp_string_to_c_string( ", DEBUG_IO, 0 );
debug_print_object( s, DEBUG_IO, 0 );
debug_printf( DEBUG_IO, 0, L") => '%s'\n", result );
return result;
}
@ -258,7 +269,6 @@ char *lisp_string_to_c_string( struct pso_pointer s ) {
*/
wint_t url_fgetwc( URL_FILE *input ) {
wint_t result = -1;
if ( ungotten != 0 ) {
/* TODO: not thread safe */
result = ungotten;
@ -269,14 +279,11 @@ wint_t url_fgetwc( URL_FILE *input ) {
fwide( input->handle.file, 1 ); /* wide characters */
result = fgetwc( input->handle.file ); /* passthrough */
break;
case CFTYPE_CURL:{
char *cbuff =
calloc( sizeof( char32_t ) + 2, sizeof( char ) );
char32_t *wbuff = calloc( 2, sizeof( char32_t ) );
size_t count = 0;
debug_print( L"url_fgetwc: about to call url_fgets\n",
DEBUG_IO, 0 );
url_fgets( cbuff, 2, input );
@ -312,10 +319,10 @@ wint_t url_fgetwc( URL_FILE *input ) {
}
mbstowcs( wbuff, cbuff, 2 ); //(char *)(&input->buffer[input->buffer_pos]), 1 );
result = wbuff[0];
free( wbuff );
free( cbuff );
} break;
}
break;
case CFTYPE_NONE:
break;
}
@ -328,13 +335,11 @@ wint_t url_fgetwc( URL_FILE *input ) {
wint_t url_ungetwc( wint_t wc, URL_FILE *input ) {
wint_t result = -1;
switch ( input->type ) {
case CFTYPE_FILE:
fwide( input->handle.file, 1 ); /* wide characters */
result = ungetwc( wc, input->handle.file ); /* passthrough */
break;
case CFTYPE_CURL:{
ungotten = wc;
break;
@ -356,12 +361,11 @@ wint_t url_ungetwc( wint_t wc, URL_FILE *input ) {
*/
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 ) );
( pointer_to_object_of_size_class
( read_stream, 2 )->payload.stream.stream ) );
}
return result;
@ -378,7 +382,6 @@ 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 result = nil;
if ( characterp( c ) && readp( r ) ) {
if ( url_ungetwc( ( wint_t )
( pointer_to_object( c )->payload.character.
@ -407,10 +410,11 @@ struct pso_pointer 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 ) == 0 ) {
if ( url_fclose
( pointer_to_object( fetch_arg( frame, 0 ) )->payload.stream.
stream )
== 0 ) {
result = t;
}
}
@ -433,7 +437,6 @@ struct pso_pointer add_meta_string( struct pso_pointer meta, char32_t *key,
value = trim( value );
char32_t buffer[strlen( value ) + 1];
mbstowcs( buffer, value, strlen( value ) + 1 );
return
make_cons( make_cons
( c_string_to_lisp_keyword( frame_pointer, key ),
@ -444,10 +447,8 @@ struct pso_pointer add_meta_time( struct pso_pointer meta, char32_t *key,
time_t *value ) {
// todo: issue #21: must have stack frame passed in.
char datestring[256];
strftime( datestring, sizeof( datestring ), nl_langinfo( D_T_FMT ),
localtime( value ) );
return add_meta_string( meta, key, datestring );
}
@ -458,43 +459,33 @@ struct pso_pointer add_meta_time( struct pso_pointer meta, char32_t *key,
static size_t write_meta_callback( char *string, size_t size, size_t nmemb,
struct pso_pointer stream ) {
struct pso2 *cell = pointer_to_object( stream );
// TODO: reimplement
/* make a copy of the string that we can destructively change */
// char *s = calloc( strlen( string ), sizeof( char ) );
// strcpy( s, string );
// if ( check_tag( cell, READTV) ||
// check_tag( cell, WRITETV) ) {
// int offset = index_of( ':', s );
// if ( offset != -1 ) {
// s[offset] = ( char ) 0;
// char *name = trim( s );
// char *value = trim( &s[++offset] );
// char32_t wname[strlen( name )];
// mbstowcs( wname, name, strlen( name ) + 1 );
// cell->payload.stream.meta =
// add_meta_string( cell->payload.stream.meta, wname, value );
// debug_printf( DEBUG_IO,
// L"write_meta_callback: added header '%s': value
// '%s'\n", name, value );
// } else if ( strncmp( "HTTP", s, 4 ) == 0 ) {
// int offset = index_of( ' ', s );
// char *value = trim( &s[offset] );
// cell->payload.stream.meta =
// add_meta_integer( add_meta_string
// ( cell->payload.stream.meta, L"status",
// value ), L"status-code", strtol( value,
// NULL,
// 10 ) );
// debug_printf( DEBUG_IO,
// L"write_meta_callback: added header 'status': value
// '%s'\n", value );
@ -510,7 +501,6 @@ static size_t write_meta_callback( char *string, size_t size, size_t nmemb,
// DEBUG_IO );
// debug_dump_object( stream, DEBUG_IO );
// }
// free( s );
return 0; // strlen( string );
}
@ -519,12 +509,12 @@ void collect_meta( struct pso_pointer stream, char *url ) {
struct pso2 *cell = pointer_to_object( stream );
URL_FILE *s = pointer_to_object( stream )->payload.stream.stream;
struct pso_pointer meta =
add_meta_string( cell->payload.stream.meta, L"url", url );
add_meta_string( cell->payload.stream.meta, L"url",
url );
struct stat statbuf;
int result = stat( url, &statbuf );
struct passwd *pwd;
struct group *grp;
switch ( s->type ) {
case CFTYPE_NONE:
break;
@ -545,7 +535,6 @@ void collect_meta( struct pso_pointer stream, char *url ) {
meta =
add_meta_integer( meta, L"size",
( intmax_t ) statbuf.st_size );
meta = add_meta_time( meta, L"modified", &statbuf.st_mtime );
}
break;
@ -569,9 +558,7 @@ void collect_meta( struct pso_pointer stream, char *url ) {
struct pso_pointer get_default_stream( bool inputp, struct pso_pointer env ) {
struct pso_pointer result = nil;
struct pso_pointer stream_name = inputp ? lisp_io_in : lisp_io_out;
result = c_assoc( stream_name, env );
return result;
}
@ -581,10 +568,8 @@ struct pso_pointer get_default_stream( bool inputp, struct pso_pointer env ) {
*/
URL_FILE *stream_get_url_file( struct pso_pointer s ) {
URL_FILE *result = NULL;
if ( readp( s ) || writep( s ) ) {
struct pso2 *obj = pointer_to_object( s );
result = obj->payload.stream.stream;
}
@ -610,18 +595,14 @@ struct pso_pointer 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) ) ) {
// char *url = lisp_string_to_c_string( fetch_arg( frame, 0) );
// if ( nilp( fetch_arg( frame, 1) ) ) {
// if ( c_nilp( fetch_arg( frame, 1) ) ) {
// URL_FILE *stream = url_fopen( url, "r" );
// debug_printf( DEBUG_IO, 0,
// L"lisp_open: stream @ %ld, stream type = %d, stream
// handle = %ld\n", ( long int ) &stream, ( int )
// stream->type, ( long int ) stream->handle.file );
// switch ( stream->type ) {
// case CFTYPE_NONE:
// return
@ -641,23 +622,19 @@ struct pso_pointer lisp_open( struct pso_pointer frame_pointer,
// /* can't tell whether a URL is bad without reading it */
// break;
// }
// result = make_read_stream( stream, nil );
// } else {
// // TODO: anything more complex is a problem for another day.
// URL_FILE *stream = url_fopen( url, "w" );
// result = make_write_stream( stream, nil );
// }
// if ( pointer_to_object( result )->payload.stream.stream == NULL ) {
// result = nil;
// } else {
// collect_meta( result, url );
// }
// free( url );
// }
return result;
}
@ -677,12 +654,11 @@ struct pso_pointer 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;
struct pso_pointer stream_pointer = fetch_arg( frame, 0 );
if ( readp( stream_pointer ) ) {
result =
make_string( frame_pointer, url_fgetwc( stream_get_url_file( stream_pointer ) ),
nil );
result = make_string( frame_pointer,
url_fgetwc( stream_get_url_file
( stream_pointer ) ), nil );
}
return result;
@ -706,12 +682,11 @@ struct pso_pointer 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 = stream_get_url_file( fetch_arg( frame, 0 ) );
struct pso_pointer cursor = make_string( frame_pointer, url_fgetwc( stream ), nil );
struct pso_pointer cursor = make_string( frame_pointer,
url_fgetwc( stream ), nil );
result = cursor;
for ( wint_t c = url_fgetwc( stream ); !url_feof( stream ) && c != 0;
c = url_fgetwc( stream ) ) {
debug_print( L"slurp: cursor is: ", DEBUG_IO, 0 );
@ -719,7 +694,6 @@ struct pso_pointer lisp_slurp( struct pso_pointer frame_pointer,
debug_print( L"; result is: ", DEBUG_IO, 0 );
debug_dump_object( result, DEBUG_IO, 0 );
debug_println( DEBUG_IO );
struct pso2 *cell = pointer_to_object( cursor );
cursor = make_string( frame_pointer, ( char32_t ) c, nil );
cell->payload.string.cdr = cursor;

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

@ -12,6 +12,13 @@
#define __psse_io_io_h
#include <curl/curl.h>
/*
* wide characters
*/
#include <uchar.h>
#include <wchar.h>
#include <wctype.h>
#include "memory/pointer.h"
#include "memory/pso2.h"
#include "memory/pso4.h"
@ -19,7 +26,9 @@
extern CURLSH *io_share;
int initialise_io( );
struct pso_pointer initialise_default_streams( struct pso_pointer env );
struct pso_pointer initialise_default_streams( struct pso_pointer
frame_pointer,
struct pso_pointer env );
#define C_IO_IN L"*in*"
#define C_IO_OUT L"*out*"

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

@ -42,6 +42,7 @@
#include "payloads/exception.h"
#include "payloads/integer.h"
#include "ops/stack_ops.h"
#include "ops/truth.h"
struct pso_pointer in_write( struct pso_pointer p, URL_FILE * output,
@ -78,7 +79,7 @@ struct pso_pointer print_string_like_thing( struct pso_pointer p,
}
if ( keywordp( p ) || stringp( p ) || symbolp( p ) ) {
for ( struct pso_pointer cursor = p; !nilp( cursor );
for ( struct pso_pointer cursor = p; !c_nilp( cursor );
cursor = pointer_to_object( cursor )->payload.string.cdr ) {
char32_t wc =
pointer_to_object( cursor )->payload.string.character;
@ -190,7 +191,9 @@ struct pso_pointer in_write( struct pso_pointer p, URL_FILE *output,
* This is kind of modelled after the implementation of PRIN* variants on page
* 383 of the aluminium book. It is the inner workings of all PRIN* functions.
*
* @param p pointer to the object to print.
* (write object stream escape? nl_before? nl_after?)
*
* @param object pointer to the object to print.
* @param output stream to print to.
* @param escape if true, print everything so that it can be read by the Lisp
* reader; otherwise, print it appropriately for human readers.
@ -198,9 +201,14 @@ struct pso_pointer in_write( struct pso_pointer p, URL_FILE *output,
* @param nl_after if true, print a newline *after* printing `p`; else a space.
* @return p on success, exception on failure.
*/
struct pso_pointer write( struct pso_pointer p, struct pso_pointer stream,
bool escape, bool nl_before, bool nl_after ) {
struct pso_pointer result = p;
struct pso_pointer write( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer object = fetch_arg( frame, 0 );
struct pso_pointer stream = fetch_arg( frame, 1 );
bool escape = c_truep( fetch_arg( frame, 2 ) );
bool nl_before = c_truep( fetch_arg( frame, 3 ) );
bool nl_after = c_truep( fetch_arg( frame, 4 ) );
struct pso_pointer result = object;
URL_FILE *output = writep( stream )
? pointer_to_object( stream )->payload.stream.stream
: file_to_url_file( stdout );
@ -211,16 +219,17 @@ struct pso_pointer write( struct pso_pointer p, struct pso_pointer stream,
if ( nl_before )
url_fputwc( L'\n', output );
result = in_write( p, output, true );
result = in_write( object, output, true );
url_fputwc( nl_after ? L'\n' : L' ', output );
dec_ref( stream );
} else {
result =
make_exception( c_string_to_lisp_string
( L"Bad write stream passed to write." ), nil, nil,
nil );
make_exception( make_frame( 1, frame_pointer,
c_string_to_lisp_string
( frame_pointer,
L"Bad write stream passed to write." ) ) );
}
return result;
@ -233,13 +242,21 @@ struct pso_pointer write( struct pso_pointer p, struct pso_pointer stream,
* @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.
*/
struct pso_pointer c_print( struct pso_pointer p, struct pso_pointer stream ) {
return write( p, stream, true, true, false );
struct pso_pointer print( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
return write( make_frame( 5, frame_pointer,
fetch_arg( frame, 0 ), fetch_arg( frame, 1 ), t,
t, nil ) );
}
/**
* @brief princ is pretty much like print except things are printed `unescaped`
*/
struct pso_pointer c_princ( struct pso_pointer p, struct pso_pointer stream ) {
return write( p, stream, false, true, false );
struct pso_pointer princ( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
return write( make_frame( 5, frame_pointer,
fetch_arg( frame, 0 ), fetch_arg( frame, 1 ),
nil, t, nil ) );
}

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

@ -16,8 +16,8 @@
#include <stdbool.h>
#include "io/fopen.h"
struct pso_pointer c_print( struct pso_pointer p, struct pso_pointer stream );
struct pso_pointer c_princ( struct pso_pointer p, struct pso_pointer stream );
struct pso_pointer print( struct pso_pointer frame_pointer );
struct pso_pointer princ( struct pso_pointer frame_pointer );
#define PRINT_VARIANT_PRINT 0
#define PRINT_VARIANT_PRIN1 1

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

@ -98,12 +98,7 @@ struct pso_pointer read_example(
* 1. The read table currently in use;
* 2. The character most recently read from that stream.
*/
struct pso_pointer read_number(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer,
struct pso_pointer env ) {
struct pso_pointer read_number( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer stream = fetch_arg( frame, 0 );
struct pso_pointer readtable = fetch_arg( frame, 1 );
@ -115,10 +110,10 @@ struct pso_pointer read_number(
int64_t value = 0;
if ( readp( stream ) ) {
if ( nilp( character ) ) {
if ( c_nilp( character ) ) {
character = get_character( stream );
}
char32_t c = nilp( character )
char32_t c = c_nilp( character )
? 0 : pointer_to_object( character )->payload.character.character;
URL_FILE *input = pointer_to_object( stream )->payload.stream.stream;
@ -127,18 +122,13 @@ struct pso_pointer read_number(
}
url_ungetwc( c, input );
result = make_integer( value );
result = make_integer( frame_pointer, value );
} // else exception?
return result;
}
struct pso_pointer read_symbol(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer,
struct pso_pointer env ) {
struct pso_pointer read_symbol( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer stream = fetch_arg( frame, 0 );
struct pso_pointer readtable = fetch_arg( frame, 1 );
@ -146,16 +136,17 @@ struct pso_pointer read_symbol(
struct pso_pointer result = nil;
if ( readp( stream ) ) {
if ( nilp( character ) ) {
if ( c_nilp( character ) ) {
character = get_character( stream );
}
char32_t c = nilp( character )
char32_t c = c_nilp( character )
? 0 : pointer_to_object( character )->payload.character.character;
URL_FILE *input = pointer_to_object( stream )->payload.stream.stream;
for ( ; iswalnum( c ); c = url_fgetwc( input ) ) {
result = make_string_like_thing( c, result, SYMBOLTAG );
result =
make_string_like_thing( frame_pointer, c, result, SYMBOLTAG );
}
url_ungetwc( c, input );
@ -176,12 +167,7 @@ struct pso_pointer read_symbol(
* 1. The read table currently in use;
* 2. The character most recently read from that stream.
*/
struct pso_pointer read(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer,
struct pso_pointer env ) {
struct pso_pointer read( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer stream = fetch_arg( frame, 0 );
struct pso_pointer readtable = fetch_arg( frame, 1 );
@ -189,22 +175,23 @@ struct pso_pointer read(
struct pso_pointer result = nil;
if ( nilp( stream ) ) {
stream = make_read_stream( file_to_url_file( stdin ), nil );
if ( c_nilp( stream ) ) {
stream =
make_read_stream( frame_pointer, file_to_url_file( stdin ), nil );
}
if ( nilp( readtable ) ) {
if ( c_nilp( readtable ) ) {
// TODO: check for the value of `*read-table*` in the environment and
// use that.
}
if ( nilp( character ) ) {
if ( c_nilp( character ) ) {
character = get_character( stream );
}
struct pso_pointer readmacro = c_assoc( character, readtable );
if ( !nilp( readmacro ) ) {
if ( !c_nilp( readmacro ) ) {
// invoke the read macro on the stream
} else if ( readp( stream ) && characterp( character ) ) {
char32_t c =
@ -228,12 +215,13 @@ struct pso_pointer read(
default:
struct pso_pointer next = make_frame( 3, frame_pointer, stream,
readtable,
make_character( c ) );
make_character
( frame_pointer, c ) );
inc_ref( next );
if ( iswdigit( c ) ) {
result = read_number( next, env );
result = read_number( next );
} else if ( iswalpha( c ) ) {
result = read_symbol( next, env );
result = read_symbol( next );
} else {
// result =
// throw_exception(

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

@ -13,13 +13,10 @@
#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_number( struct pso_pointer frame_pointer );
struct pso_pointer read_symbol( struct pso_pointer frame_pointer,
struct pso_pointer env );
struct pso_pointer read_symbol( struct pso_pointer frame_pointer );
struct pso_pointer read( struct pso_pointer frame_pointer,
struct pso_pointer env );
struct pso_pointer read( struct pso_pointer frame_pointer );
#endif

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

@ -44,15 +44,15 @@ struct pso_pointer destroy( struct pso_pointer p ) {
switch ( get_tag_value( p ) ) {
case CONSTV:
destroy_cons( f, nil );
destroy_cons( f );
break;
case EXCEPTIONTV:
destroy_exception( f, nil );
destroy_exception( f );
break;
case KEYTV:
case STRINGTV:
case SYMBOLTV:
destroy_string( f, nil );
destroy_string( f );
break;
case STACKTV:
// destroy_stack_frame( f, nil );

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

@ -58,9 +58,9 @@ struct pso_pointer initialise_memory( uint32_t node ) {
struct pso_pointer result = nil;
if ( memory_initialised ) {
result =
make_exception( c_string_to_lisp_string
( L"Attenpt to reinitialise memory." ), nil, nil,
nil );
make_exception( make_frame( 1, nil, c_string_to_lisp_string
( nil,
L"Attenpt to reinitialise memory." ) ) );
} else {
for ( uint8_t i = 0; i <= MAX_SIZE_CLASS; i++ ) {
freelists[i] = nil;
@ -82,18 +82,18 @@ struct pso_pointer pop_freelist( uint8_t size_class ) {
struct pso_pointer result = t;
if ( size_class <= MAX_SIZE_CLASS ) {
if ( nilp( freelists[size_class] ) ) {
if ( c_nilp( freelists[size_class] ) ) {
result = allocate_page( size_class );
}
if ( nilp( result ) ) {
if ( c_nilp( result ) ) {
fputws( L"FATAL: Page space exhausted\n", stderr );
exit( 1 ); // TODO: we don't want to do this! Somehow, we need to
// recover a workable environment, ideally by throwing a pre-made
// exception.
}
if ( !exceptionp( result ) && !nilp( result ) ) {
if ( !exceptionp( result ) && !c_nilp( result ) ) {
pthread_mutex_lock( &freelists_mutices[size_class] );
result = freelists[size_class];
struct pso2 *object = pointer_to_object( result );

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

@ -16,12 +16,15 @@
#include "memory/memory.h"
#include "memory/pointer.h"
#include "memory/pso.h"
#include "memory/tags.h"
#include "payloads/exception.h"
#include "ops/eq.h"
#include "ops/stack_ops.h"
#include "ops/string_ops.h"
#include "ops/truth.h"
#include "payloads/exception.h"
/**
* @brief Flag to prevent the node being initialised more than once.
@ -56,9 +59,9 @@ struct pso_pointer t = ( struct pso_pointer ) { 0, 0, 4 };
*/
struct pso_pointer in_debugging_mode =
#ifdef DEBUG
( struct pso_pointer ) { 0, 0, 4 };
( struct pso_pointer ) { 0, 0, 4 };
#else
( struct pso_pointer ) { 0, 0, 0 };
( struct pso_pointer ) { 0, 0, 0 };
#endif
/**
@ -77,18 +80,22 @@ struct pso_pointer initialise_node( uint32_t index ) {
node_index = index;
struct pso_pointer result = initialise_environment( index );
struct pso_pointer base_of_stack = make_frame( 0, nil );
if ( !c_nilp( result ) && !exceptionp( result ) ) {
node_initialised = true;
node_initialised = true;
if ( initialise_io( ) == 0 ) {
result = initialise_default_streams( result );
result = initialise_default_streams( base_of_stack, result );
} else {
result =
make_exception( make_frame(1, nil,
c_string_to_lisp_string( nil, L"Failed to initialise default streams" )));
make_exception( make_frame( 1, base_of_stack,
c_string_to_lisp_string
( base_of_stack,
L"Failed to initialise default streams" ) ) );
}
}
dec_ref( base_of_stack );
return result;
}

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

@ -286,7 +286,8 @@ struct pso_pointer initialise_page( union page *page_addr, uint16_t page_index,
result = nil;
}
debug_print( nilp( result ) ? L"fail.\n" : L"success.\n", DEBUG_ALLOC, 0 );
debug_print( c_nilp( result ) ? L"fail.\n" : L"success.\n", DEBUG_ALLOC,
0 );
return result;
}

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

@ -64,7 +64,7 @@ struct pso_pointer allocate( struct pso_pointer frame_pointer, char *tag,
#endif
struct pso_pointer result = pop_freelist( size_class );
struct pso4* frame = pointer_to_pso4(frame_pointer);
struct pso4 *frame = pointer_to_pso4( frame_pointer );
if ( !c_nilp( result ) ) {
strncpy( ( char * ) ( pointer_to_object( result )->header.tag.
@ -72,8 +72,8 @@ struct pso_pointer allocate( struct pso_pointer frame_pointer, char *tag,
debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ",
result.page, result.offset );
if ( stackp(frame_pointer)) {
struct pso_pointer locals = make_cons( result,
if ( stackp( frame_pointer ) ) {
struct pso_pointer locals = make_cons( frame_pointer, result,
frame->payload.
stack_frame.locals );
frame->payload.stack_frame.locals = locals;

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

@ -31,13 +31,15 @@ uint32_t get_tag_value( struct pso_pointer p ) {
*
* @param p must be a struct pso_pointer, indicating the appropriate object.
*/
struct pso_pointer get_tag_string( struct pso_pointer p ) {
struct pso_pointer get_tag_string( struct pso_pointer frame_pointer,
struct pso_pointer p ) {
struct pso_pointer result = nil;
struct pso2 *object = pointer_to_object( p );
for ( int i = 2 - 1; i >= 0; i-- ) {
result =
make_string( ( char32_t ) ( object->header.tag.bytes.mnemonic[i] ),
make_string( frame_pointer,
( char32_t ) ( object->header.tag.bytes.mnemonic[i] ),
result );
}

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

@ -87,7 +87,8 @@
// #define get_tag_value(p)((pointer_to_object(p)->header.tag.value) & 0xffffff)
uint32_t get_tag_value( struct pso_pointer p );
struct pso_pointer get_tag_string( struct pso_pointer p );
struct pso_pointer get_tag_string( struct pso_pointer frame_pointer,
struct pso_pointer p );
/**
* @brief check that the tag of the object indicated by this poiner has this

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

@ -101,13 +101,15 @@ struct pso_pointer assoc(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer) {
struct pso_pointer frame_pointer ) {
#ifdef MANAGED_POINTER_ONLY
struct pso4 *frame = pointer_to_pso4( frame_pointer );
#endif
struct pso_pointer key = fetch_arg( frame, 0 );
struct pso_pointer store = or( make_frame( 2, frame_pointer,
fetch_arg( frame, 1 ), frame->payload.stack_frame.env));
fetch_arg( frame, 1 ),
frame->payload.
stack_frame.env ) );
return c_assoc( key, store );
}
@ -121,13 +123,15 @@ struct pso_pointer interned(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer) {
struct pso_pointer frame_pointer ) {
#ifdef MANAGED_POINTER_ONLY
struct pso4 *frame = pointer_to_pso4( frame_pointer );
#endif
struct pso_pointer key = fetch_arg( frame, 0 );
struct pso_pointer store = or( make_frame( 2, frame_pointer,
fetch_arg( frame, 1 ), frame->payload.stack_frame.env));
fetch_arg( frame, 1 ),
frame->payload.
stack_frame.env ) );
return c_interned( key, store );
}
@ -141,13 +145,15 @@ struct pso_pointer internedp(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer) {
struct pso_pointer frame_pointer ) {
#ifdef MANAGED_POINTER_ONLY
struct pso4 *frame = pointer_to_pso4( frame_pointer );
#endif
struct pso_pointer key = fetch_arg( frame, 0 );
struct pso_pointer store = or( make_frame( 2, frame_pointer,
fetch_arg( frame, 1 ), frame->payload.stack_frame.env));
fetch_arg( frame, 1 ),
frame->payload.
stack_frame.env ) );
return c_internedp( key, store ) ? t : nil;
}

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

@ -22,19 +22,16 @@
#include "payloads/function.h"
#include "payloads/stack.h"
struct pso_pointer bind(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer) {
#ifdef MANAGED_POINTER_ONLY
/**
* (bind key value store)
*/
struct pso_pointer lisp_bind( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
#endif
struct pso_pointer key = fetch_arg( frame, 0 );
struct pso_pointer value = fetch_arg( frame, 1 );
struct pso_pointer store = fetch_arg( frame, 2 );
struct pso_pointer binding = cons( make_frame( 2, frame_pointer, key, value));
struct pso_pointer binding =
cons( make_frame( 2, frame_pointer, key, value ) );
return cons( make_frame( 2, frame_pointer, binding, store));
return cons( make_frame( 2, frame_pointer, binding, store ) );
}

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

@ -16,15 +16,7 @@
#include "memory/pointer.h"
#include "memory/pso4.h"
struct pso_pointer c_bind( struct pso_pointer key,
struct pso_pointer value,
struct pso_pointer store );
struct pso_pointer lisp_bind(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer,
struct pso_pointer env );
struct pso_pointer lisp_bind( struct pso_pointer frame_pointer );
#endif

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

@ -32,7 +32,7 @@ struct pso_pointer equal(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer);
struct pso_pointer frame_pointer );
#endif

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

@ -31,14 +31,7 @@
*
* * (apply fn args)
*/
struct pso_pointer apply(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer) {
#ifdef MANAGED_POINTER_ONLY
struct pso4 *frame = pointer_to_pso4( frame_pointer );
#endif
struct pso_pointer apply( struct pso_pointer frame_pointer ) {
// TODO.
@ -49,16 +42,11 @@ struct pso_pointer apply(
*
* * (eval form)
*/
struct pso_pointer eval(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer) {
#ifdef MANAGED_POINTER_ONLY
struct pso_pointer eval( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
#endif
struct pso_pointer arg = fetch_arg( frame, 0 );
struct pso_pointer result = nil;
struct pso_pointer result = nil;
switch ( get_tag_value( arg ) ) {
// case CONSTV:
@ -68,10 +56,10 @@ struct pso_pointer eval(
case KEYTV:
case STRINGTV:
// self evaluating
result = nil;
result = nil;
break;
case SYMBOLTV:
arg = c_assoc( arg, fetch_env(frame_pointer) );
arg = c_assoc( arg, fetch_env( frame_pointer ) );
break;
// case LAMBDATV:
// result = eval_lambda( frame, frame_pointer, env);
@ -84,22 +72,22 @@ struct pso_pointer eval(
// break;
default:
arg =
make_exception(
make_frame(1, frame_pointer,
make_cons( frame_pointer,
c_string_to_lisp_string( frame_pointer,
L"Can't yet evaluate things of this type: " ),
arg ),
make_cons( frame_pointer,
make_cons
( frame_pointer,
c_string_to_lisp_keyword
( frame_pointer,
L"tag" ),
get_tag_string
( arg ) ),
nil ),
nil ));
make_exception( make_frame( 1, frame_pointer,
make_cons( frame_pointer,
c_string_to_lisp_string
( frame_pointer,
L"Can't yet evaluate things of this type: " ),
arg ),
make_cons( frame_pointer,
make_cons
( frame_pointer,
c_string_to_lisp_keyword
( frame_pointer,
L"tag" ),
get_tag_string
( frame_pointer,
arg ) ), nil ),
nil ) );
}
if ( exceptionp( arg ) ) {
@ -108,7 +96,7 @@ struct pso_pointer eval(
EXCEPTIONTV );
if ( c_nilp( x->payload.exception.stack ) ) {
}
}

14
src/c/ops/eval_apply.h
View file

@ -17,20 +17,10 @@
#include "memory/pso4.h"
#include "payloads/function.h"
struct pso_pointer apply(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer,
struct pso_pointer env );
struct pso_pointer apply( struct pso_pointer frame_pointer );
struct pso_pointer eval(
#ifndef MANAGED_POINTER_ONLY
struct pso4 *frame,
#endif
struct pso_pointer frame_pointer,
struct pso_pointer env );
struct pso_pointer eval( struct pso_pointer frame_pointer );
#endif

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

@ -17,16 +17,16 @@
#include "ops/truth.h"
struct pso_pointer length( struct pso_pointer frame_pointer) {
struct pso4* frame = pointer_to_pso4(frame_pointer);
struct pso_pointer list = fetch_arg( frame, 0);
int count = 0;
struct pso_pointer length( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
for ( struct pso_pointer cursor = list; !c_nilp( cursor);
cursor = cdr( make_frame( 1, frame_pointer, list))) {
count++;
}
struct pso_pointer list = fetch_arg( frame, 0 );
int count = 0;
return make_integer( frame_pointer, count);
for ( struct pso_pointer cursor = list; !c_nilp( cursor );
cursor = cdr( make_frame( 1, frame_pointer, list ) ) ) {
count++;
}
return make_integer( frame_pointer, count );
}

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

@ -17,6 +17,6 @@
#include "payloads/function.h"
struct pso_pointer length( struct pso_pointer frame_pointer);
struct pso_pointer length( struct pso_pointer frame_pointer );
#endif

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

@ -33,6 +33,7 @@
#include "ops/assoc.h"
#include "ops/eval_apply.h"
#include "ops/stack_ops.h"
#include "ops/truth.h"
/**
@ -47,14 +48,14 @@ void int_handler( int dummy ) {
/**
* Very simple read/eval/print loop for bootstrapping.
*/
void c_repl( bool show_prompt ) {
void repl( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
bool show_prompt = c_truep( fetch_arg( frame, 0 ) );
// todo: issue #21: must have stack frame passed in.
signal( SIGINT, int_handler );
debug_print( L"Entered repl\n", DEBUG_REPL, 0 );
// TODO: NULL is not OK here, but will do until we have a REPL in Lisp.
struct pso_pointer env =
consp( oblist ) ? oblist : make_cons( nil, oblist, nil );
struct pso_pointer env = fetch_env( frame_pointer );
struct pso_pointer input_stream = c_assoc( lisp_io_in, env );
struct pso_pointer output_stream = c_assoc( lisp_io_out, env );
@ -72,32 +73,28 @@ void c_repl( bool show_prompt ) {
while ( readp( input_stream ) &&
!url_feof( stream_get_url_file( input_stream ) ) ) {
if ( show_prompt )
c_princ( c_assoc( lisp_io_prompt, env ), output_stream );
princ( make_frame( 2, frame_pointer,
c_assoc( lisp_io_prompt, env ),
output_stream ) );
/* bottom of stack */
struct pso_pointer frame_pointer = make_frame( 1, nil, input_stream );
/* the reason for initialising a new stack for each REPL input is to
* be sure the old stack is fully torn down and reclaimed. Once I'm
* confident of that, TODO: do not start a new stack base each time!
*/
struct pso_pointer base_of_stack =
inc_ref( make_frame_with_env( 0, nil,
consp( oblist ) ? oblist :
make_cons( nil, oblist, nil ) ) );
if ( c_nilp( frame_pointer ) )
break;
struct pso_pointer input = read(
#ifndef MANAGED_POINTER_ONLY
pointer_to_pso4( frame_pointer ),
#endif
frame_pointer, env );
print( make_frame
( 2, base_of_stack,
eval( make_frame
( 1, base_of_stack,
read( make_frame
( 1, base_of_stack, input_stream ) ) ) ),
output_stream ) );
frame_pointer = make_frame( 1, frame_pointer, input );
if ( c_nilp( frame_pointer ) )
break;
struct pso_pointer result = eval(
#ifndef MANAGED_POINTER_ONLY
pointer_to_pso4( frame_pointer ),
#endif
frame_pointer, oblist );
c_print( result, output_stream );
dec_ref( frame_pointer );
dec_ref( base_of_stack );
}
debug_print( L"Leaving repl\n", DEBUG_REPL, 0 );

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

@ -13,8 +13,7 @@
#define SRC_C_OPS_REPL_H_
// todo: issue #21: must have stack frame passed in.
void c_repl( );
void repl( struct pso_pointer frame_pointer );
#endif /* SRC_C_OPS_REPL_H_ */

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

@ -35,7 +35,8 @@
* @return a sequence like the `sequence` passed, but reversed; or `nil` if
* the argument was not a sequence.
*/
struct pso_pointer c_reverse( struct pso_pointer frame_pointer, struct pso_pointer sequence ) {
struct pso_pointer c_reverse( struct pso_pointer frame_pointer,
struct pso_pointer sequence ) {
// todo: issue #21: must have stack frame passed in.
struct pso_pointer result = nil;
@ -49,27 +50,31 @@ struct pso_pointer c_reverse( struct pso_pointer frame_pointer, struct pso_point
case KEYTV:
// TODO: should you be able to reverse keywords and symbols?
result =
make_string_like_thing( frame_pointer, object->payload.string.character,
make_string_like_thing( frame_pointer,
object->payload.string.character,
result, KEYTAG );
break;
case STRINGTV:
result =
make_string_like_thing( frame_pointer, object->payload.string.character,
make_string_like_thing( frame_pointer,
object->payload.string.character,
result, STRINGTAG );
break;
case SYMBOLTV:
// TODO: should you be able to reverse keywords and symbols?
result =
make_string_like_thing( frame_pointer, object->payload.string.character,
make_string_like_thing( frame_pointer,
object->payload.string.character,
result, SYMBOLTAG );
break;
default:
result =
make_exception( make_frame( 1, frame_pointer,
make_cons( frame_pointer,
c_string_to_lisp_string
( frame_pointer, L"Invalid object in sequence" ),
cursor ) ));
make_exception( make_frame( 1, frame_pointer,
make_cons( frame_pointer,
c_string_to_lisp_string
( frame_pointer,
L"Invalid object in sequence" ),
cursor ) ) );
goto exit;
break;
}

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

@ -50,8 +50,7 @@ struct pso_pointer fetch_arg( struct pso4 *frame, unsigned int index ) {
*
* @param frame_pointer a pointer to a stack frame.
*/
struct pso_pointer fetch_env( struct pso_pointer frame_pointer) {
return stackp(frame_pointer) ?
pointer_to_pso4(frame_pointer)->payload.stack_frame.env :
nil;
struct pso_pointer fetch_env( struct pso_pointer frame_pointer ) {
return stackp( frame_pointer ) ?
pointer_to_pso4( frame_pointer )->payload.stack_frame.env : nil;
}

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

@ -27,6 +27,6 @@ extern uint32_t stack_limit;
struct pso_pointer fetch_arg( struct pso4 *frame, unsigned int index );
struct pso_pointer fetch_env( struct pso_pointer frame_pointer);
struct pso_pointer fetch_env( struct pso_pointer frame_pointer );
#endif

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

@ -27,7 +27,7 @@
* @return true if `p` points to `nil`.
* @return false otherwise.
*/
bool c_nilp(struct pso_pointer p) {
bool c_nilp( struct pso_pointer p ) {
return ( p.page == 0 && p.offset == 0 );
}
@ -80,7 +80,7 @@ struct pso_pointer truep( struct pso_pointer frame_pointer ) {
* @param frame_pointer A pointer to the current stack frame;
* @return `t` if the first argument in this frame is not `nil`, else `t`.
*/
struct pso_pointer not( struct pso_pointer frame_pointer) {
struct pso_pointer not( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
return ( !c_nilp( fetch_arg( frame, 0 ) ) ? t : nil );
@ -91,18 +91,19 @@ struct pso_pointer not( struct pso_pointer frame_pointer) {
*
* @return `nil` if any `arg` is `nil`, else `t`.
*/
struct pso_pointer and( struct pso_pointer frame_pointer) {
struct pso4* frame = pointer_to_pso4( frame_pointer);
struct pso_pointer result = t;
for (int arg = 0; c_truep(result) && arg < frame->payload.stack_frame.args; arg++) {
if (c_nilp(fetch_arg(frame, arg))) {
result = nil;
break;
}
}
return result;
struct pso_pointer and( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer result = t;
for ( int arg = 0;
c_truep( result ) && arg < frame->payload.stack_frame.args; arg++ ) {
if ( c_nilp( fetch_arg( frame, arg ) ) ) {
result = nil;
break;
}
}
return result;
}
@ -111,16 +112,17 @@ struct pso_pointer and( struct pso_pointer frame_pointer) {
*
* @return `t` if any `arg` is non-nil, else `nil`.
*/
struct pso_pointer or( struct pso_pointer frame_pointer) {
struct pso4* frame = pointer_to_pso4( frame_pointer);
struct pso_pointer result = nil;
for (int arg = 0; c_truep(result) && arg < frame->payload.stack_frame.args; arg++) {
if (!c_nilp(fetch_arg(frame, arg))) {
result = t;
break;
}
}
return result;
struct pso_pointer or( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer result = nil;
for ( int arg = 0;
c_truep( result ) && arg < frame->payload.stack_frame.args; arg++ ) {
if ( !c_nilp( fetch_arg( frame, arg ) ) ) {
result = t;
break;
}
}
return result;
}

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

@ -25,7 +25,7 @@ struct pso_pointer and( struct pso_pointer frame_pointer );
struct pso_pointer or( struct pso_pointer frame_pointer );
bool c_nilp(struct pso_pointer p);
bool c_truep(struct pso_pointer p);
bool c_nilp( struct pso_pointer p );
bool c_truep( struct pso_pointer p );
#endif

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

@ -38,5 +38,6 @@ struct character_payload {
char32_t character;
};
struct pso_pointer make_character( struct pso_pointer frame_pointer, wint_t c );
struct pso_pointer make_character( struct pso_pointer frame_pointer,
wint_t c );
#endif

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

@ -31,19 +31,21 @@
* @param frame_pointer a pointer to a stack frame.
* @return struct pso_pointer a pointer to the newly allocated cons cell.
*/
struct pso_pointer cons(struct pso_pointer frame_pointer) {
struct pso4 *frame = pointer_to_pso4(frame_pointer);
struct pso_pointer result = allocate(frame_pointer, CONSTAG, 2);
struct pso_pointer cons( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer result = allocate( frame_pointer, CONSTAG, 2 );
struct pso2 *object = pointer_to_object(result);
object->payload.cons.car = inc_ref(fetch_arg(frame, 0));
object->payload.cons.cdr = inc_ref(fetch_arg(frame, 1));
struct pso2 *object = pointer_to_object( result );
object->payload.cons.car = inc_ref( fetch_arg( frame, 0 ) );
object->payload.cons.cdr = inc_ref( fetch_arg( frame, 1 ) );
return result;
return result;
}
struct pso_pointer make_cons(struct pso_pointer frame_pointer, struct pso_pointer car, struct pso_pointer cdr){
return cons( make_frame(2, frame_pointer, car, cdr));
struct pso_pointer make_cons( struct pso_pointer frame_pointer,
struct pso_pointer car,
struct pso_pointer cdr ) {
return cons( make_frame( 2, frame_pointer, car, cdr ) );
}
/**
@ -55,26 +57,32 @@ struct pso_pointer make_cons(struct pso_pointer frame_pointer, struct pso_pointe
* @return the car of the indicated cell.
* @exception if the pointer does not indicate a cons cell.
*/
struct pso_pointer car(struct pso_pointer frame_pointer) {
struct pso_pointer result = nil;
struct pso4 *frame = pointer_to_pso4(frame_pointer);
struct pso_pointer cons = fetch_arg(frame, 0);
struct pso2 *object = pointer_to_object(cons);
struct pso_pointer car( struct pso_pointer frame_pointer ) {
struct pso_pointer result = nil;
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer cons = fetch_arg( frame, 0 );
struct pso2 *object = pointer_to_object( cons );
if (consp(cons)) {
result = object->payload.cons.car;
} else {
result = make_exception(make_frame(
2, frame_pointer,
c_string_to_lisp_string(frame_pointer, L"Invalid type for car"),
make_cons(frame_pointer, make_cons(
frame_pointer,
c_string_to_lisp_keyword(frame_pointer, L"type"),
get_tag_string(cons)),
nil)));
}
if ( consp( cons ) ) {
result = object->payload.cons.car;
} else {
result = make_exception( make_frame( 2, frame_pointer,
c_string_to_lisp_string
( frame_pointer,
L"Invalid type for car" ),
make_cons( frame_pointer,
make_cons
( frame_pointer,
c_string_to_lisp_keyword
( frame_pointer,
L"type" ),
get_tag_string
( frame_pointer,
cons ) ),
nil ) ) );
}
return result;
return result;
}
/**
@ -86,36 +94,40 @@ struct pso_pointer car(struct pso_pointer frame_pointer) {
* @return the cdr of the indicated cell.
* @exception if the pointer does not indicate a cons cell.
*/
struct pso_pointer cdr(struct pso_pointer frame_pointer) {
struct pso_pointer result = nil;
struct pso4 *frame = pointer_to_pso4(frame_pointer);
struct pso_pointer cons = fetch_arg(frame, 0);
struct pso2 *object = pointer_to_object(cons);
struct pso_pointer cdr( struct pso_pointer frame_pointer ) {
struct pso_pointer result = nil;
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer cons = fetch_arg( frame, 0 );
struct pso2 *object = pointer_to_object( cons );
switch (get_tag_value(cons)) {
case CONSTV:
result = object->payload.cons.cdr;
break;
case KEYTV:
case STRINGTV:
case SYMBOLTV:
result = object->payload.string.cdr;
break;
default:
struct pso_pointer type_binding =
make_cons(frame_pointer,
c_string_to_lisp_keyword(frame_pointer, L"type"),
get_tag_string(cons));
result = make_exception(make_frame(
2, frame_pointer,
c_string_to_lisp_string(frame_pointer, L"Invalid type for cdr"),
make_cons(frame_pointer,
type_binding,
nil)));
break;
}
switch ( get_tag_value( cons ) ) {
case CONSTV:
result = object->payload.cons.cdr;
break;
case KEYTV:
case STRINGTV:
case SYMBOLTV:
result = object->payload.string.cdr;
break;
default:
result = make_exception( make_frame( 2, frame_pointer,
c_string_to_lisp_string
( frame_pointer,
L"Invalid type for cdr" ),
make_cons( frame_pointer,
make_cons
( frame_pointer,
c_string_to_lisp_keyword
( frame_pointer,
L"type" ),
get_tag_string
( frame_pointer,
cons ) ),
nil ) ) );
break;
}
return result;
return result;
}
/**
@ -125,15 +137,15 @@ struct pso_pointer cdr(struct pso_pointer frame_pointer) {
* Lisp calling conventions; one expected arg, the pointer to the cell to
* be destroyed.
*/
struct pso_pointer destroy_cons(struct pso_pointer fp) {
if (stackp(fp)) {
struct pso4 *frame = pointer_to_pso4(fp);
struct pso_pointer p = frame->payload.stack_frame.arg[0];
struct pso_pointer destroy_cons( struct pso_pointer fp ) {
if ( stackp( fp ) ) {
struct pso4 *frame = pointer_to_pso4( fp );
struct pso_pointer p = frame->payload.stack_frame.arg[0];
if (check_tag(p, CONSTV)) {
struct pso2 *cons = pointer_to_object(p);
dec_ref(cons->payload.cons.car);
dec_ref(cons->payload.cons.cdr);
}
}
if ( check_tag( p, CONSTV ) ) {
struct pso2 *cons = pointer_to_object( p );
dec_ref( cons->payload.cons.car );
dec_ref( cons->payload.cons.cdr );
}
}
}

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

@ -33,11 +33,10 @@ struct pso_pointer cdr( struct pso_pointer frame_pointer );
struct pso_pointer cons( struct pso_pointer frame_pointer );
struct pso_pointer destroy_cons( struct pso_pointer frame_pointer);
struct pso_pointer destroy_cons( struct pso_pointer frame_pointer );
struct pso_pointer make_cons(struct pso_pointer frame_pointer,
struct pso_pointer car,
struct pso_pointer cdr);
struct pso_pointer make_cons( struct pso_pointer frame_pointer,
struct pso_pointer car, struct pso_pointer cdr );
/**
* macro short-cuts for make_cons.

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

@ -47,21 +47,21 @@ b * @param meta metadata for this exception. Must be an assoc list, hashtable,
* or `nil`
* @param cause the exception that caused this exception to be `thrown`.
*/
struct pso_pointer make_exception( struct pso_pointer frame_pointer) {
struct pso4* frame = pointer_to_pso4( frame_pointer);
struct pso_pointer message = fetch_arg(frame, 0);
struct pso_pointer previous = frame->payload.stack_frame.previous;
struct pso_pointer meta = fetch_arg( frame, 1);
struct pso_pointer cause = fetch_arg( frame, 2);
struct pso_pointer make_exception( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer message = fetch_arg( frame, 0 );
struct pso_pointer previous = frame->payload.stack_frame.previous;
struct pso_pointer meta = fetch_arg( frame, 1 );
struct pso_pointer cause = fetch_arg( frame, 2 );
struct pso_pointer result =
allocate( frame_pointer, EXCEPTIONTAG, 3 );
struct pso_pointer result = allocate( frame_pointer, EXCEPTIONTAG, 3 );
if ( !c_nilp( result ) && !exceptionp( result ) ) {
struct pso3 *object = ( struct pso3 * ) pointer_to_object( result );
object->payload.exception.message = message;
object->payload.exception.stack = stackp( frame_pointer ) ? frame_pointer : nil;
object->payload.exception.stack =
stackp( frame_pointer ) ? frame_pointer : nil;
object->payload.exception.meta = ( consp( meta )
|| hashtabp( meta ) ) ? meta : nil;
object->payload.exception.cause = exceptionp( cause ) ? cause : nil;
@ -76,8 +76,7 @@ struct pso_pointer make_exception( struct pso_pointer frame_pointer) {
* Lisp calling conventions; one expected arg, the pointer to the object to
* be destroyed.
*/
struct pso_pointer destroy_exception( struct pso_pointer fp,
struct pso_pointer env ) {
struct pso_pointer destroy_exception( struct pso_pointer fp ) {
if ( stackp( fp ) ) {
struct pso4 *frame = pointer_to_pso4( fp );
struct pso_pointer p = frame->payload.stack_frame.arg[0];

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

@ -28,7 +28,6 @@ struct exception_payload {
struct pso_pointer make_exception( struct pso_pointer frame_pointer );
struct pso_pointer destroy_exception( struct pso_pointer fp,
struct pso_pointer env );
struct pso_pointer destroy_exception( struct pso_pointer fp );
#endif

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

@ -25,7 +25,8 @@
* @param more `nil`, or a pointer to the more significant cell(s) of this number.
* *NOTE* that if `more` is not `nil`, `value` *must not* exceed `MAX_INTEGER`.
*/
struct pso_pointer make_integer( struct pso_pointer frame_pointer, int64_t value ) {
struct pso_pointer make_integer( struct pso_pointer frame_pointer,
int64_t value ) {
struct pso_pointer result = nil;
debug_print( L"Entering make_integer\n", DEBUG_ALLOC, 0 );

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

@ -25,6 +25,7 @@ struct integer_payload {
__int128_t value;
};
struct pso_pointer make_integer( struct pso_pointer frame_pointer, int64_t value );
struct pso_pointer make_integer( struct pso_pointer frame_pointer,
int64_t value );
#endif

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

@ -22,6 +22,8 @@
#include "payloads/cons.h"
#include "ops/stack_ops.h"
/**
* @brief When an string is freed, its cdr pointer must be decremented.
@ -29,14 +31,10 @@
* Lisp calling conventions; one expected arg, the pointer to the object to
* be destroyed.
*/
struct pso_pointer destroy_string( 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];
dec_ref( c_cdr( p ) );
}
struct pso_pointer destroy_string( struct pso_pointer frame_pointer ) {
if ( stackp( frame_pointer ) ) {
dec_ref( c_cdr( fetch_arg( pointer_to_pso4( frame_pointer ), 0 ) ) );
}
return nil;
}

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

@ -33,7 +33,6 @@ struct string_payload {
struct pso_pointer cdr;
};
struct pso_pointer destroy_string( struct pso_pointer fp,
struct pso_pointer env );
struct pso_pointer destroy_string( struct pso_pointer fp );
#endif

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

@ -43,9 +43,8 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous,
va_start( args, previous );
struct pso4 *prev_frame = pointer_to_pso4( previous );
struct pso_pointer new_pointer =
allocate( previous, STACKTAG, 4 );
struct pso4* new_frame = pointer_to_pso4(new_pointer);
struct pso_pointer new_pointer = allocate( previous, STACKTAG, 4 );
struct pso4 *new_frame = pointer_to_pso4( new_pointer );
#ifdef DEBUG
debug_printf( DEBUG_ALLOC, 0,
@ -57,14 +56,16 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous,
prev_frame->payload.stack_frame.previous = previous;
if ( stackp( previous ) ) {
new_frame->payload.stack_frame.depth = prev_frame->payload.stack_frame.depth + 1;
new_frame->payload.stack_frame.env = prev_frame->payload.stack_frame.env;
new_frame->payload.stack_frame.depth =
prev_frame->payload.stack_frame.depth + 1;
new_frame->payload.stack_frame.env =
prev_frame->payload.stack_frame.env;
} else {
new_frame->payload.stack_frame.depth = 0;
new_frame->payload.stack_frame.depth = 0;
}
debug_printf( DEBUG_ALLOC, 1, L"depth is %d...\n",
new_frame->payload.stack_frame.depth );
new_frame->payload.stack_frame.depth );
int cursor = 0;
new_frame->payload.stack_frame.args = arg_count;
@ -86,7 +87,7 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous,
new_frame->payload.stack_frame.more = c_reverse( more_args );
} else {
for ( ; cursor < args_in_frame; cursor++ ) {
new_frame->payload.stack_frame.arg[cursor] = nil;
new_frame->payload.stack_frame.arg[cursor] = nil;
}
}
@ -117,9 +118,8 @@ struct pso_pointer make_frame_with_env( int arg_count,
va_start( args, env );
struct pso4 *prev_frame = pointer_to_pso4( previous );
struct pso_pointer new_pointer =
allocate( previous, STACKTAG, 4 );
struct pso4* new_frame = pointer_to_pso4(new_pointer);
struct pso_pointer new_pointer = allocate( previous, STACKTAG, 4 );
struct pso4 *new_frame = pointer_to_pso4( new_pointer );
#ifdef DEBUG
debug_printf( DEBUG_ALLOC, 0,
@ -131,14 +131,15 @@ struct pso_pointer make_frame_with_env( int arg_count,
prev_frame->payload.stack_frame.previous = previous;
if ( stackp( previous ) ) {
new_frame->payload.stack_frame.depth = prev_frame->payload.stack_frame.depth + 1;
new_frame->payload.stack_frame.depth =
prev_frame->payload.stack_frame.depth + 1;
new_frame->payload.stack_frame.env = env;
} else {
new_frame->payload.stack_frame.depth = 0;
new_frame->payload.stack_frame.depth = 0;
}
debug_printf( DEBUG_ALLOC, 1, L"depth is %d...\n",
new_frame->payload.stack_frame.depth );
new_frame->payload.stack_frame.depth );
int cursor = 0;
new_frame->payload.stack_frame.args = arg_count;
@ -160,7 +161,7 @@ struct pso_pointer make_frame_with_env( int arg_count,
new_frame->payload.stack_frame.more = c_reverse( more_args );
} else {
for ( ; cursor < args_in_frame; cursor++ ) {
new_frame->payload.stack_frame.arg[cursor] = nil;
new_frame->payload.stack_frame.arg[cursor] = nil;
}
}
@ -181,14 +182,19 @@ struct pso_pointer make_frame_with_env( int arg_count,
*
* @return pointer to the new frame.
*/
struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer previous, struct pso_pointer argvalues,
struct pso_pointer env) {
struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer
previous,
struct pso_pointer
argvalues,
struct pso_pointer env ) {
struct pso4 *prev_frame = pointer_to_pso4( previous );
struct pso_pointer new_pointer =
allocate( previous, STACKTAG, 4 );
struct pso4* new_frame = pointer_to_pso4(new_pointer);
struct pso_pointer arg_length = length(make_frame(1, previous, argvalues));
int arg_count = integerp(arg_length) ? pointer_to_object(arg_length)->payload.integer.value : 0;
struct pso_pointer new_pointer = allocate( previous, STACKTAG, 4 );
struct pso4 *new_frame = pointer_to_pso4( new_pointer );
struct pso_pointer arg_length =
length( make_frame( 1, previous, argvalues ) );
int arg_count =
integerp( arg_length ) ? pointer_to_object( arg_length )->
payload.integer.value : 0;
#ifdef DEBUG
debug_printf( DEBUG_ALLOC, 0,
L"\nAllocating stack frame with %d arguments at page %d, "
@ -199,28 +205,31 @@ struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer previous,
prev_frame->payload.stack_frame.previous = previous;
if ( stackp( previous ) ) {
new_frame->payload.stack_frame.depth = prev_frame->payload.stack_frame.depth + 1;
new_frame->payload.stack_frame.env = inc_ref( prev_frame->payload.stack_frame.env);
new_frame->payload.stack_frame.depth =
prev_frame->payload.stack_frame.depth + 1;
new_frame->payload.stack_frame.env =
inc_ref( prev_frame->payload.stack_frame.env );
} else {
new_frame->payload.stack_frame.depth = 0;
new_frame->payload.stack_frame.depth = 0;
}
debug_printf( DEBUG_ALLOC, 1, L"depth is %d...\n",
new_frame->payload.stack_frame.depth );
new_frame->payload.stack_frame.depth );
int cursor = 0;
new_frame->payload.stack_frame.args = arg_count;
for ( ; cursor < arg_count && cursor < args_in_frame; cursor++ ) {
new_frame->payload.stack_frame.arg[cursor] = inc_ref( make_frame( 1, previous, car(argvalues)));
argvalues = cdr( make_frame( 1, previous, argvalues));
new_frame->payload.stack_frame.arg[cursor] =
inc_ref( make_frame( 1, previous, car( argvalues ) ) );
argvalues = cdr( make_frame( 1, previous, argvalues ) );
}
if ( cursor < arg_count ) {
new_frame->payload.stack_frame.more = inc_ref( argvalues);
new_frame->payload.stack_frame.more = inc_ref( argvalues );
} else {
for ( ; cursor < args_in_frame; cursor++ ) {
new_frame->payload.stack_frame.arg[cursor] = nil;
new_frame->payload.stack_frame.arg[cursor] = nil;
}
}
@ -239,8 +248,12 @@ struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer previous,
*
* @return pointer to the new frame.
*/
struct pso_pointer make_frame_with_arglist( struct pso_pointer previous, struct pso_pointer argvalues) {
return make_frame_with_arglist_and_env( previous, argvalues, pointer_to_pso4(previous)->payload.stack_frame.env);
struct pso_pointer make_frame_with_arglist( struct pso_pointer previous,
struct pso_pointer argvalues ) {
return make_frame_with_arglist_and_env( previous, argvalues,
pointer_to_pso4
( previous )->payload.stack_frame.
env );
}

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

@ -43,17 +43,19 @@ struct stack_frame_payload {
struct pso_pointer make_frame( int arg_count, struct pso_pointer previous,
... );
struct pso_pointer make_frame_with_env( int arg_count,
struct pso_pointer previous,
struct pso_pointer env, ... );
struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer previous,
struct pso_pointer argvalues,
struct pso_pointer env);
struct pso_pointer make_frame_with_arglist( struct pso_pointer previous,
struct pso_pointer argvalues);
struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer
previous,
struct pso_pointer
argvalues,
struct pso_pointer env );
struct pso_pointer make_frame_with_arglist( struct pso_pointer previous,
struct pso_pointer argvalues );
struct pso_pointer destroy_stack_frame( struct pso_pointer fp,
struct pso_pointer env );

20
src/c/psse.c
View file

@ -1,4 +1,3 @@
/**
* psse.c
*
@ -120,7 +119,7 @@ int main( int argc, char *argv[] ) {
debug_print_object( oblist, DEBUG_BOOTSTRAP, 0 );
debug_println( DEBUG_BOOTSTRAP );
if ( nilp( oblist ) ) {
if ( c_nilp( oblist ) ) {
fputs( "Failed to initialise node\n", stderr );
exit( 1 );
}
@ -134,7 +133,22 @@ int main( int argc, char *argv[] ) {
stdout );
}
c_repl( show_prompt );
struct pso_pointer bootstrap_stack = inc_ref( make_frame_with_env( 1, nil,
consp
( oblist )
? oblist
:
make_cons
( nil,
oblist,
nil ),
show_prompt
? t :
nil ) );
repl( bootstrap_stack );
dec_ref( bootstrap_stack );
exit( 0 );
}