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

Fixed, working.

Browse source
This commit is contained in:
Simon Brooke 2019-01-29 22:36:20 +00:00
parent eb394d153f
commit f9bcac10e7
14 changed files with 159 additions and 155 deletions
Download patch file Download diff file Expand all files Collapse all files

17
src/ops/lispops.c
View file

@ -352,10 +352,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 );
@ -842,7 +841,9 @@ struct cons_pointer c_reverse( struct cons_pointer arg ) {
result = make_string( o.payload.string.character, result );
break;
case SYMBOLTV:
result = make_symbol_or_key( o.payload.string.character, result, SYMBOLTAG );
result =
make_symbol_or_key( o.payload.string.character, result,
SYMBOLTAG );
break;
}
}
@ -1208,13 +1209,13 @@ struct cons_pointer lisp_source( struct stack_frame *frame,
struct cons_pointer env ) {
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( frame->arg[0] );
struct cons_pointer source_key = c_string_to_lisp_keyword(L"source");
struct cons_pointer source_key = c_string_to_lisp_keyword( L"source" );
switch ( cell.tag.value ) {
case FUNCTIONTV:
result = c_assoc( source_key, cell.payload.function.meta);
result = c_assoc( source_key, cell.payload.function.meta );
break;
case SPECIALTV:
result = c_assoc( source_key, cell.payload.special.meta);
result = c_assoc( source_key, cell.payload.special.meta );
break;
case LAMBDATV:
result = make_cons( c_string_to_lisp_symbol( L"lambda" ),

44
src/ops/meta.c
View file

@ -17,31 +17,29 @@
*
* @return a pointer to the metadata of my first argument, or nil if none.
*/
struct cons_pointer lisp_metadata( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
debug_print(L"lisp_metadata: entered\n", DEBUG_EVAL);
debug_dump_object(frame->arg[0], DEBUG_EVAL);
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell(frame->arg[0]);
struct cons_pointer lisp_metadata( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
debug_print( L"lisp_metadata: entered\n", DEBUG_EVAL );
debug_dump_object( frame->arg[0], DEBUG_EVAL );
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( frame->arg[0] );
switch( cell.tag.value) {
case FUNCTIONTV:
result = cell.payload.function.meta;
break;
case SPECIALTV:
result = cell.payload.special.meta;
break;
case READTV:
case WRITETV:
result = cell.payload.special.meta;
break;
}
switch ( cell.tag.value ) {
case FUNCTIONTV:
result = cell.payload.function.meta;
break;
case SPECIALTV:
result = cell.payload.special.meta;
break;
case READTV:
case WRITETV:
result = cell.payload.stream.meta;
break;
}
return make_cons(
make_cons(
c_string_to_lisp_keyword( L"type"),
c_type(frame->arg[0])),
result);
return make_cons( make_cons( c_string_to_lisp_keyword( L"type" ),
c_type( frame->arg[0] ) ), result );
// return result;
}

5
src/ops/meta.h
View file

@ -11,7 +11,8 @@
#define __psse_meta_h
struct cons_pointer lisp_metadata( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) ;
struct cons_pointer lisp_metadata( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
#endif

237
src/ops/print.c
View file

@ -1,237 +0,0 @@
/*
* print.c
*
* First pass at a printer, for bootstrapping.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <ctype.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include "conspage.h"
#include "consspaceobject.h"
#include "integer.h"
#include "stack.h"
#include "print.h"
/**
* Whether or not we colorise output.
* \todo this should be a Lisp symbol binding, not a C variable.
*/
int print_use_colours = 0;
/**
* print all the characters in the symbol or string indicated by `pointer`
* onto this `output`; if `pointer` does not indicate a string or symbol,
* don't print anything but just return.
*/
void print_string_contents( URL_FILE * output, struct cons_pointer pointer ) {
while ( stringp( pointer ) || symbolp( pointer ) || keywordp(pointer)) {
struct cons_space_object *cell = &pointer2cell( pointer );
wchar_t c = cell->payload.string.character;
if ( c != '\0' ) {
url_fputwc( c, output );
}
pointer = cell->payload.string.cdr;
}
}
/**
* print all the characters in the string indicated by `pointer` onto
* the stream at this `output`, prepending and appending double quote
* characters.
*/
void print_string( URL_FILE * output, struct cons_pointer pointer ) {
url_fputwc( btowc( '"' ), output );
print_string_contents( output, pointer );
url_fputwc( btowc( '"' ), output );
}
/**
* Print a single list cell (cons cell) indicated by `pointer` to the
* stream indicated by `output`. if `initial_space` is `true`, prepend
* a space character.
*/
void
print_list_contents( URL_FILE * output, struct cons_pointer pointer,
bool initial_space ) {
struct cons_space_object *cell = &pointer2cell( pointer );
switch ( cell->tag.value ) {
case CONSTV:
if ( initial_space ) {
url_fputwc( btowc( ' ' ), output );
}
print( output, cell->payload.cons.car );
print_list_contents( output, cell->payload.cons.cdr, true );
break;
case NILTV:
break;
default:
url_fwprintf( output, L" . " );
print( output, pointer );
}
}
void print_list( URL_FILE * output, struct cons_pointer pointer ) {
if ( print_use_colours ) {
url_fwprintf( output, L"%s(%s", "\x1B[31m", "\x1B[39m" );
} else {
url_fputws( L"(", output );
};
print_list_contents( output, pointer, false );
if ( print_use_colours ) {
url_fwprintf( output, L"%s)%s", "\x1B[31m", "\x1B[39m" );
} else {
url_fputws( L")", output );
}
}
/**
* Print the cons-space object indicated by `pointer` to the stream indicated
* by `output`.
*/
struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) {
struct cons_space_object cell = pointer2cell( pointer );
char *buffer;
/*
* Because tags have values as well as bytes, this if ... else if
* statement can ultimately be replaced by a switch, which will be neater.
*/
switch ( cell.tag.value ) {
case CONSTV:
print_list( output, pointer );
break;
case EXCEPTIONTV:
url_fwprintf( output, L"\n%sException: ",
print_use_colours ? "\x1B[31m" : "" );
dump_stack_trace( output, pointer );
break;
case FUNCTIONTV:
url_fwprintf( output, L"<Function>" );
break;
case INTEGERTV:{
struct cons_pointer s = integer_to_string( pointer, 10 );
inc_ref( s );
if ( print_use_colours ) {
url_fputws( L"\x1B[34m", output );
}
print_string_contents( output, s );
dec_ref( s );
}
break;
case KEYTV:
if ( print_use_colours ) {
url_fputws( L"\x1B[1;33m", output );
}
url_fputws( L":", output );
print_string_contents( output, pointer );
break;
case LAMBDATV:{
struct cons_pointer to_print =
make_cons( c_string_to_lisp_symbol( L"lambda" ),
make_cons( cell.payload.lambda.args,
cell.payload.lambda.body ) );
inc_ref( to_print );
print( output, to_print );
dec_ref( to_print );
}
break;
case NILTV:
url_fwprintf( output, L"nil" );
break;
case NLAMBDATV:{
struct cons_pointer to_print =
make_cons( c_string_to_lisp_symbol( L"nlambda" ),
make_cons( cell.payload.lambda.args,
cell.payload.lambda.body ) );
inc_ref( to_print );
print( output, to_print );
dec_ref( to_print );
}
break;
case RATIOTV:
print( output, cell.payload.ratio.dividend );
url_fputws( L"/", output );
print( output, cell.payload.ratio.divisor );
break;
case READTV:
url_fwprintf( output, L"<Input stream>" );
break;
case REALTV:
/* \todo using the C heap is a bad plan because it will fragment.
* As soon as I have working vector space I'll use a special purpose
* vector space object */
buffer = ( char * ) malloc( 24 );
memset( buffer, 0, 24 );
/* format it really long, then clear the trailing zeros */
sprintf( buffer, "%-.23Lg", cell.payload.real.value );
if ( strchr( buffer, '.' ) != NULL ) {
for ( int i = strlen( buffer ) - 1; buffer[i] == '0'; i-- ) {
buffer[i] = '\0';
}
}
if ( print_use_colours ) {
url_fputws( L"\x1B[34m", output );
}
url_fwprintf( output, L"%s", buffer );
free( buffer );
break;
case STRINGTV:
if ( print_use_colours ) {
url_fputws( L"\x1B[36m", output );
}
print_string( output, pointer );
break;
case SYMBOLTV:
if ( print_use_colours ) {
url_fputws( L"\x1B[1;33m", output );
}
print_string_contents( output, pointer );
break;
case SPECIALTV:
url_fwprintf( output, L"<Special form>" );
break;
case TRUETV:
url_fwprintf( output, L"t" );
break;
case WRITETV:
url_fwprintf( output, L"<Output stream>" );
break;
default:
fwprintf( stderr,
L"%sError: Unrecognised tag value %d (%c%c%c%c)\n",
print_use_colours ? "\x1B[31m" : "",
cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1],
cell.tag.bytes[2], cell.tag.bytes[3] );
break;
}
if ( print_use_colours ) {
url_fputws( L"\x1B[39m", output );
}
return pointer;
}
void println( URL_FILE * output ) {
url_fputws( L"\n", output );
}

21
src/ops/print.h
View file

@ -1,21 +0,0 @@
/**
* print.h
*
* First pass at a printer, for bootstrapping.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <ctype.h>
#include <stdio.h>
#ifndef __print_h
#define __print_h
struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer );
void println( URL_FILE * output );
extern int print_use_colours;
#endif

385
src/ops/read.c
View file

@ -1,385 +0,0 @@
/*
* read.c
*
* First pass at a reader, for bootstrapping.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <math.h>
#include <stdbool.h>
#include <stdio.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include "consspaceobject.h"
#include "debug.h"
#include "dump.h"
#include "integer.h"
#include "intern.h"
#include "io.h"
#include "lispops.h"
#include "peano.h"
#include "print.h"
#include "ratio.h"
#include "read.h"
#include "real.h"
#include "vectorspace.h"
/*
* for the time being things which may be read are: strings numbers - either
* integer or real, but not yet including ratios or bignums lists Can't read
* atoms because I don't yet know what an atom is or how it's stored.
*/
struct cons_pointer read_number( struct stack_frame *frame,
struct cons_pointer frame_pointer,
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 read_string( URL_FILE * input, wint_t initial );
struct cons_pointer read_symbol_or_key( URL_FILE * input, char *tag,
wint_t initial );
/**
* quote reader macro in C (!)
*/
struct cons_pointer c_quote( struct cons_pointer arg ) {
return make_cons( c_string_to_lisp_symbol( L"quote" ),
make_cons( arg, NIL ) );
}
/**
* Read the next object on this input stream and return a cons_pointer to it,
* treating this initial character as the first character of the object
* representation.
*/
struct cons_pointer read_continuation( struct stack_frame *frame,
struct cons_pointer frame_pointer,
URL_FILE * input, wint_t initial ) {
debug_print( L"entering read_continuation\n", DEBUG_IO );
struct cons_pointer result = NIL;
wint_t c;
for ( c = initial;
c == '\0' || iswblank( c ) || iswcntrl( c );
c = url_fgetwc( 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 = url_fgetwc( input ); c != '\n';
c = url_fgetwc( input ) );
/* skip all characters from semi-colon to the end of the line */
break;
case EOF:
result = throw_exception( c_string_to_lisp_string
( L"End of input while reading" ),
frame_pointer );
break;
case '\'':
result =
c_quote( read_continuation
( frame, frame_pointer, input,
url_fgetwc( input ) ) );
break;
case '(':
result =
read_list( frame, frame_pointer, input,
url_fgetwc( input ) );
break;
case '"':
result = read_string( input, url_fgetwc( input ) );
break;
case '-':{
wint_t next = url_fgetwc( input );
url_ungetwc( next, input );
if ( iswdigit( next ) ) {
result =
read_number( frame, frame_pointer, input, c,
false );
} else {
result = read_symbol_or_key( input, SYMBOLTAG, c );
}
}
break;
case '.':
{
wint_t next = url_fgetwc( input );
if ( iswdigit( next ) ) {
url_ungetwc( next, input );
result =
read_number( frame, frame_pointer, input, c,
true );
} else if ( iswblank( next ) ) {
/* dotted pair. \todo this isn't right, we
* really need to backtrack up a level. */
result =
read_continuation( frame, frame_pointer, input,
url_fgetwc( input ) );
} else {
read_symbol_or_key( input, SYMBOLTAG, c );
}
}
break;
case ':':
result =
read_symbol_or_key( input, KEYTAG, url_fgetwc( input ) );
break;
default:
if ( iswdigit( c ) ) {
result =
read_number( frame, frame_pointer, input, c, false );
} else if ( iswprint( c ) ) {
result = read_symbol_or_key( input, SYMBOLTAG, c );
} else {
result =
throw_exception( make_cons( c_string_to_lisp_string
( L"Unrecognised start of input character" ),
make_string( c, NIL ) ),
frame_pointer );
}
break;
}
}
debug_print( L"read_continuation returning\n", DEBUG_IO );
debug_dump_object( result, DEBUG_IO );
return result;
}
/**
* read a number from this input stream, given this initial character.
* \todo Need to do a lot of inc_ref and dec_ref, to make sure the
* garbage is collected.
*/
struct cons_pointer read_number( struct stack_frame *frame,
struct cons_pointer frame_pointer,
URL_FILE * input,
wint_t initial, bool seen_period ) {
debug_print( L"entering read_number\n", DEBUG_IO );
struct cons_pointer result = make_integer( 0, NIL );
/* \todo we really need to be getting `base` from a privileged Lisp name -
* and it should be the same privileged name we use when writing numbers */
struct cons_pointer base = make_integer( 10, NIL );
struct cons_pointer dividend = NIL;
int places_of_decimals = 0;
wint_t c;
bool neg = initial == btowc( '-' );
if ( neg ) {
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 = url_fgetwc( input ) ) {
switch ( c ) {
case L'.':
if ( seen_period || !nilp( dividend ) ) {
return throw_exception( c_string_to_lisp_string
( L"Malformed number: too many periods" ),
frame_pointer );
} else {
debug_print( L"read_number: decimal point seen\n",
DEBUG_IO );
seen_period = true;
}
break;
case L'/':
if ( seen_period || !nilp( dividend ) ) {
return throw_exception( c_string_to_lisp_string
( L"Malformed number: dividend of rational must be integer" ),
frame_pointer );
} else {
debug_print( L"read_number: ratio slash seen\n",
DEBUG_IO );
dividend = result;
result = make_integer( 0, NIL );
}
break;
case L',':
// silently ignore it.
break;
default:
result = add_integers( multiply_integers( result, base ),
make_integer( ( int ) c - ( int ) '0',
NIL ) );
debug_printf( DEBUG_IO,
L"read_number: added character %c, result now ",
c );
debug_print_object( result, DEBUG_IO );
debug_print( L"\n", DEBUG_IO );
if ( seen_period ) {
places_of_decimals++;
}
}
}
/*
* push back the character read which was not a digit
*/
url_ungetwc( c, input );
if ( seen_period ) {
debug_print( L"read_number: converting result to real\n", DEBUG_IO );
struct cons_pointer div = make_ratio( frame_pointer, result,
make_integer( powl
( to_long_double
( base ),
places_of_decimals ),
NIL ) );
inc_ref( div );
result = make_real( to_long_double( div ) );
dec_ref( div );
} else if ( integerp( dividend ) ) {
debug_print( L"read_number: converting result to ratio\n", DEBUG_IO );
result = make_ratio( frame_pointer, dividend, result );
}
if ( neg ) {
debug_print( L"read_number: converting result to negative\n",
DEBUG_IO );
result = negative( frame_pointer, result );
}
debug_print( L"read_number returning\n", DEBUG_IO );
debug_dump_object( result, DEBUG_IO );
return result;
}
/**
* Read a list from this input stream, which no longer contains the opening
* left parenthesis.
*/
struct cons_pointer read_list( struct stack_frame *frame,
struct cons_pointer frame_pointer,
URL_FILE * input, wint_t initial ) {
struct cons_pointer result = NIL;
if ( initial != ')' ) {
debug_printf( DEBUG_IO,
L"read_list starting '%C' (%d)\n", initial, initial );
struct cons_pointer car =
read_continuation( frame, frame_pointer, input,
initial );
result =
make_cons( car,
read_list( frame, frame_pointer, input,
url_fgetwc( input ) ) );
} else {
debug_print( L"End of list detected\n", DEBUG_IO );
}
return result;
}
/**
* Read a string. This means either a string delimited by double quotes
* (is_quoted == true), in which case it may contain whitespace but may
* not contain a double quote character (unless escaped), or one not
* so delimited in which case it may not contain whitespace (unless escaped)
* but may contain a double quote character (probably not a good idea!)
*/
struct cons_pointer read_string( URL_FILE * input, wint_t initial ) {
struct cons_pointer cdr = NIL;
struct cons_pointer result;
switch ( initial ) {
case '\0':
result = NIL;
break;
case '"':
/* making a string of the null character means we can have an empty
* string. Just returning NIL here would make an empty string
* impossible. */
result = make_string( '\0', NIL );
break;
default:
result =
make_string( initial,
read_string( input, url_fgetwc( input ) ) );
break;
}
return result;
}
struct cons_pointer read_symbol_or_key( URL_FILE * input, char *tag,
wint_t initial ) {
struct cons_pointer cdr = NIL;
struct cons_pointer result;
switch ( initial ) {
case '\0':
result = make_symbol_or_key( initial, NIL, tag );
break;
case '"':
case '\'':
/* unwise to allow embedded quotation marks in symbols */
case ')':
case ':':
/*
* symbols and keywords may not include right-parenthesis
* or colons.
*/
result = NIL;
/*
* push back the character read
*/
url_ungetwc( initial, input );
break;
default:
if ( iswprint( initial )
&& !iswblank( initial ) ) {
result =
make_symbol_or_key( initial,
read_symbol_or_key( input,
tag,
url_fgetwc( input ) ),
tag );
} else {
result = NIL;
/*
* push back the character read
*/
url_ungetwc( initial, input );
}
break;
}
debug_print( L"read_symbol_or_key returning\n", DEBUG_IO );
debug_dump_object( result, DEBUG_IO );
return result;
}
/**
* 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 ) {
return read_continuation( frame, frame_pointer, input,
url_fgetwc( input ) );
}

21
src/ops/read.h
View file

@ -1,21 +0,0 @@
/**
* read.c
*
* First pass at a reader, for bootstrapping.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __read_h
#define __read_h
/**
* 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 );
#endif