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

Compiles, most tests break

Browse source
This commit is contained in:
Simon Brooke 2019-01-27 17:22:13 +00:00
parent b8f241c2c5
commit 0e11adea1c
22 changed files with 902 additions and 714 deletions
Download patch file Download diff file Expand all files Collapse all files

4
src/ops/equal.c
View file

@ -80,8 +80,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
&& ( equal( cell_a->payload.string.cdr,
cell_b->payload.string.cdr )
|| ( end_of_string( cell_a->payload.string.cdr )
&& end_of_string( cell_b->payload.string.
cdr ) ) );
&& end_of_string( cell_b->payload.
string.cdr ) ) );
break;
case INTEGERTV:
result =

8
src/ops/intern.c
View file

@ -110,8 +110,8 @@ struct cons_pointer c_assoc( struct cons_pointer key,
* with this key/value pair added to the front.
*/
struct cons_pointer
bind( struct cons_pointer key, struct cons_pointer value,
struct cons_pointer store ) {
set( struct cons_pointer key, struct cons_pointer value,
struct cons_pointer store ) {
debug_print( L"Binding ", DEBUG_BIND );
debug_print_object( key, DEBUG_BIND );
debug_print( L" to ", DEBUG_BIND );
@ -131,7 +131,7 @@ deep_bind( struct cons_pointer key, struct cons_pointer value ) {
debug_print( L"Entering deep_bind\n", DEBUG_BIND );
struct cons_pointer old = oblist;
oblist = bind( key, value, oblist );
oblist = set( key, value, oblist );
inc_ref( oblist );
dec_ref( old );
@ -153,7 +153,7 @@ intern( struct cons_pointer key, struct cons_pointer environment ) {
/*
* not currently bound
*/
result = bind( key, NIL, environment );
result = set( key, NIL, environment );
}
return result;

6
src/ops/intern.h
View file

@ -28,9 +28,9 @@ struct cons_pointer c_assoc( struct cons_pointer key,
struct cons_pointer internedp( struct cons_pointer key,
struct cons_pointer environment );
struct cons_pointer bind( struct cons_pointer key,
struct cons_pointer value,
struct cons_pointer store );
struct cons_pointer set( struct cons_pointer key,
struct cons_pointer value,
struct cons_pointer store );
struct cons_pointer deep_bind( struct cons_pointer key,
struct cons_pointer value );

8
src/ops/io.c
View file

@ -1,8 +0,0 @@
/*
* io.c
*
* Communication between PSSE and the outside world, via libcurl.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/

56
src/ops/lispops.c
View file

@ -29,6 +29,7 @@
#include "debug.h"
#include "dump.h"
#include "equal.h"
#include "fopen.h"
#include "integer.h"
#include "intern.h"
#include "lispops.h"
@ -231,7 +232,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
struct cons_pointer name = c_car( names );
struct cons_pointer val = frame->arg[i];
new_env = bind( name, val, new_env );
new_env = set( name, val, new_env );
log_binding( name, val );
names = c_cdr( names );
@ -256,7 +257,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
}
}
new_env = bind( names, vals, new_env );
new_env = set( names, vals, new_env );
inc_ref( new_env );
}
@ -377,10 +378,9 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
result = next_pointer;
} else {
result =
( *fn_cell.payload.
special.executable ) ( get_stack_frame
( next_pointer ),
next_pointer, env );
( *fn_cell.payload.special.
executable ) ( get_stack_frame( next_pointer ),
next_pointer, env );
debug_print( L"Special form returning: ", DEBUG_EVAL );
debug_print_object( result, DEBUG_EVAL );
debug_println( DEBUG_EVAL );
@ -627,10 +627,10 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer,
* @return true if `arg` represents an end of string, else false.
* \todo candidate for moving to a memory/string.c file
*/
bool end_of_stringp(struct cons_pointer arg) {
return nilp(arg) ||
( stringp( arg ) &&
pointer2cell(arg).payload.string.character == (wint_t)'\0');
bool end_of_stringp( struct cons_pointer arg ) {
return nilp( arg ) ||
( stringp( arg ) &&
pointer2cell( arg ).payload.string.character == ( wint_t ) '\0' );
}
/**
@ -656,8 +656,8 @@ lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer,
if ( nilp( car ) && nilp( cdr ) ) {
return NIL;
} else if ( stringp( car ) && stringp( cdr ) &&
end_of_stringp( c_cdr( car)) ) {
// \todo check that car is of length 1
end_of_stringp( c_cdr( car ) ) ) {
// \todo check that car is of length 1
result =
make_string( pointer2cell( car ).payload.string.character, cdr );
} else {
@ -691,7 +691,8 @@ lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer,
result = cell.payload.cons.car;
break;
case READTV:
result = make_string( fgetwc( cell.payload.stream.stream ), NIL );
result =
make_string( url_fgetwc( cell.payload.stream.stream ), NIL );
break;
case NILTV:
break;
@ -734,7 +735,7 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer,
result = cell.payload.cons.cdr;
break;
case READTV:
fgetwc( cell.payload.stream.stream );
url_fgetwc( cell.payload.stream.stream );
result = frame->arg[0];
break;
case STRINGTV:
@ -839,7 +840,8 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer,
#ifdef DEBUG
debug_print( L"entering lisp_read\n", DEBUG_IO );
#endif
URL_FILE *input = stdin;
URL_FILE *input;
struct cons_pointer in_stream = readp( frame->arg[0] ) ?
frame->arg[0] : get_default_stream( true, env );
@ -848,6 +850,8 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer,
debug_dump_object( in_stream, DEBUG_IO );
input = pointer2cell( in_stream ).payload.stream.stream;
inc_ref( in_stream );
} else {
input = file_to_url_file( stdin );
}
struct cons_pointer result = read( frame, frame_pointer, input );
@ -856,8 +860,11 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer,
if ( readp( in_stream ) ) {
dec_ref( in_stream );
} else {
free( input );
}
return result;
}
@ -922,7 +929,7 @@ lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
debug_print( L"Entering print\n", DEBUG_IO );
struct cons_pointer result = NIL;
URL_FILE *output = stdout;
URL_FILE *output;
struct cons_pointer out_stream = writep( frame->arg[1] ) ?
frame->arg[1] : get_default_stream( false, env );
@ -931,6 +938,8 @@ lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer,
debug_dump_object( out_stream, DEBUG_IO );
output = pointer2cell( out_stream ).payload.stream.stream;
inc_ref( out_stream );
} else {
output = file_to_url_file( stderr );
}
debug_print( L"lisp_print: about to print\n", DEBUG_IO );
@ -943,6 +952,8 @@ lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer,
if ( writep( out_stream ) ) {
dec_ref( out_stream );
} else {
free( output );
}
return result;
@ -1035,7 +1046,7 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer,
* @return the value of the last expression of the first successful `clause`.
*/
struct cons_pointer
lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer,
lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer result = NIL;
bool done = false;
@ -1165,7 +1176,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
* print as parent.
*/
while ( readp( input ) && writep( output )
&& !feof( pointer2cell( input ).payload.stream.stream ) ) {
&& !url_feof( pointer2cell( input ).payload.stream.stream ) ) {
/* OK, here's a really subtle problem: because lists are immutable, anything
* bound in the oblist subsequent to this function being invoked isn't in the
* environment. So, for example, changes to *prompt* or *log* made in the oblist
@ -1203,7 +1214,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
inc_ref( expr );
if ( exceptionp( expr )
&& feof( pointer2cell( input ).payload.stream.stream ) ) {
&& url_feof( pointer2cell( input ).payload.stream.stream ) ) {
/* suppress printing end of stream exception */
break;
}
@ -1282,7 +1293,7 @@ struct cons_pointer lisp_inspect( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
debug_print( L"Entering print\n", DEBUG_IO );
URL_FILE *output = stdout;
URL_FILE *output;
struct cons_pointer out_stream = writep( frame->arg[1] ) ?
frame->arg[1] : get_default_stream( false, env );
@ -1291,11 +1302,16 @@ struct cons_pointer lisp_inspect( struct stack_frame *frame,
debug_dump_object( out_stream, DEBUG_IO );
output = pointer2cell( out_stream ).payload.stream.stream;
inc_ref( out_stream );
} else {
output = file_to_url_file( stdout );
}
dump_object( output, frame->arg[0] );
if ( writep( out_stream ) ) {
dec_ref( out_stream );
} else {
free( output );
}
return frame->arg[0];

50
src/ops/print.c
View file

@ -40,7 +40,7 @@ void print_string_contents( URL_FILE * output, struct cons_pointer pointer ) {
wchar_t c = cell->payload.string.character;
if ( c != '\0' ) {
fputwc( c, output );
url_fputwc( c, output );
}
pointer = cell->payload.string.cdr;
}
@ -52,9 +52,9 @@ void print_string_contents( URL_FILE * output, struct cons_pointer pointer ) {
* characters.
*/
void print_string( URL_FILE * output, struct cons_pointer pointer ) {
fputwc( btowc( '"' ), output );
url_fputwc( btowc( '"' ), output );
print_string_contents( output, pointer );
fputwc( btowc( '"' ), output );
url_fputwc( btowc( '"' ), output );
}
/**
@ -70,7 +70,7 @@ print_list_contents( URL_FILE * output, struct cons_pointer pointer,
switch ( cell->tag.value ) {
case CONSTV:
if ( initial_space ) {
fputwc( btowc( ' ' ), output );
url_fputwc( btowc( ' ' ), output );
}
print( output, cell->payload.cons.car );
@ -79,23 +79,23 @@ print_list_contents( URL_FILE * output, struct cons_pointer pointer,
case NILTV:
break;
default:
fwprintf( output, L" . " );
url_fwprintf( output, L" . " );
print( output, pointer );
}
}
void print_list( URL_FILE * output, struct cons_pointer pointer ) {
if ( print_use_colours ) {
fwprintf( output, L"%s(%s", "\x1B[31m", "\x1B[39m" );
url_fwprintf( output, L"%s(%s", "\x1B[31m", "\x1B[39m" );
} else {
fputws( L"(", output );
url_fputws( L"(", output );
};
print_list_contents( output, pointer, false );
if ( print_use_colours ) {
fwprintf( output, L"%s)%s", "\x1B[31m", "\x1B[39m" );
url_fwprintf( output, L"%s)%s", "\x1B[31m", "\x1B[39m" );
} else {
fputws( L")", output );
url_fputws( L")", output );
}
}
@ -117,18 +117,18 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) {
print_list( output, pointer );
break;
case EXCEPTIONTV:
fwprintf( output, L"\n%sException: ",
print_use_colours ? "\x1B[31m" : "" );
url_fwprintf( output, L"\n%sException: ",
print_use_colours ? "\x1B[31m" : "" );
dump_stack_trace( output, pointer );
break;
case FUNCTIONTV:
fwprintf( output, L"<Function>" );
url_fwprintf( output, L"<Function>" );
break;
case INTEGERTV:{
struct cons_pointer s = integer_to_string( pointer, 10 );
inc_ref( s );
if ( print_use_colours ) {
fputws( L"\x1B[34m", output );
url_fputws( L"\x1B[34m", output );
}
print_string_contents( output, s );
dec_ref( s );
@ -147,7 +147,7 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) {
}
break;
case NILTV:
fwprintf( output, L"nil" );
url_fwprintf( output, L"nil" );
break;
case NLAMBDATV:{
struct cons_pointer to_print =
@ -163,11 +163,11 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) {
break;
case RATIOTV:
print( output, cell.payload.ratio.dividend );
fputws( L"/", output );
url_fputws( L"/", output );
print( output, cell.payload.ratio.divisor );
break;
case READTV:
fwprintf( output, L"<Input stream>" );
url_fwprintf( output, L"<Input stream>" );
break;
case REALTV:
/* \todo using the C heap is a bad plan because it will fragment.
@ -183,31 +183,31 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) {
}
}
if ( print_use_colours ) {
fputws( L"\x1B[34m", output );
url_fputws( L"\x1B[34m", output );
}
fwprintf( output, L"%s", buffer );
url_fwprintf( output, L"%s", buffer );
free( buffer );
break;
case STRINGTV:
if ( print_use_colours ) {
fputws( L"\x1B[36m", output );
url_fputws( L"\x1B[36m", output );
}
print_string( output, pointer );
break;
case SYMBOLTV:
if ( print_use_colours ) {
fputws( L"\x1B[1;33m", output );
url_fputws( L"\x1B[1;33m", output );
}
print_string_contents( output, pointer );
break;
case SPECIALTV:
fwprintf( output, L"<Special form>" );
url_fwprintf( output, L"<Special form>" );
break;
case TRUETV:
fwprintf( output, L"t" );
url_fwprintf( output, L"t" );
break;
case WRITETV:
fwprintf( output, L"<Output stream>" );
url_fwprintf( output, L"<Output stream>" );
break;
default:
fwprintf( stderr,
@ -219,12 +219,12 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) {
}
if ( print_use_colours ) {
fputws( L"\x1B[39m", output );
url_fputws( L"\x1B[39m", output );
}
return pointer;
}
void println( URL_FILE * output ) {
fputws( L"\n", output );
url_fputws( L"\n", output );
}

54
src/ops/read.c
View file

@ -41,8 +41,8 @@ struct cons_pointer read_number( struct stack_frame *frame,
URL_FILE * input, wint_t initial,
bool seen_period );
struct cons_pointer read_list( struct stack_frame *frame,
struct cons_pointer frame_pointer, URL_FILE * input,
wint_t initial );
struct cons_pointer frame_pointer,
URL_FILE * input, wint_t initial );
struct cons_pointer read_string( URL_FILE * input, wint_t initial );
struct cons_pointer read_symbol( URL_FILE * input, wint_t initial );
@ -68,16 +68,18 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
wint_t c;
for ( c = initial;
c == '\0' || iswblank( c ) || iswcntrl( c ); c = fgetwc( input ) );
c == '\0' || iswblank( c ) || iswcntrl( c );
c = url_fgetwc( input ) );
if ( feof( input ) ) {
if ( url_feof( input ) ) {
result =
throw_exception( c_string_to_lisp_string
( L"End of file while reading" ), frame_pointer );
} else {
switch ( c ) {
case ';':
for ( c = fgetwc( input ); c != '\n'; c = fgetwc( input ) );
for ( c = url_fgetwc( input ); c != '\n';
c = url_fgetwc( input ) );
/* skip all characters from semi-colon to the end of the line */
break;
case EOF:
@ -89,18 +91,19 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
result =
c_quote( read_continuation
( frame, frame_pointer, input,
fgetwc( input ) ) );
url_fgetwc( input ) ) );
break;
case '(':
result =
read_list( frame, frame_pointer, input, fgetwc( input ) );
read_list( frame, frame_pointer, input,
url_fgetwc( input ) );
break;
case '"':
result = read_string( input, fgetwc( input ) );
result = read_string( input, url_fgetwc( input ) );
break;
case '-':{
wint_t next = fgetwc( input );
ungetwc( next, input );
wint_t next = url_fgetwc( input );
url_ungetwc( next, input );
if ( iswdigit( next ) ) {
result =
read_number( frame, frame_pointer, input, c,
@ -112,9 +115,9 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
break;
case '.':
{
wint_t next = fgetwc( input );
wint_t next = url_fgetwc( input );
if ( iswdigit( next ) ) {
ungetwc( next, input );
url_ungetwc( next, input );
result =
read_number( frame, frame_pointer, input, c,
true );
@ -123,13 +126,13 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
* really need to backtrack up a level. */
result =
read_continuation( frame, frame_pointer, input,
fgetwc( input ) );
url_fgetwc( input ) );
} else {
read_symbol( input, c );
}
}
break;
//case ':': reserved for keywords and paths
//case ':': reserved for keywords and paths
default:
if ( iswdigit( c ) ) {
result =
@ -173,14 +176,14 @@ struct cons_pointer read_number( struct stack_frame *frame,
bool neg = initial == btowc( '-' );
if ( neg ) {
initial = fgetwc( input );
initial = url_fgetwc( input );
}
debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial,
initial );
for ( c = initial; iswdigit( c )
|| c == L'.' || c == L'/' || c == L','; c = fgetwc( input ) ) {
|| c == L'.' || c == L'/' || c == L','; c = url_fgetwc( input ) ) {
switch ( c ) {
case L'.':
if ( seen_period || !nilp( dividend ) ) {
@ -229,7 +232,7 @@ struct cons_pointer read_number( struct stack_frame *frame,
/*
* push back the character read which was not a digit
*/
ungetwc( c, input );
url_ungetwc( c, input );
if ( seen_period ) {
debug_print( L"read_number: converting result to real\n", DEBUG_IO );
@ -279,7 +282,7 @@ struct cons_pointer read_list( struct stack_frame *frame,
result =
make_cons( car,
read_list( frame, frame_pointer, input,
fgetwc( input ) ) );
url_fgetwc( input ) ) );
} else {
debug_print( L"End of list detected\n", DEBUG_IO );
}
@ -309,7 +312,8 @@ struct cons_pointer read_string( URL_FILE * input, wint_t initial ) {
break;
default:
result =
make_string( initial, read_string( input, fgetwc( input ) ) );
make_string( initial,
read_string( input, url_fgetwc( input ) ) );
break;
}
@ -328,7 +332,8 @@ struct cons_pointer read_symbol( URL_FILE * input, wint_t initial ) {
* THIS IS NOT A GOOD IDEA, but is legal
*/
result =
make_symbol( initial, read_symbol( input, fgetwc( input ) ) );
make_symbol( initial,
read_symbol( input, url_fgetwc( input ) ) );
break;
case ')':
/*
@ -338,20 +343,20 @@ struct cons_pointer read_symbol( URL_FILE * input, wint_t initial ) {
/*
* push back the character read
*/
ungetwc( initial, input );
url_ungetwc( initial, input );
break;
default:
if ( iswprint( initial )
&& !iswblank( initial ) ) {
result =
make_symbol( initial,
read_symbol( input, fgetwc( input ) ) );
read_symbol( input, url_fgetwc( input ) ) );
} else {
result = NIL;
/*
* push back the character read
*/
ungetwc( initial, input );
url_ungetwc( initial, input );
}
break;
}
@ -369,5 +374,6 @@ struct cons_pointer read( struct
stack_frame
*frame, struct cons_pointer frame_pointer,
URL_FILE * input ) {
return read_continuation( frame, frame_pointer, input, fgetwc( input ) );
return read_continuation( frame, frame_pointer, input,
url_fgetwc( input ) );
}

3
src/ops/read.h
View file

@ -15,6 +15,7 @@
* read the next object on this input stream and return a cons_pointer to it.
*/
struct cons_pointer read( struct stack_frame *frame,
struct cons_pointer frame_pointer, URL_FILE * input );
struct cons_pointer frame_pointer,
URL_FILE * input );
#endif