There's an enormous lot of good stuff in this, but I've messed up print
almost certainly by writing a non-wide character to a wide stream.
This commit is contained in:
parent
7e40d65df0
commit
93b84087ce
2
Makefile
2
Makefile
|
|
@ -13,7 +13,7 @@ INC_DIRS := $(shell find $(SRC_DIRS) -type d)
|
|||
INC_FLAGS := $(addprefix -I,$(INC_DIRS))
|
||||
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
|
||||
LDFLAGS := -lm
|
||||
|
|
|
|||
|
|
@ -54,8 +54,9 @@ void make_cons_page( ) {
|
|||
for ( int i = 0; i < CONSPAGESIZE; i++ ) {
|
||||
struct cons_space_object *cell =
|
||||
&conspages[initialised_cons_pages]->cell[i];
|
||||
if ( initialised_cons_pages == 0 && i < 2 ) {
|
||||
if ( i == 0 ) {
|
||||
if ( initialised_cons_pages == 0 && i < 3 ) {
|
||||
switch ( i) {
|
||||
case 0:
|
||||
/*
|
||||
* initialise cell as NIL
|
||||
*/
|
||||
|
|
@ -64,7 +65,8 @@ void make_cons_page( ) {
|
|||
cell->payload.free.car = NIL;
|
||||
cell->payload.free.cdr = NIL;
|
||||
fwprintf( stderr, L"Allocated special cell NIL\n" );
|
||||
} else if ( i == 1 ) {
|
||||
break;
|
||||
case 1:
|
||||
/*
|
||||
* initialise cell as T
|
||||
*/
|
||||
|
|
@ -75,6 +77,17 @@ void make_cons_page( ) {
|
|||
cell->payload.free.cdr = ( struct cons_pointer ) {
|
||||
0, 1};
|
||||
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 {
|
||||
/*
|
||||
|
|
|
|||
|
|
@ -11,6 +11,7 @@
|
|||
#include <stdint.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <stdio.h>
|
||||
/*
|
||||
* wide characters
|
||||
*/
|
||||
|
|
@ -20,6 +21,7 @@
|
|||
#include "conspage.h"
|
||||
#include "consspaceobject.h"
|
||||
#include "print.h"
|
||||
#include "stack.h"
|
||||
|
||||
/**
|
||||
* 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.offset, cell.count );
|
||||
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:
|
||||
fwprintf( output,
|
||||
L"\t\tInteger cell: value %ld, count %u\n",
|
||||
cell.payload.integer.value, cell.count );
|
||||
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 READTV:
|
||||
fwprintf( output, L"\t\tInput stream\n");
|
||||
case REALTV:
|
||||
fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n",
|
||||
cell.payload.real.value, cell.count );
|
||||
break;
|
||||
case STRINGTV:
|
||||
if (cell.payload.string.character == 0) {
|
||||
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.cdr.page,
|
||||
cell.payload.string.cdr.offset, cell.count );
|
||||
fwprintf( output, L"\t\t value: " );
|
||||
print( output, pointer );
|
||||
fwprintf( output, L"\n" );
|
||||
fwprintf( output, L"\n" );}
|
||||
break;
|
||||
case SYMBOLTV:
|
||||
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.cdr.page,
|
||||
|
|
@ -141,6 +163,22 @@ struct cons_pointer make_cons( struct cons_pointer car,
|
|||
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.
|
||||
*/
|
||||
|
|
@ -217,6 +255,32 @@ make_special( struct cons_pointer src, struct cons_pointer ( *executable )
|
|||
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.
|
||||
*/
|
||||
|
|
|
|||
|
|
@ -53,6 +53,13 @@
|
|||
#define INTEGERTAG "INTR"
|
||||
#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.
|
||||
* 541870414
|
||||
|
|
@ -64,6 +71,7 @@
|
|||
* An open read stream.
|
||||
*/
|
||||
#define READTAG "READ"
|
||||
#define READTV 1145128274
|
||||
|
||||
/**
|
||||
* A real number.
|
||||
|
|
@ -106,6 +114,15 @@
|
|||
* An open write stream.
|
||||
*/
|
||||
#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
|
||||
|
|
@ -117,6 +134,11 @@
|
|||
*/
|
||||
#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
|
||||
*/
|
||||
|
|
@ -140,11 +162,21 @@
|
|||
*/
|
||||
#define consp(conspoint) (check_tag(conspoint,CONSTAG))
|
||||
|
||||
/**
|
||||
* 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))
|
||||
|
||||
/**
|
||||
* 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
|
||||
*/
|
||||
|
|
@ -235,6 +267,15 @@ struct cons_payload {
|
|||
struct cons_pointer cdr;
|
||||
};
|
||||
|
||||
/**
|
||||
* Payload of an exception.
|
||||
* 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
|
||||
|
|
@ -346,6 +387,10 @@ struct cons_space_object {
|
|||
* if tag == CONSTAG
|
||||
*/
|
||||
struct cons_payload cons;
|
||||
/*
|
||||
* if tag == EXCEPTIONTAG
|
||||
*/
|
||||
struct exception_payload exception;
|
||||
/*
|
||||
* if tag == FREETAG
|
||||
*/
|
||||
|
|
@ -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 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.
|
||||
|
|
@ -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 );
|
||||
|
||||
/**
|
||||
* 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.
|
||||
*/
|
||||
|
|
|
|||
|
|
@ -71,9 +71,10 @@ int main( int argc, char *argv[] ) {
|
|||
/*
|
||||
* privileged variables (keywords)
|
||||
*/
|
||||
|
||||
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( L"λ"), LAMBDA ); */
|
||||
deep_bind( c_string_to_lisp_symbol( "lambda"), LAMBDA );
|
||||
|
||||
/*
|
||||
* primitive function operations
|
||||
|
|
|
|||
|
|
@ -127,9 +127,6 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
|
|||
break;
|
||||
|
||||
case FUNCTIONTV:
|
||||
/*
|
||||
* actually, this is apply
|
||||
*/
|
||||
{
|
||||
struct stack_frame *next = make_stack_frame( frame, args, 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;
|
||||
}
|
||||
|
||||
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 ) ) {
|
||||
done = true;
|
||||
} else {
|
||||
lisp_throw( c_string_to_lisp_string
|
||||
result = lisp_throw( c_string_to_lisp_string
|
||||
( "Arguments to `cond` must be lists" ), frame );
|
||||
}
|
||||
}
|
||||
|
|
@ -494,8 +491,15 @@ struct cons_pointer
|
|||
lisp_throw( struct cons_pointer message, struct stack_frame *frame ) {
|
||||
fwprintf( stderr, L"\nERROR: " );
|
||||
print( stderr, message );
|
||||
fwprintf( stderr,
|
||||
L"\n\nAn exception was thrown and I've no idea what to do now\n" );
|
||||
struct cons_pointer result = NIL;
|
||||
|
||||
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
40
src/peano.c
|
|
@ -142,10 +142,46 @@ lisp_subtract( struct stack_frame *frame, struct cons_pointer env ) {
|
|||
} else if ( realp( frame->arg[0] ) && integerp( frame->arg[1] ) ) {
|
||||
result =
|
||||
make_real( arg0.payload.real.value -
|
||||
numeric_value( frame->arg[0] ) );
|
||||
} // else we have an error!
|
||||
numeric_value( frame->arg[1] ) );
|
||||
} 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.
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
73
src/print.c
73
src/print.c
|
|
@ -78,38 +78,45 @@ void print( FILE * output, struct cons_pointer pointer ) {
|
|||
* statement can ultimately be replaced by a switch, which will be neater.
|
||||
*/
|
||||
switch ( cell.tag.value ) {
|
||||
case CONSTV:
|
||||
print_list( output, pointer );
|
||||
break;
|
||||
case INTEGERTV:
|
||||
fwprintf( output, L"%ld", cell.payload.integer.value );
|
||||
break;
|
||||
case NILTV:
|
||||
fwprintf( output, L"nil" );
|
||||
break;
|
||||
case REALTV:
|
||||
fwprintf( output, L"%Lf", cell.payload.real.value );
|
||||
break;
|
||||
case STRINGTV:
|
||||
print_string( output, pointer );
|
||||
break;
|
||||
case SYMBOLTV:
|
||||
print_string_contents( output, pointer );
|
||||
break;
|
||||
case TRUETV:
|
||||
fwprintf( output, L"t" );
|
||||
break;
|
||||
case FUNCTIONTV:
|
||||
fwprintf( output, L"(Function)" );
|
||||
break;
|
||||
case SPECIALTV:
|
||||
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;
|
||||
case CONSTV:
|
||||
print_list( output, pointer );
|
||||
break;
|
||||
case EXCEPTIONTV:
|
||||
fwprintf( output, L"\nException: ");
|
||||
print_string_contents( output, cell.payload.exception.message);
|
||||
break;
|
||||
case INTEGERTV:
|
||||
fwprintf( output, L"%ld", cell.payload.integer.value );
|
||||
break;
|
||||
case LAMBDATV:
|
||||
fwprintf( output, L"lambda" /* "λ" */);
|
||||
break;
|
||||
case NILTV:
|
||||
fwprintf( output, L"nil" );
|
||||
break;
|
||||
case REALTV:
|
||||
fwprintf( output, L"%Lf", cell.payload.real.value );
|
||||
break;
|
||||
case STRINGTV:
|
||||
print_string( output, pointer );
|
||||
break;
|
||||
case SYMBOLTV:
|
||||
print_string_contents( output, pointer );
|
||||
break;
|
||||
case TRUETV:
|
||||
fwprintf( output, L"t" );
|
||||
break;
|
||||
case FUNCTIONTV:
|
||||
fwprintf( output, L"(Function)" );
|
||||
break;
|
||||
case SPECIALTV:
|
||||
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
25
src/read.c
|
|
@ -20,6 +20,7 @@
|
|||
#include "consspaceobject.h"
|
||||
#include "integer.h"
|
||||
#include "intern.h"
|
||||
#include "lispops.h"
|
||||
#include "print.h"
|
||||
#include "read.h"
|
||||
#include "real.h"
|
||||
|
|
@ -31,7 +32,7 @@
|
|||
*/
|
||||
|
||||
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_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
|
||||
* 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;
|
||||
|
||||
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 ) );
|
||||
|
||||
switch ( c ) {
|
||||
case EOF:
|
||||
result = lisp_throw( c_string_to_lisp_string
|
||||
( "End of input while reading" ), frame );
|
||||
break;
|
||||
case '\'':
|
||||
result = c_quote( read_continuation( input, fgetwc( input ) ) );
|
||||
result = c_quote( read_continuation( frame, input, fgetwc( input ) ) );
|
||||
break;
|
||||
case '(':
|
||||
result = read_list( input, fgetwc( input ) );
|
||||
result = read_list( frame, input, fgetwc( input ) );
|
||||
break;
|
||||
case '"':
|
||||
result = read_string( input, fgetwc( input ) );
|
||||
|
|
@ -75,7 +80,7 @@ struct cons_pointer read_continuation( FILE * input, wint_t initial ) {
|
|||
} else if ( iswblank( next ) ) {
|
||||
/* dotted pair. TODO: this isn't right, we
|
||||
* really need to backtrack up a level. */
|
||||
result = read_continuation( input, fgetwc( input ) );
|
||||
result = read_continuation( frame, input, fgetwc( input ) );
|
||||
} else {
|
||||
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
|
||||
* 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;
|
||||
|
||||
if ( initial != ')' ) {
|
||||
fwprintf( stderr, L"read_list starting '%C' (%d)\n", initial,
|
||||
initial );
|
||||
struct cons_pointer car = read_continuation( input, initial );
|
||||
result = make_cons( car, read_list( input, fgetwc( input ) ) );
|
||||
struct cons_pointer car = read_continuation( frame, input, initial );
|
||||
result = make_cons( car, read_list( frame, input, fgetwc( input ) ) );
|
||||
} else {
|
||||
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.
|
||||
*/
|
||||
struct cons_pointer read( FILE * input ) {
|
||||
return read_continuation( input, fgetwc( input ) );
|
||||
struct cons_pointer read(struct stack_frame *frame, FILE * input ) {
|
||||
return read_continuation( frame, input, fgetwc( input ) );
|
||||
}
|
||||
|
|
|
|||
|
|
@ -14,6 +14,6 @@
|
|||
/**
|
||||
* 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
|
||||
|
|
|
|||
80
src/repl.c
80
src/repl.c
|
|
@ -19,6 +19,54 @@
|
|||
#include "print.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
|
||||
* @param in_stream the stream to read from;
|
||||
|
|
@ -29,23 +77,21 @@
|
|||
void
|
||||
repl( FILE * in_stream, FILE * out_stream, FILE * error_stream,
|
||||
bool show_prompt ) {
|
||||
while ( !feof( in_stream ) ) {
|
||||
if ( show_prompt ) {
|
||||
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 cons_pointer input_stream = make_read_stream(in_stream);
|
||||
struct cons_pointer output_stream = make_write_stream(out_stream);
|
||||
|
||||
struct stack_frame *frame = make_empty_frame( NULL, oblist );
|
||||
frame->arg[0] = input;
|
||||
struct cons_pointer value = lisp_eval( frame, oblist );
|
||||
free_stack_frame( frame );
|
||||
// print( out_stream, input );
|
||||
fwprintf( out_stream, L"\n" );
|
||||
fwprintf( error_stream, L"\neval {%d,%d}=> ", input.page,
|
||||
input.offset );
|
||||
print( out_stream, value );
|
||||
while ( !feof( pointer2cell(input_stream).payload.stream.stream ) ) {
|
||||
if ( show_prompt ) {
|
||||
fwprintf( out_stream, L"\n:: " );
|
||||
}
|
||||
|
||||
struct cons_pointer val = repl_eval( repl_read( input_stream));
|
||||
|
||||
/* suppress the 'end of stream' exception */
|
||||
if ( exceptionp(val) &&
|
||||
!feof( pointer2cell( input_stream).payload.stream.stream ) )
|
||||
{
|
||||
repl_print( output_stream, val);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
|
|||
12
src/stack.c
12
src/stack.c
|
|
@ -84,17 +84,25 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous,
|
|||
struct stack_frame *arg_frame = make_empty_frame( previous, env );
|
||||
arg_frame->arg[0] = cell.payload.cons.car;
|
||||
inc_ref( arg_frame->arg[0] );
|
||||
result->arg[i] = lisp_eval( arg_frame, env );
|
||||
inc_ref( result->arg[i] );
|
||||
struct cons_pointer val = lisp_eval( arg_frame, env );
|
||||
if (pointer2cell(val).tag.value == EXCEPTIONTV) {
|
||||
result->arg[0] = val;
|
||||
break;
|
||||
} else {
|
||||
result->arg[i] = val;
|
||||
}
|
||||
inc_ref(val);
|
||||
free_stack_frame( arg_frame );
|
||||
|
||||
args = cell.payload.cons.cdr;
|
||||
}
|
||||
if (!nilp( args)) {
|
||||
/*
|
||||
* TODO: this isn't right. These args should also each be evaled.
|
||||
*/
|
||||
result->more = args;
|
||||
inc_ref( result->more );
|
||||
}
|
||||
|
||||
return result;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
#!/bin/bash
|
||||
|
||||
value='"Fred"'
|
||||
expected="String cell: character 'F'"
|
||||
echo ${value} | target/psse -d 2>&1 | grep "${expected}" > /dev/null
|
||||
expected="String cell: character 'F' (70)"
|
||||
echo ${value} | target/psse -d 2>/dev/null | grep "${expected}" > /dev/null
|
||||
|
||||
if [ $? -eq 0 ]
|
||||
then
|
||||
|
|
|
|||
Loading…
Reference in a new issue