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

There's an enormous lot of good stuff in this, but I've messed up print

Browse source 
almost certainly by writing a non-wide character to a wide stream.
This commit is contained in:
Simon Brooke 2018-12-07 20:09:33 +00:00
parent 7e40d65df0
commit 93b84087ce
13 changed files with 379 additions and 131 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Makefile
View file

@ -13,7 +13,7 @@ INC_DIRS := $(shell find $(SRC_DIRS) -type d)
INC_FLAGS := $(addprefix -I,$(INC_DIRS)) INC_FLAGS := $(addprefix -I,$(INC_DIRS))
INDENT_FLAGS := -kr -br -brf -brs -ce -cdw -npsl -nut -prs -l79 -ts2 INDENT_FLAGS := -kr -br -brf -brs -ce -cdw -npsl -nut -prs -l79 -ts2
VERSION := "0.0.0" VERSION := "0.0.2"
CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g
LDFLAGS := -lm LDFLAGS := -lm

29
src/conspage.c
View file

@ -1,7 +1,7 @@
/* /*
* conspage.c * conspage.c
* *
* Setup and tear down cons pages, and (FOR NOW) do primitive * Setup and tear down cons pages, and (FOR NOW) do primitive
* allocation/deallocation of cells. * allocation/deallocation of cells.
* NOTE THAT before we go multi-threaded, these functions must be * NOTE THAT before we go multi-threaded, these functions must be
* aggressively * aggressively
@ -30,7 +30,7 @@ bool conspageinitihasbeencalled = false;
int initialised_cons_pages = 0; int initialised_cons_pages = 0;
/** /**
* The (global) pointer to the (global) freelist. Not sure whether this ultimately * The (global) pointer to the (global) freelist. Not sure whether this ultimately
* belongs in this file. * belongs in this file.
*/ */
struct cons_pointer freelist = NIL; struct cons_pointer freelist = NIL;
@ -54,19 +54,21 @@ void make_cons_page( ) {
for ( int i = 0; i < CONSPAGESIZE; i++ ) { for ( int i = 0; i < CONSPAGESIZE; i++ ) {
struct cons_space_object *cell = struct cons_space_object *cell =
&conspages[initialised_cons_pages]->cell[i]; &conspages[initialised_cons_pages]->cell[i];
if ( initialised_cons_pages == 0 && i < 2 ) { if ( initialised_cons_pages == 0 && i < 3 ) {
if ( i == 0 ) { switch ( i) {
case 0:
/* /*
* initialise cell as NIL * initialise cell as NIL
*/ */
strncpy( &cell->tag.bytes[0], NILTAG, TAGLENGTH ); strncpy( &cell->tag.bytes[0], NILTAG, TAGLENGTH );
cell->count = MAXREFERENCE; cell->count = MAXREFERENCE;
cell->payload.free.car = NIL; cell->payload.free.car = NIL;
cell->payload.free.cdr = NIL; cell->payload.free.cdr = NIL;
fwprintf( stderr, L"Allocated special cell NIL\n" ); fwprintf( stderr, L"Allocated special cell NIL\n" );
} else if ( i == 1 ) { break;
case 1:
/* /*
* initialise cell as T * initialise cell as T
*/ */
strncpy( &cell->tag.bytes[0], TRUETAG, TAGLENGTH ); strncpy( &cell->tag.bytes[0], TRUETAG, TAGLENGTH );
cell->count = MAXREFERENCE; cell->count = MAXREFERENCE;
@ -75,10 +77,21 @@ void make_cons_page( ) {
cell->payload.free.cdr = ( struct cons_pointer ) { cell->payload.free.cdr = ( struct cons_pointer ) {
0, 1}; 0, 1};
fwprintf( stderr, L"Allocated special cell T\n" ); fwprintf( stderr, L"Allocated special cell T\n" );
break;
case 2:
/*
* initialise cell as λ
*/
strncpy( &cell->tag.bytes[0], LAMBDATAG, TAGLENGTH );
cell->count = MAXREFERENCE;
cell->payload.string.character = (wint_t)L'λ';
cell->payload.free.cdr = NIL;
fwprintf( stderr, L"Allocated special cell LAMBDA\n" );
break;
} }
} else { } else {
/* /*
* otherwise, standard initialisation * otherwise, standard initialisation
*/ */
strncpy( &cell->tag.bytes[0], FREETAG, TAGLENGTH ); strncpy( &cell->tag.bytes[0], FREETAG, TAGLENGTH );
cell->payload.free.car = NIL; cell->payload.free.car = NIL;

86
src/consspaceobject.c
View file

@ -11,8 +11,9 @@
#include <stdint.h> #include <stdint.h>
#include <stdlib.h> #include <stdlib.h>
#include <string.h> #include <string.h>
#include <stdio.h>
/* /*
* wide characters * wide characters
*/ */
#include <wchar.h> #include <wchar.h>
#include <wctype.h> #include <wctype.h>
@ -20,6 +21,7 @@
#include "conspage.h" #include "conspage.h"
#include "consspaceobject.h" #include "consspaceobject.h"
#include "print.h" #include "print.h"
#include "stack.h"
/** /**
* Check that the tag on the cell at this pointer is this tag * Check that the tag on the cell at this pointer is this tag
@ -83,33 +85,53 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
cell.payload.cons.cdr.page, cell.payload.cons.cdr.page,
cell.payload.cons.cdr.offset, cell.count ); cell.payload.cons.cdr.offset, cell.count );
break; break;
case EXCEPTIONTV:
fwprintf(output, L"\t\tException cell: ");
print(output, cell.payload.exception.message);
fwprintf( output, L"\n");
/* TODO: dump the stack trace */
for (struct stack_frame * frame = cell.payload.exception.frame;
frame != NULL;
frame = frame->previous){
dump_frame(output, frame);
}
break;
case FREETV:
fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n",
cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset );
break;
case INTEGERTV: case INTEGERTV:
fwprintf( output, fwprintf( output,
L"\t\tInteger cell: value %ld, count %u\n", L"\t\tInteger cell: value %ld, count %u\n",
cell.payload.integer.value, cell.count ); cell.payload.integer.value, cell.count );
break; break;
case FREETV: case READTV:
fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n", fwprintf( output, L"\t\tInput stream\n");
cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset );
break;
case REALTV: case REALTV:
fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n", fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n",
cell.payload.real.value, cell.count ); cell.payload.real.value, cell.count );
break; break;
case STRINGTV: case STRINGTV:
if (cell.payload.string.character == 0) {
fwprintf( output, fwprintf( output,
L"\t\tString cell: character '%c' (%d) next at page %d offset %d, count %u\n", L"\t\tString cell: termination; next at page %d offset %d, count %u\n",
cell.payload.string.character,
cell.payload.string.cdr.page,
cell.payload.string.cdr.offset, cell.count );
}else {
fwprintf( output,
L"\t\tString cell: character '%lc' (%d) next at page %d offset %d, count %u\n",
cell.payload.string.character, cell.payload.string.character,
cell.payload.string.character, cell.payload.string.character,
cell.payload.string.cdr.page, cell.payload.string.cdr.page,
cell.payload.string.cdr.offset, cell.count ); cell.payload.string.cdr.offset, cell.count );
fwprintf( output, L"\t\t value: " ); fwprintf( output, L"\t\t value: " );
print( output, pointer ); print( output, pointer );
fwprintf( output, L"\n" ); fwprintf( output, L"\n" );}
break; break;
case SYMBOLTV: case SYMBOLTV:
fwprintf( output, fwprintf( output,
L"\t\tSymbol cell: character '%c' (%d) next at page %d offset %d, count %u\n", L"\t\tSymbol cell: character '%lc' (%d) next at page %d offset %d, count %u\n",
cell.payload.string.character, cell.payload.string.character,
cell.payload.string.character, cell.payload.string.character,
cell.payload.string.cdr.page, cell.payload.string.cdr.page,
@ -141,6 +163,22 @@ struct cons_pointer make_cons( struct cons_pointer car,
return pointer; return pointer;
} }
/**
* Construct an exception cell.
* @param message should be a lisp string describing the problem, but actually any cons pointer will do;
* @param frame should be the frame in which the exception occurred.
*/
struct cons_pointer make_exception( struct cons_pointer message, struct stack_frame * frame) {
struct cons_pointer pointer = allocate_cell( EXCEPTIONTAG );
struct cons_space_object *cell = &pointer2cell( pointer );
cell->payload.exception.message = message;
cell->payload.exception.frame = frame;
return pointer;
}
/** /**
* Construct a cell which points to an executable Lisp special form. * Construct a cell which points to an executable Lisp special form.
*/ */
@ -159,7 +197,7 @@ make_function( struct cons_pointer src, struct cons_pointer ( *executable )
/** /**
* Construct a string from this character (which later will be UTF) and * Construct a string from this character (which later will be UTF) and
* this tail. A string is implemented as a flat list of cells each of which * this tail. A string is implemented as a flat list of cells each of which
* has one character and a pointer to the next; in the last cell the * has one character and a pointer to the next; in the last cell the
* pointer to next is NIL. * pointer to next is NIL.
*/ */
struct cons_pointer struct cons_pointer
@ -188,7 +226,7 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) {
/** /**
* Construct a string from this character and * Construct a string from this character and
* this tail. A string is implemented as a flat list of cells each of which * this tail. A string is implemented as a flat list of cells each of which
* has one character and a pointer to the next; in the last cell the * has one character and a pointer to the next; in the last cell the
* pointer to next is NIL. * pointer to next is NIL.
*/ */
struct cons_pointer make_string( wint_t c, struct cons_pointer tail ) { struct cons_pointer make_string( wint_t c, struct cons_pointer tail ) {
@ -196,7 +234,7 @@ struct cons_pointer make_string( wint_t c, struct cons_pointer tail ) {
} }
/** /**
* Construct a symbol from this character and this tail. * Construct a symbol from this character and this tail.
*/ */
struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) { struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) {
return make_string_like_thing( c, tail, SYMBOLTAG ); return make_string_like_thing( c, tail, SYMBOLTAG );
@ -217,6 +255,32 @@ make_special( struct cons_pointer src, struct cons_pointer ( *executable )
return pointer; return pointer;
} }
/**
* Construct a cell which points to a stream open for reading.
* @param input the C stream to wrap.
*/
struct cons_pointer make_read_stream( FILE * input) {
struct cons_pointer pointer = allocate_cell( READTAG );
struct cons_space_object *cell = &pointer2cell( pointer );
cell->payload.stream.stream = input;
return pointer;
}
/**
* Construct a cell which points to a stream open for writeing.
* @param output the C stream to wrap.
*/
struct cons_pointer make_write_stream( FILE * output) {
struct cons_pointer pointer = allocate_cell( WRITETAG );
struct cons_space_object *cell = &pointer2cell( pointer );
cell->payload.stream.stream = output;
return pointer;
}
/** /**
* Return a lisp string representation of this old skool ASCII string. * Return a lisp string representation of this old skool ASCII string.
*/ */

130
src/consspaceobject.h
View file

@ -12,7 +12,7 @@
#include <stdint.h> #include <stdint.h>
#include <stdio.h> #include <stdio.h>
/* /*
* wide characters * wide characters
*/ */
#include <wchar.h> #include <wchar.h>
#include <wctype.h> #include <wctype.h>
@ -53,6 +53,13 @@
#define INTEGERTAG "INTR" #define INTEGERTAG "INTR"
#define INTEGERTV 1381256777 #define INTEGERTV 1381256777
/**
* Lambda is very special, and, like NIL and TRUE, we need to identify it
* quickly and cheaply. So we will give it, too, a special cons cell at {0,2}
*/
#define LAMBDATAG "LMDA"
#define LAMBDATV 1094995276
/** /**
* The special cons cell at address {0,0} whose car and cdr both point to itself. * The special cons cell at address {0,0} whose car and cdr both point to itself.
* 541870414 * 541870414
@ -64,6 +71,7 @@
* An open read stream. * An open read stream.
*/ */
#define READTAG "READ" #define READTAG "READ"
#define READTV 1145128274
/** /**
* A real number. * A real number.
@ -85,7 +93,7 @@
#define STRINGTV 1196577875 #define STRINGTV 1196577875
/** /**
* A symbol is just like a string except not self-evaluating. 1112365395 * A symbol is just like a string except not self-evaluating. 1112365395
*/ */
#define SYMBOLTAG "SYMB" #define SYMBOLTAG "SYMB"
#define SYMBOLTV 1112365395 #define SYMBOLTV 1112365395
@ -106,6 +114,15 @@
* An open write stream. * An open write stream.
*/ */
#define WRITETAG "WRIT" #define WRITETAG "WRIT"
/* TODO: this is wrong */
#define WRITETV 1414091351
/**
* An exception.
*/
#define EXCEPTIONTAG "EXEP"
/* TODO: this is wrong */
#define EXCEPTIONTV 1346721861
/** /**
* a cons pointer which points to the special NIL cell * a cons pointer which points to the special NIL cell
@ -117,6 +134,11 @@
*/ */
#define TRUE (struct cons_pointer){ 0, 1} #define TRUE (struct cons_pointer){ 0, 1}
/**
* a cons pointer which points to the special λ cell
*/
#define LAMBDA (struct cons_pointer){ 0,2}
/** /**
* the maximum possible value of a reference count * the maximum possible value of a reference count
*/ */
@ -130,53 +152,63 @@
#define pointer2cell(pointer) ((conspages[pointer.page]->cell[pointer.offset])) #define pointer2cell(pointer) ((conspages[pointer.page]->cell[pointer.offset]))
/** /**
* true if conspointer points to the special cell NIL, else false * true if conspointer points to the special cell NIL, else false
* (there should only be one of these so it's slightly redundant). * (there should only be one of these so it's slightly redundant).
*/ */
#define nilp(conspoint) (check_tag(conspoint,NILTAG)) #define nilp(conspoint) (check_tag(conspoint,NILTAG))
/** /**
* true if conspointer points to a cons cell, else false * true if conspointer points to a cons cell, else false
*/ */
#define consp(conspoint) (check_tag(conspoint,CONSTAG)) #define consp(conspoint) (check_tag(conspoint,CONSTAG))
/** /**
* true if conspointer points to a function cell, else false * true if conspointer points to an exception, else false
*/
#define exceptionp(conspoint) (check_tag(conspoint,EXCEPTIONTAG))
/**
* true if conspointer points to a function cell, else false
*/ */
#define functionp(conspoint) (check_tag(conspoint,FUNCTIONTAG)) #define functionp(conspoint) (check_tag(conspoint,FUNCTIONTAG))
/** /**
* true if conspointer points to a special form cell, else false * true if conspointer points to the special Lambda cell, else false
*/
#define lambdap(conspoint) (check_tag(conspoint,LAMBDATAG))
/**
* true if conspointer points to a special form cell, else false
*/ */
#define specialp(conspoint) (check_tag(conspoint,SPECIALTAG)) #define specialp(conspoint) (check_tag(conspoint,SPECIALTAG))
/** /**
* true if conspointer points to a string cell, else false * true if conspointer points to a string cell, else false
*/ */
#define stringp(conspoint) (check_tag(conspoint,STRINGTAG)) #define stringp(conspoint) (check_tag(conspoint,STRINGTAG))
/** /**
* true if conspointer points to a symbol cell, else false * true if conspointer points to a symbol cell, else false
*/ */
#define symbolp(conspoint) (check_tag(conspoint,SYMBOLTAG)) #define symbolp(conspoint) (check_tag(conspoint,SYMBOLTAG))
/** /**
* true if conspointer points to an integer cell, else false * true if conspointer points to an integer cell, else false
*/ */
#define integerp(conspoint) (check_tag(conspoint,INTEGERTAG)) #define integerp(conspoint) (check_tag(conspoint,INTEGERTAG))
/** /**
* true if conspointer points to a read stream cell, else false * true if conspointer points to a read stream cell, else false
*/ */
#define readp(conspoint) (check_tag(conspoint,READTAG)) #define readp(conspoint) (check_tag(conspoint,READTAG))
/** /**
* true if conspointer points to a real number cell, else false * true if conspointer points to a real number cell, else false
*/ */
#define realp(conspoint) (check_tag(conspoint,REALTAG)) #define realp(conspoint) (check_tag(conspoint,REALTAG))
/** /**
* true if conspointer points to some sort of a number cell, * true if conspointer points to some sort of a number cell,
* else false * else false
*/ */
#define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,REALTAG)) #define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,REALTAG))
@ -187,7 +219,7 @@
#define writep(conspoint) (check_tag(conspoint,WRITETAG)) #define writep(conspoint) (check_tag(conspoint,WRITETAG))
/** /**
* true if conspointer points to a true cell, else false * true if conspointer points to a true cell, else false
* (there should only be one of these so it's slightly redundant). * (there should only be one of these so it's slightly redundant).
* Also note that anything that is not NIL is truthy. * Also note that anything that is not NIL is truthy.
*/ */
@ -209,7 +241,7 @@ struct cons_pointer {
}; };
/* /*
* number of arguments stored in a stack frame * number of arguments stored in a stack frame
*/ */
#define args_in_frame 8 #define args_in_frame 8
@ -221,7 +253,7 @@ struct stack_frame {
struct stack_frame *previous; /* the previous frame */ struct stack_frame *previous; /* the previous frame */
struct cons_pointer arg[args_in_frame]; struct cons_pointer arg[args_in_frame];
/* /*
* first 8 arument bindings * first 8 arument bindings
*/ */
struct cons_pointer more; /* list of any further argument bindings */ struct cons_pointer more; /* list of any further argument bindings */
struct cons_pointer function; /* the function to be called */ struct cons_pointer function; /* the function to be called */
@ -236,11 +268,20 @@ struct cons_payload {
}; };
/** /**
* Payload of a function cell. * Payload of an exception.
* source points to the source from which the function was compiled, or NIL * Message should be a Lisp string; frame should be a pointer to an (unfreed) stack frame.
*/
struct exception_payload {
struct cons_pointer message;
struct stack_frame * frame;
};
/**
* Payload of a function cell.
* source points to the source from which the function was compiled, or NIL
* if it is a primitive. * if it is a primitive.
* executable points to a function which takes a pointer to a stack frame * executable points to a function which takes a pointer to a stack frame
* (representing its stack frame) and a cons pointer (representing its * (representing its stack frame) and a cons pointer (representing its
* environment) as arguments and returns a cons pointer (representing its * environment) as arguments and returns a cons pointer (representing its
* result). * result).
*/ */
@ -277,8 +318,8 @@ struct real_payload {
}; };
/** /**
* Payload of a special form cell. * Payload of a special form cell.
* source points to the source from which the function was compiled, or NIL * source points to the source from which the function was compiled, or NIL
* if it is a primitive. * if it is a primitive.
* executable points to a function which takes a cons pointer (representing * executable points to a function which takes a cons pointer (representing
* its argument list) and a cons pointer (representing its environment) and a * its argument list) and a cons pointer (representing its environment) and a
@ -318,7 +359,7 @@ struct vectorp_payload {
char bytes[TAGLENGTH]; /* the tag (type) of the char bytes[TAGLENGTH]; /* the tag (type) of the
* vector-space object this cell * vector-space object this cell
* points to, considered as bytes. * points to, considered as bytes.
* NOTE that the vector space object * NOTE that the vector space object
* should itself have the identical * should itself have the identical
* tag. */ * tag. */
uint32_t value; /* the tag considered as a number */ uint32_t value; /* the tag considered as a number */
@ -343,47 +384,51 @@ struct cons_space_object {
* this cell */ * this cell */
union { union {
/* /*
* if tag == CONSTAG * if tag == CONSTAG
*/ */
struct cons_payload cons; struct cons_payload cons;
/* /*
* if tag == FREETAG * if tag == EXCEPTIONTAG
*/
struct exception_payload exception;
/*
* if tag == FREETAG
*/ */
struct free_payload free; struct free_payload free;
/* /*
* if tag == FUNCTIONTAG * if tag == FUNCTIONTAG
*/ */
struct function_payload function; struct function_payload function;
/* /*
* if tag == INTEGERTAG * if tag == INTEGERTAG
*/ */
struct integer_payload integer; struct integer_payload integer;
/* /*
* if tag == NILTAG; we'll treat the special cell NIL as just a cons * if tag == NILTAG; we'll treat the special cell NIL as just a cons
*/ */
struct cons_payload nil; struct cons_payload nil;
/* /*
* if tag == READTAG || tag == WRITETAG * if tag == READTAG || tag == WRITETAG
*/ */
struct stream_payload stream; struct stream_payload stream;
/* /*
* if tag == REALTAG * if tag == REALTAG
*/ */
struct real_payload real; struct real_payload real;
/* /*
* if tag == SPECIALTAG * if tag == SPECIALTAG
*/ */
struct special_payload special; struct special_payload special;
/* /*
* if tag == STRINGTAG || tag == SYMBOLTAG * if tag == STRINGTAG || tag == SYMBOLTAG
*/ */
struct string_payload string; struct string_payload string;
/* /*
* if tag == TRUETAG; we'll treat the special cell T as just a cons * if tag == TRUETAG; we'll treat the special cell T as just a cons
*/ */
struct cons_payload t; struct cons_payload t;
/* /*
* if tag == VECTORPTAG * if tag == VECTORPTAG
*/ */
struct vectorp_payload vectorp; struct vectorp_payload vectorp;
} payload; } payload;
@ -411,6 +456,12 @@ void dump_object( FILE * output, struct cons_pointer pointer );
struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer make_cons( struct cons_pointer car,
struct cons_pointer cdr ); struct cons_pointer cdr );
/**
* Construct an exception cell.
* @param message should be a lisp string describing the problem, but actually any cons pointer will do;
* @param frame should be the frame in which the exception occurred.
*/
struct cons_pointer make_exception( struct cons_pointer message, struct stack_frame * frame);
/** /**
* Construct a cell which points to an executable Lisp special form. * Construct a cell which points to an executable Lisp special form.
@ -430,7 +481,7 @@ struct cons_pointer make_special( struct cons_pointer src,
/** /**
* Construct a string from this character and this tail. A string is * Construct a string from this character and this tail. A string is
* implemented as a flat list of cells each of which has one character and a * implemented as a flat list of cells each of which has one character and a
* pointer to the next; in the last cell the pointer to next is NIL. * pointer to the next; in the last cell the pointer to next is NIL.
*/ */
struct cons_pointer make_string( wint_t c, struct cons_pointer tail ); struct cons_pointer make_string( wint_t c, struct cons_pointer tail );
@ -441,6 +492,19 @@ struct cons_pointer make_string( wint_t c, struct cons_pointer tail );
*/ */
struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ); struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail );
/**
* Construct a cell which points to a stream open for reading.
* @param input the C stream to wrap.
*/
struct cons_pointer make_read_stream( FILE * input);
/**
* Construct a cell which points to a stream open for writeing.
* @param output the C stream to wrap.
*/
struct cons_pointer make_write_stream( FILE * output);
/** /**
* Return a lisp string representation of this old skool ASCII string. * Return a lisp string representation of this old skool ASCII string.
*/ */

3
src/init.c
View file

@ -71,9 +71,10 @@ int main( int argc, char *argv[] ) {
/* /*
* privileged variables (keywords) * privileged variables (keywords)
*/ */
deep_bind( c_string_to_lisp_symbol( "nil" ), NIL ); deep_bind( c_string_to_lisp_symbol( "nil" ), NIL );
deep_bind( c_string_to_lisp_symbol( "t" ), TRUE ); deep_bind( c_string_to_lisp_symbol( "t" ), TRUE );
/* deep_bind( c_string_to_lisp_symbol( L"λ"), LAMBDA ); */
deep_bind( c_string_to_lisp_symbol( "lambda"), LAMBDA );
/* /*
* primitive function operations * primitive function operations

20
src/lispops.c
View file

@ -127,9 +127,6 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
break; break;
case FUNCTIONTV: case FUNCTIONTV:
/*
* actually, this is apply
*/
{ {
struct stack_frame *next = make_stack_frame( frame, args, env ); struct stack_frame *next = make_stack_frame( frame, args, env );
result = ( *fn_cell.payload.special.executable ) ( next, env ); result = ( *fn_cell.payload.special.executable ) ( next, env );
@ -384,7 +381,7 @@ lisp_read( struct stack_frame *frame, struct cons_pointer env ) {
input = pointer2cell( frame->arg[0] ).payload.stream.stream; input = pointer2cell( frame->arg[0] ).payload.stream.stream;
} }
return read( input ); return read( frame, input );
} }
@ -477,7 +474,7 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) {
} else if ( nilp( clause_pointer ) ) { } else if ( nilp( clause_pointer ) ) {
done = true; done = true;
} else { } else {
lisp_throw( c_string_to_lisp_string result = lisp_throw( c_string_to_lisp_string
( "Arguments to `cond` must be lists" ), frame ); ( "Arguments to `cond` must be lists" ), frame );
} }
} }
@ -494,8 +491,15 @@ struct cons_pointer
lisp_throw( struct cons_pointer message, struct stack_frame *frame ) { lisp_throw( struct cons_pointer message, struct stack_frame *frame ) {
fwprintf( stderr, L"\nERROR: " ); fwprintf( stderr, L"\nERROR: " );
print( stderr, message ); print( stderr, message );
fwprintf( stderr, struct cons_pointer result = NIL;
L"\n\nAn exception was thrown and I've no idea what to do now\n" );
exit( 1 ); struct cons_space_object cell = pointer2cell( message );
if ( cell.tag.value == EXCEPTIONTV) {
result = message;
} else {
result = make_exception( message, frame);
}
return result;
} }

40
src/peano.c
View file

@ -142,10 +142,46 @@ lisp_subtract( struct stack_frame *frame, struct cons_pointer env ) {
} else if ( realp( frame->arg[0] ) && integerp( frame->arg[1] ) ) { } else if ( realp( frame->arg[0] ) && integerp( frame->arg[1] ) ) {
result = result =
make_real( arg0.payload.real.value - make_real( arg0.payload.real.value -
numeric_value( frame->arg[0] ) ); numeric_value( frame->arg[1] ) );
} // else we have an error! } else {
/* TODO: throw an exception */
lisp_throw( c_string_to_lisp_string
( "Cannot subtract: not a number" ), frame );
}
// and if not nilp[frame->arg[2]) we also have an error. // and if not nilp[frame->arg[2]) we also have an error.
return result; return result;
} }
/**
* Divide one number by another.
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer or real.
*/
struct cons_pointer
lisp_divide( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer result = NIL;
struct cons_space_object arg0 = pointer2cell( frame->arg[0] );
struct cons_space_object arg1 = pointer2cell( frame->arg[1] );
if ( numberp(frame->arg[1]) && numeric_value(frame->arg[1]) == 0) {
lisp_throw( c_string_to_lisp_string
( "Cannot divide: divisor is zero" ), frame );
} else if ( integerp( frame->arg[0] ) && integerp( frame->arg[1] ) ) {
result = make_integer( arg0.payload.integer.value /
arg1.payload.integer.value );
} else if ( numberp(frame->arg[0]) && numberp(frame->arg[1])) {
result = make_real( numeric_value(frame->arg[0]) / numeric_value(frame->arg[1]));
} else {
lisp_throw( c_string_to_lisp_string
( "Cannot divide: not a number" ), frame );
}
return result;
}

77
src/print.c
View file

@ -11,7 +11,7 @@
#include <stdio.h> #include <stdio.h>
#include <string.h> #include <string.h>
/* /*
* wide characters * wide characters
*/ */
#include <wchar.h> #include <wchar.h>
#include <wctype.h> #include <wctype.h>
@ -75,41 +75,48 @@ void print( FILE * output, struct cons_pointer pointer ) {
/* /*
* Because tags have values as well as bytes, this if ... else if * Because tags have values as well as bytes, this if ... else if
* statement can ultimately be replaced by a switch, which will be neater. * statement can ultimately be replaced by a switch, which will be neater.
*/ */
switch ( cell.tag.value ) { switch ( cell.tag.value ) {
case CONSTV: case CONSTV:
print_list( output, pointer ); print_list( output, pointer );
break; break;
case INTEGERTV: case EXCEPTIONTV:
fwprintf( output, L"%ld", cell.payload.integer.value ); fwprintf( output, L"\nException: ");
break; print_string_contents( output, cell.payload.exception.message);
case NILTV: break;
fwprintf( output, L"nil" ); case INTEGERTV:
break; fwprintf( output, L"%ld", cell.payload.integer.value );
case REALTV: break;
fwprintf( output, L"%Lf", cell.payload.real.value ); case LAMBDATV:
break; fwprintf( output, L"lambda" /* "λ" */);
case STRINGTV: break;
print_string( output, pointer ); case NILTV:
break; fwprintf( output, L"nil" );
case SYMBOLTV: break;
print_string_contents( output, pointer ); case REALTV:
break; fwprintf( output, L"%Lf", cell.payload.real.value );
case TRUETV: break;
fwprintf( output, L"t" ); case STRINGTV:
break; print_string( output, pointer );
case FUNCTIONTV: break;
fwprintf( output, L"(Function)" ); case SYMBOLTV:
break; print_string_contents( output, pointer );
case SPECIALTV: break;
fwprintf( output, L"(Special form)" ); case TRUETV:
break; fwprintf( output, L"t" );
default: break;
fwprintf( stderr, case FUNCTIONTV:
L"Error: Unrecognised tag value %d (%c%c%c%c)\n", fwprintf( output, L"(Function)" );
cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1], break;
cell.tag.bytes[2], cell.tag.bytes[3] ); case SPECIALTV:
break; fwprintf( output, L"(Special form)" );
break;
default:
fwprintf( stderr,
L"Error: Unrecognised tag value %d (%c%c%c%c)\n",
cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1],
cell.tag.bytes[2], cell.tag.bytes[3] );
break;
} }
} }

25
src/read.c
View file

@ -20,6 +20,7 @@
#include "consspaceobject.h" #include "consspaceobject.h"
#include "integer.h" #include "integer.h"
#include "intern.h" #include "intern.h"
#include "lispops.h"
#include "print.h" #include "print.h"
#include "read.h" #include "read.h"
#include "real.h" #include "real.h"
@ -31,7 +32,7 @@
*/ */
struct cons_pointer read_number( FILE * input, wint_t initial ); struct cons_pointer read_number( FILE * input, wint_t initial );
struct cons_pointer read_list( FILE * input, wint_t initial ); struct cons_pointer read_list( struct stack_frame *frame, FILE * input, wint_t initial );
struct cons_pointer read_string( FILE * input, wint_t initial ); struct cons_pointer read_string( FILE * input, wint_t initial );
struct cons_pointer read_symbol( FILE * input, wint_t initial ); struct cons_pointer read_symbol( FILE * input, wint_t initial );
@ -48,7 +49,7 @@ struct cons_pointer c_quote( struct cons_pointer arg ) {
* treating this initial character as the first character of the object * treating this initial character as the first character of the object
* representation. * representation.
*/ */
struct cons_pointer read_continuation( FILE * input, wint_t initial ) { struct cons_pointer read_continuation(struct stack_frame *frame, FILE * input, wint_t initial ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
wint_t c; wint_t c;
@ -57,11 +58,15 @@ struct cons_pointer read_continuation( FILE * input, wint_t initial ) {
c == '\0' || iswblank( c ) || iswcntrl( c ); c = fgetwc( input ) ); c == '\0' || iswblank( c ) || iswcntrl( c ); c = fgetwc( input ) );
switch ( c ) { switch ( c ) {
case EOF:
result = lisp_throw( c_string_to_lisp_string
( "End of input while reading" ), frame );
break;
case '\'': case '\'':
result = c_quote( read_continuation( input, fgetwc( input ) ) ); result = c_quote( read_continuation( frame, input, fgetwc( input ) ) );
break; break;
case '(': case '(':
result = read_list( input, fgetwc( input ) ); result = read_list( frame, input, fgetwc( input ) );
break; break;
case '"': case '"':
result = read_string( input, fgetwc( input ) ); result = read_string( input, fgetwc( input ) );
@ -75,7 +80,7 @@ struct cons_pointer read_continuation( FILE * input, wint_t initial ) {
} else if ( iswblank( next ) ) { } else if ( iswblank( next ) ) {
/* dotted pair. TODO: this isn't right, we /* dotted pair. TODO: this isn't right, we
* really need to backtrack up a level. */ * really need to backtrack up a level. */
result = read_continuation( input, fgetwc( input ) ); result = read_continuation( frame, input, fgetwc( input ) );
} else { } else {
read_symbol( input, c ); read_symbol( input, c );
} }
@ -142,14 +147,14 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) {
* Read a list from this input stream, which no longer contains the opening * Read a list from this input stream, which no longer contains the opening
* left parenthesis. * left parenthesis.
*/ */
struct cons_pointer read_list( FILE * input, wint_t initial ) { struct cons_pointer read_list( struct stack_frame *frame, FILE * input, wint_t initial ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
if ( initial != ')' ) { if ( initial != ')' ) {
fwprintf( stderr, L"read_list starting '%C' (%d)\n", initial, fwprintf( stderr, L"read_list starting '%C' (%d)\n", initial,
initial ); initial );
struct cons_pointer car = read_continuation( input, initial ); struct cons_pointer car = read_continuation( frame, input, initial );
result = make_cons( car, read_list( input, fgetwc( input ) ) ); result = make_cons( car, read_list( frame, input, fgetwc( input ) ) );
} else { } else {
fwprintf( stderr, L"End of list detected\n" ); fwprintf( stderr, L"End of list detected\n" );
} }
@ -231,6 +236,6 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
/** /**
* Read the next object on this input stream and return a cons_pointer to it. * Read the next object on this input stream and return a cons_pointer to it.
*/ */
struct cons_pointer read( FILE * input ) { struct cons_pointer read(struct stack_frame *frame, FILE * input ) {
return read_continuation( input, fgetwc( input ) ); return read_continuation( frame, input, fgetwc( input ) );
} }

2
src/read.h
View file

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

80
src/repl.c
View file

@ -19,6 +19,54 @@
#include "print.h" #include "print.h"
#include "stack.h" #include "stack.h"
/* TODO: this is subtly wrong. If we were evaluating
* (print (eval (read)))
* then the stack frame for read would have the stack frame for
* eval as parent, and it in turn would have the stack frame for
* print as parent.
*/
/**
* Dummy up a Lisp read call with its own stack frame.
*/
struct cons_pointer repl_read( struct cons_pointer stream_pointer) {
struct stack_frame *frame = make_empty_frame( NULL, oblist );
frame->arg[0] = stream_pointer;
struct cons_pointer result = lisp_read( frame, oblist);
free_stack_frame( frame );
return result;
}
/**
* Dummy up a Lisp eval call with its own stack frame.
*/
struct cons_pointer repl_eval( struct cons_pointer input) {
struct stack_frame *frame = make_empty_frame( NULL, oblist );
frame->arg[0] = NIL /* input */;
struct cons_pointer result = lisp_eval( frame, oblist);
free_stack_frame( frame );
return result;
}
/**
* Dummy up a Lisp print call with its own stack frame.
*/
struct cons_pointer repl_print( struct cons_pointer stream_pointer, struct cons_pointer value) {
struct stack_frame *frame = make_empty_frame( NULL, oblist );
frame->arg[0] = value;
frame->arg[1] = NIL /* stream_pointer */;
struct cons_pointer result = lisp_print( frame, oblist);
free_stack_frame( frame );
return result;
}
/** /**
* The read/eval/print loop * The read/eval/print loop
* @param in_stream the stream to read from; * @param in_stream the stream to read from;
@ -29,23 +77,21 @@
void void
repl( FILE * in_stream, FILE * out_stream, FILE * error_stream, repl( FILE * in_stream, FILE * out_stream, FILE * error_stream,
bool show_prompt ) { bool show_prompt ) {
while ( !feof( in_stream ) ) { struct cons_pointer input_stream = make_read_stream(in_stream);
if ( show_prompt ) { struct cons_pointer output_stream = make_write_stream(out_stream);
fwprintf( out_stream, L"\n:: " );
}
struct cons_pointer input = read( in_stream );
fwprintf( error_stream, L"\nread {%d,%d}=> ", input.page,
input.offset );
print( error_stream, input );
struct stack_frame *frame = make_empty_frame( NULL, oblist ); while ( !feof( pointer2cell(input_stream).payload.stream.stream ) ) {
frame->arg[0] = input; if ( show_prompt ) {
struct cons_pointer value = lisp_eval( frame, oblist ); fwprintf( out_stream, L"\n:: " );
free_stack_frame( frame ); }
// print( out_stream, input );
fwprintf( out_stream, L"\n" ); struct cons_pointer val = repl_eval( repl_read( input_stream));
fwprintf( error_stream, L"\neval {%d,%d}=> ", input.page,
input.offset ); /* suppress the 'end of stream' exception */
print( out_stream, value ); if ( exceptionp(val) &&
!feof( pointer2cell( input_stream).payload.stream.stream ) )
{
repl_print( output_stream, val);
}
} }
} }

12
src/stack.c
View file

@ -84,17 +84,25 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous,
struct stack_frame *arg_frame = make_empty_frame( previous, env ); struct stack_frame *arg_frame = make_empty_frame( previous, env );
arg_frame->arg[0] = cell.payload.cons.car; arg_frame->arg[0] = cell.payload.cons.car;
inc_ref( arg_frame->arg[0] ); inc_ref( arg_frame->arg[0] );
result->arg[i] = lisp_eval( arg_frame, env ); struct cons_pointer val = lisp_eval( arg_frame, env );
inc_ref( result->arg[i] ); if (pointer2cell(val).tag.value == EXCEPTIONTV) {
result->arg[0] = val;
break;
} else {
result->arg[i] = val;
}
inc_ref(val);
free_stack_frame( arg_frame ); free_stack_frame( arg_frame );
args = cell.payload.cons.cdr; args = cell.payload.cons.cdr;
} }
if (!nilp( args)) {
/* /*
* TODO: this isn't right. These args should also each be evaled. * TODO: this isn't right. These args should also each be evaled.
*/ */
result->more = args; result->more = args;
inc_ref( result->more ); inc_ref( result->more );
}
return result; return result;
} }

4
unit-tests/string-allocation.sh
View file

@ -1,8 +1,8 @@
#!/bin/bash #!/bin/bash
value='"Fred"' value='"Fred"'
expected="String cell: character 'F'" expected="String cell: character 'F' (70)"
echo ${value} | target/psse -d 2>&1 | grep "${expected}" > /dev/null echo ${value} | target/psse -d 2>/dev/null | grep "${expected}" > /dev/null
if [ $? -eq 0 ] if [ $? -eq 0 ]
then then