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

Merge branch 'release/0.0.3'

Browse source
This commit is contained in:
Simon Brooke 2018-12-21 21:40:29 +00:00
parent 7e40d65df0 71b9a61814
commit 614e20ab45
33 changed files with 1502 additions and 498 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
.gitignore vendored
View file

@ -18,3 +18,13 @@ src/\.#*
post-scarcity\.iml
doc/
log*
\.cproject
\.gdb_history
\.project
\.settings/language\.settings\.xml

14
Makefile
View file

@ -1,4 +1,3 @@
TARGET ?= target/psse
SRC_DIRS ?= ./src
@ -11,9 +10,12 @@ TESTS := $(shell find unit-tests -name *.sh)
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"
INDENT_FLAGS := -nbad -bap -nbc -br -brf -brs -c33 -cd33 -ncdb -ce -ci4 -cli4 \
-d0 -di1 -nfc1 -i4 -ip0 -l75 -lp -npcs \
-npsl -nsc -nsob -nss -nut -prs -l79 -ts2
VERSION := "0.0.2"
CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g
LDFLAGS := -lm
@ -25,14 +27,18 @@ doc: $(SRCS) Makefile
doxygen
format: $(SRCS) $(HDRS) Makefile
ifeq ($(shell uname -s), Darwin)
gindent $(INDENT_FLAGS) $(SRCS) $(HDRS)
else
indent $(INDENT_FLAGS) $(SRCS) $(HDRS)
endif
test: $(OBJS) $(TESTS) Makefile
bash ./unit-tests.sh
.PHONY: clean
clean:
$(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~
$(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ *~
repl:
$(TARGET) -p 2> psse.log

28
lisp/defun.lisp Normal file
View file

@ -0,0 +1,28 @@
;; Because I don't (yet) have syntax for varargs, the body must be passed
;; to defun as a list of sexprs.
(set! defun!
(nlambda
form
(cond ((symbolp (car form))
(set (car form) (apply lambda (cdr form))))
(t nil))))
(defun! square (x) (* x x))
(set! defsp!
(nlambda
form
(cond (symbolp (car form))
(set! (car form) (apply nlambda (cdr form))))))
(defsp! cube (x) ((* x x x)))
(set! p 5)
(square 5) ;; should work
(square p) ;; should work
(cube 5) ;; should work
(cube p) ;; should fail: unbound symbol

4
lisp/fact.lisp Normal file
View file

@ -0,0 +1,4 @@
(set! fact
(lambda (n)
(cond ((= n 1) 1)
(t (* n (fact (- n 1)))))))

45
src/conspage.c
View file

@ -55,7 +55,8 @@ void make_cons_page( ) {
struct cons_space_object *cell =
&conspages[initialised_cons_pages]->cell[i];
if ( initialised_cons_pages == 0 && i < 2 ) {
if ( i == 0 ) {
switch ( i ) {
case 0:
/*
* initialise cell as NIL
*/
@ -64,17 +65,21 @@ 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
*/
strncpy( &cell->tag.bytes[0], TRUETAG, TAGLENGTH );
cell->count = MAXREFERENCE;
cell->payload.free.car = ( struct cons_pointer ) {
0, 1};
0, 1
};
cell->payload.free.cdr = ( struct cons_pointer ) {
0, 1};
0, 1
};
fwprintf( stderr, L"Allocated special cell T\n" );
break;
}
} else {
/*
@ -107,7 +112,8 @@ void dump_pages( FILE * output ) {
for ( int j = 0; j < CONSPAGESIZE; j++ ) {
dump_object( output, ( struct cons_pointer ) {
i, j} );
i, j
} );
}
}
}
@ -121,9 +127,36 @@ void dump_pages( FILE * output ) {
void free_cell( struct cons_pointer pointer ) {
struct cons_space_object *cell = &pointer2cell( pointer );
switch ( cell->tag.value ) {
/* for all the types of cons-space object which point to other
* cons-space objects, cascade the decrement. */
case CONSTV:
dec_ref( cell->payload.cons.car );
dec_ref( cell->payload.cons.cdr );
break;
case EXCEPTIONTV:
dec_ref( cell->payload.exception.message );
break;
case FUNCTIONTV:
dec_ref( cell->payload.function.source );
break;
case LAMBDATV:
case NLAMBDATV:
dec_ref( cell->payload.lambda.args );
dec_ref( cell->payload.lambda.body );
break;
case SPECIALTV:
dec_ref( cell->payload.special.source );
break;
case STRINGTV:
case SYMBOLTV:
dec_ref( cell->payload.string.cdr );
break;
}
if ( !check_tag( pointer, FREETAG ) ) {
if ( cell->count == 0 ) {
fwprintf( stderr, L"Freeing cell\n" );
fwprintf( stderr, L"Freeing cell " );
dump_object( stderr, pointer );
strncpy( &cell->tag.bytes[0], FREETAG, 4 );
cell->payload.free.car = NIL;

157
src/consspaceobject.c
View file

@ -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
@ -61,13 +63,36 @@ void dec_ref( struct cons_pointer pointer ) {
}
}
void dump_string_cell( FILE * output, wchar_t *prefix,
struct cons_pointer pointer ) {
struct cons_space_object cell = pointer2cell( pointer );
if ( cell.payload.string.character == 0 ) {
fwprintf( output,
L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n",
prefix,
cell.payload.string.cdr.page, cell.payload.string.cdr.offset,
cell.count );
} else {
fwprintf( output,
L"\t\t%ls cell: character '%lc' (%d) next at page %d offset %d, count %u\n",
prefix,
( wint_t ) 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" );
}
}
/**
* dump the object at this cons_pointer to this output stream.
*/
void dump_object( FILE * output, struct cons_pointer pointer ) {
struct cons_space_object cell = pointer2cell( pointer );
fwprintf( output,
L"\tDumping %c%c%c%c (%d) at page %d, offset %d count %u\n",
L"\t%c%c%c%c (%d) at page %d, offset %d count %u\n",
cell.tag.bytes[0],
cell.tag.bytes[1],
cell.tag.bytes[2],
@ -83,40 +108,42 @@ 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" );
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 );
case LAMBDATV:
fwprintf( output, L"\t\tLambda cell; args: " );
print( output, cell.payload.lambda.args );
fwprintf( output, L";\n\t\t\tbody: " );
print( output, cell.payload.lambda.body );
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:
fwprintf( output,
L"\t\tString cell: character '%c' (%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" );
dump_string_cell( output, L"String", pointer );
break;
case SYMBOLTV:
fwprintf( output,
L"\t\tSymbol cell: character '%c' (%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" );
dump_string_cell( output, L"Symbol", pointer );
break;
}
}
@ -130,8 +157,7 @@ struct cons_pointer make_cons( struct cons_pointer car,
pointer = allocate_cell( CONSTAG );
struct cons_space_object *cell =
&conspages[pointer.page]->cell[pointer.offset];
struct cons_space_object *cell = &pointer2cell( pointer );
inc_ref( car );
inc_ref( cdr );
@ -141,6 +167,26 @@ 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 );
inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */
inc_ref( message );
cell->payload.exception.message = message;
cell->payload.exception.frame = frame;
return pointer;
}
/**
* Construct a cell which points to an executable Lisp special form.
*/
@ -156,6 +202,43 @@ make_function( struct cons_pointer src, struct cons_pointer ( *executable )
return pointer;
}
/**
* Construct a lambda (interpretable source) cell
*/
struct cons_pointer make_lambda( struct cons_pointer args,
struct cons_pointer body ) {
struct cons_pointer pointer = allocate_cell( LAMBDATAG );
struct cons_space_object *cell = &pointer2cell( pointer );
inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */
inc_ref( args );
inc_ref( body );
cell->payload.lambda.args = args;
cell->payload.lambda.body = body;
return pointer;
}
/**
* Construct an nlambda (interpretable source) cell; to a
* lambda as a special form is to a function.
*/
struct cons_pointer make_nlambda( struct cons_pointer args,
struct cons_pointer body ) {
struct cons_pointer pointer = allocate_cell( NLAMBDATAG );
inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */
struct cons_space_object *cell = &pointer2cell( pointer );
inc_ref( args );
inc_ref( body );
cell->payload.lambda.args = args;
cell->payload.lambda.body = body;
return pointer;
}
/**
* 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
@ -217,6 +300,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.
*/

93
src/consspaceobject.h
View file

@ -34,6 +34,13 @@
#define CONSTAG "CONS"
#define CONSTV 1397641027
/**
* An exception.
*/
#define EXCEPTIONTAG "EXEP"
/* TODO: this is wrong */
#define EXCEPTIONTV 1346721861
/**
* An unallocated cell on the free list - should never be encountered by a Lisp
* function. 1162170950
@ -53,6 +60,12 @@
#define INTEGERTAG "INTR"
#define INTEGERTV 1381256777
/**
* A lambda cell.
*/
#define LAMBDATAG "LMDA"
#define LAMBDATV 1094995276
/**
* The special cons cell at address {0,0} whose car and cdr both point to itself.
* 541870414
@ -60,10 +73,17 @@
#define NILTAG "NIL "
#define NILTV 541870414
/**
* An nlambda cell.
*/
#define NLAMBDATAG "NLMD"
#define NLAMBDATV 1145916494
/**
* An open read stream.
*/
#define READTAG "READ"
#define READTV 1145128274
/**
* A real number.
@ -106,6 +126,8 @@
* An open write stream.
*/
#define WRITETAG "WRIT"
/* TODO: this is wrong */
#define WRITETV 1414091351
/**
* a cons pointer which points to the special NIL cell
@ -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 a 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
@ -268,11 +309,18 @@ struct integer_payload {
long int value;
};
/**
* payload for lambda and nlambda cells
*/
struct lambda_payload {
struct cons_pointer args;
struct cons_pointer body;
};
/**
* payload for a real number cell. Internals of this liable to change to give 128 bits
* precision, but I'm not sure of the detail.
*/
struct real_payload {
*/ struct real_payload {
long double value;
};
@ -346,6 +394,10 @@ struct cons_space_object {
* if tag == CONSTAG
*/
struct cons_payload cons;
/*
* if tag == EXCEPTIONTAG
*/
struct exception_payload exception;
/*
* if tag == FREETAG
*/
@ -358,6 +410,10 @@ struct cons_space_object {
* if tag == INTEGERTAG
*/
struct integer_payload integer;
/*
* if tag == LAMBDATAG or NLAMBDATAG
*/
struct lambda_payload lambda;
/*
* if tag == NILTAG; we'll treat the special cell NIL as just a cons
*/
@ -411,6 +467,13 @@ 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.
@ -420,6 +483,19 @@ struct cons_pointer make_function( struct cons_pointer src,
( struct stack_frame *,
struct cons_pointer ) );
/**
* Construct a lambda (interpretable source) cell
*/
struct cons_pointer make_lambda( struct cons_pointer args,
struct cons_pointer body );
/**
* Construct an nlambda (interpretable source) cell; to a
* lambda as a special form is to a function.
*/
struct cons_pointer make_nlambda( struct cons_pointer args,
struct cons_pointer body );
/**
* Construct a cell which points to an executable Lisp special form.
*/
@ -441,6 +517,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.
*/

12
src/equal.c
View file

@ -60,9 +60,12 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
switch ( cell_a->tag.value ) {
case CONSTV:
case LAMBDATV:
case NLAMBDATV:
result =
equal( cell_a->payload.cons.car, cell_b->payload.cons.car )
&& equal( cell_a->payload.cons.cdr, cell_b->payload.cons.cdr );
&& equal( cell_a->payload.cons.cdr,
cell_b->payload.cons.cdr );
break;
case STRINGTV:
case SYMBOLTV:
@ -77,9 +80,14 @@ 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 =
cell_a->payload.integer.value ==
cell_b->payload.integer.value;
break;
case REALTV:
{
double num_a = numeric_value( a );

20
src/init.c
View file

@ -46,8 +46,11 @@ int main( int argc, char *argv[] ) {
bool dump_at_end = false;
bool show_prompt = false;
while ( ( option = getopt( argc, argv, "pd" ) ) != -1 ) {
while ( ( option = getopt( argc, argv, "pdc" ) ) != -1 ) {
switch ( option ) {
case 'c':
print_use_colours = true;
break;
case 'd':
dump_at_end = true;
break;
@ -71,7 +74,6 @@ 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 );
@ -84,30 +86,34 @@ int main( int argc, char *argv[] ) {
bind_function( "car", &lisp_car );
bind_function( "cdr", &lisp_cdr );
bind_function( "cons", &lisp_cons );
bind_function( "divide", &lisp_divide );
bind_function( "eq", &lisp_eq );
bind_function( "equal", &lisp_equal );
bind_function( "eval", &lisp_eval );
bind_function( "multiply", &lisp_multiply );
bind_function( "read", &lisp_read );
bind_function( "oblist", &lisp_oblist );
bind_function( "print", &lisp_print );
bind_function( "progn", &lisp_progn );
bind_function( "set", &lisp_set );
bind_function( "subtract", &lisp_subtract );
bind_function( "type", &lisp_type );
bind_function( "+", &lisp_add );
bind_function( "*", &lisp_multiply );
bind_function( "-", &lisp_subtract );
bind_function( "/", &lisp_divide );
bind_function( "=", &lisp_equal );
/*
* primitive special forms
*/
bind_special( "cond", &lisp_cond );
bind_special( "lambda", &lisp_lambda );
bind_special( "nlambda", &lisp_nlambda );
bind_special( "progn", &lisp_progn );
bind_special( "quote", &lisp_quote );
/* bind the oblist last, at this stage. Something clever needs to be done
* here and I'm not sure what it is. */
deep_bind( c_string_to_lisp_symbol( "oblist" ), oblist );
bind_special( "set!", &lisp_set_shriek );
repl( stdin, stdout, stderr, show_prompt );

2
src/integer.c
View file

@ -21,7 +21,7 @@
* but only integers and reals are so far implemented.
*/
long double numeric_value( struct cons_pointer pointer ) {
double result = NAN;
long double result = NAN;
struct cons_space_object *cell = &pointer2cell( pointer );
if ( integerp( pointer ) ) {

1
src/intern.c
View file

@ -133,7 +133,6 @@ struct cons_pointer
intern( struct cons_pointer key, struct cons_pointer environment ) {
struct cons_pointer result = environment;
struct cons_pointer canonical = internedp( key, environment );
if ( nilp( canonical ) ) {
/*
* not currently bound

350
src/lispops.c
View file

@ -63,7 +63,7 @@ struct cons_pointer c_car( struct cons_pointer arg ) {
struct cons_pointer c_cdr( struct cons_pointer arg ) {
struct cons_pointer result = NIL;
if ( consp( arg ) ) {
if ( consp( arg ) || stringp( arg ) || symbolp( arg ) ) {
result = pointer2cell( arg ).payload.cons.cdr;
}
@ -91,7 +91,141 @@ struct cons_pointer eval_form( struct stack_frame *parent,
next->arg[0] = form;
inc_ref( next->arg[0] );
result = lisp_eval( next, env );
if ( !exceptionp( result ) ) {
/* if we're returning an exception, we should NOT free the
* stack frame. Corollary is, when we free an exception, we
* should free all the frames it's holding on to. */
free_stack_frame( next );
}
return result;
}
/**
* eval all the forms in this `list` in the context of this stack `frame`
* and this `env`, and return a list of their values. If the arg passed as
* `list` is not in fact a list, return nil.
*/
struct cons_pointer eval_forms( struct stack_frame *frame,
struct cons_pointer list,
struct cons_pointer env ) {
return consp( list ) ?
make_cons( eval_form( frame, c_car( list ), env ),
eval_forms( frame, c_cdr( list ), env ) ) : NIL;
}
/**
* Return the object list (root namespace).
*
* (oblist)
*/
struct cons_pointer
lisp_oblist( struct stack_frame *frame, struct cons_pointer env ) {
return oblist;
}
/**
* used to construct the body for `lambda` and `nlambda` expressions.
*/
struct cons_pointer compose_body( struct stack_frame *frame ) {
struct cons_pointer body =
!nilp( frame->arg[args_in_frame - 1] ) ? frame->more : NIL;
for ( int i = args_in_frame - 1; i > 0; i-- ) {
if ( !nilp( body ) ) {
body = make_cons( frame->arg[i], body );
} else if ( !nilp( frame->arg[i] ) ) {
body = make_cons( frame->arg[i], body );
}
}
fputws( L"compose_body returning ", stderr );
print( stderr, body );
fputws( L"\n", stderr );
return body;
}
/**
* Construct an interpretable function.
*
* @param frame the stack frame in which the expression is to be interpreted;
* @param env the environment in which it is to be intepreted.
*/
struct cons_pointer
lisp_lambda( struct stack_frame *frame, struct cons_pointer env ) {
return make_lambda( frame->arg[0], compose_body( frame ) );
}
/**
* Construct an interpretable special form.
*
* @param frame the stack frame in which the expression is to be interpreted;
* @param env the environment in which it is to be intepreted.
*/
struct cons_pointer
lisp_nlambda( struct stack_frame *frame, struct cons_pointer env ) {
return make_nlambda( frame->arg[0], compose_body( frame ) );
}
void log_binding( struct cons_pointer name, struct cons_pointer val ) {
print( stderr, c_string_to_lisp_string( "\n\tBinding " ) );
print( stderr, name );
print( stderr, c_string_to_lisp_string( " to " ) );
print( stderr, val );
fputws( L"\"\n", stderr );
}
/**
* Evaluate a lambda or nlambda expression.
*/
struct cons_pointer
eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
struct cons_pointer env ) {
struct cons_pointer result = NIL;
fwprintf( stderr, L"eval_lambda called\n" );
struct cons_pointer new_env = env;
struct cons_pointer names = cell.payload.lambda.args;
struct cons_pointer body = cell.payload.lambda.body;
if ( consp( names ) ) {
/* if `names` is a list, bind successive items from that list
* to values of arguments */
for ( int i = 0; i < args_in_frame && consp( names ); i++ ) {
struct cons_pointer name = c_car( names );
struct cons_pointer val = frame->arg[i];
new_env = bind( name, val, new_env );
log_binding( name, val );
names = c_cdr( names );
}
} else if ( symbolp( names ) ) {
/* if `names` is a symbol, rather than a list of symbols,
* then bind a list of the values of args to that symbol. */
struct cons_pointer vals = frame->more;
for ( int i = args_in_frame - 1; i >= 0; i-- ) {
struct cons_pointer val = eval_form( frame, frame->arg[i], env );
if ( nilp( val ) && nilp( vals ) ) { /* nothing */
} else {
vals = make_cons( val, vals );
}
}
new_env = bind( names, vals, new_env );
}
while ( !nilp( body ) ) {
struct cons_pointer sexpr = c_car( body );
body = c_cdr( body );
fputws( L"In lambda: ", stderr );
result = eval_form( frame, sexpr, new_env );
}
return result;
}
@ -107,36 +241,88 @@ struct cons_pointer eval_form( struct stack_frame *parent,
struct cons_pointer
c_apply( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer result = NIL;
struct stack_frame *fn_frame = make_empty_frame( frame, env );
fn_frame->arg[0] = c_car( frame->arg[0] );
inc_ref( fn_frame->arg[0] );
struct cons_pointer fn_pointer = lisp_eval( fn_frame, env );
if ( !exceptionp( result ) ) {
/* if we're returning an exception, we should NOT free the
* stack frame. Corollary is, when we free an exception, we
* should free all the frames it's holding on to. */
free_stack_frame( fn_frame );
}
struct cons_space_object fn_cell = pointer2cell( fn_pointer );
struct cons_pointer args = c_cdr( frame->arg[0] );
switch ( fn_cell.tag.value ) {
case EXCEPTIONTV:
/* just pass exceptions straight back */
result = fn_pointer;
break;
case FUNCTIONTV:
{
struct cons_pointer exep = NIL;
struct stack_frame *next =
make_stack_frame( frame, args, env, &exep );
result = ( *fn_cell.payload.special.executable ) ( next, env );
if ( exceptionp( exep ) ) {
/* if we're returning an exception, we should NOT free the
* stack frame. Corollary is, when we free an exception, we
* should free all the frames it's holding on to. */
result = exep;
} else {
free_stack_frame( next );
}
}
break;
case LAMBDATV:
{
struct cons_pointer exep = NIL;
struct stack_frame *next =
make_stack_frame( frame, args, env, &exep );
fputws( L"Stack frame for lambda\n", stderr );
dump_frame( stderr, next );
result = eval_lambda( fn_cell, next, env );
if ( exceptionp( result ) ) {
/* if we're returning an exception, we should NOT free the
* stack frame. Corollary is, when we free an exception, we
* should free all the frames it's holding on to. */
result = exep;
} else {
free_stack_frame( next );
}
}
break;
case NLAMBDATV:
{
struct stack_frame *next =
make_special_frame( frame, args, env );
fputws( L"Stack frame for nlambda\n", stderr );
dump_frame( stderr, next );
result = eval_lambda( fn_cell, next, env );
if ( !exceptionp( result ) ) {
/* if we're returning an exception, we should NOT free the
* stack frame. Corollary is, when we free an exception, we
* should free all the frames it's holding on to. */
free_stack_frame( next );
}
}
break;
case SPECIALTV:
{
struct stack_frame *next = make_special_frame( frame, args, env );
struct stack_frame *next =
make_special_frame( frame, args, env );
result = ( *fn_cell.payload.special.executable ) ( next, env );
if ( !exceptionp( result ) ) {
/* if we're returning an exception, we should NOT free the
* stack frame. Corollary is, when we free an exception, we
* should free all the frames it's holding on to. */
free_stack_frame( next );
}
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 );
free_stack_frame( next );
}
break;
default:
{
char *buffer = malloc( 1024 );
@ -146,7 +332,8 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
fn_cell.tag.value, fn_cell.tag.bytes[0],
fn_cell.tag.bytes[1], fn_cell.tag.bytes[2],
fn_cell.tag.bytes[3] );
struct cons_pointer message = c_string_to_lisp_string( buffer );
struct cons_pointer message =
c_string_to_lisp_string( buffer );
free( buffer );
result = lisp_throw( message, frame );
}
@ -197,29 +384,38 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
switch ( cell.tag.value ) {
case CONSTV:
{
result = c_apply( frame, env );
}
break;
case SYMBOLTV:
{
struct cons_pointer canonical = internedp( frame->arg[0], env );
struct cons_pointer canonical =
internedp( frame->arg[0], env );
if ( nilp( canonical ) ) {
struct cons_pointer message =
c_string_to_lisp_string
( "Attempt to take value of unbound symbol." );
make_cons( c_string_to_lisp_string
( "Attempt to take value of unbound symbol." ),
frame->arg[0] );
result = lisp_throw( message, frame );
} else {
result = c_assoc( canonical, env );
inc_ref( result );
}
}
break;
/*
* TODO:
* the Clojure practice of having a map serve in the function place of
* an s-expression is a good one and I should adopt it; also if the
* object is a consp it could be interpretable source code but in the
* long run I don't want an interpreter, and if I can get away without
* so much the better.
*/
default:
result = frame->arg[0];
break;
}
fputws( L"Eval returning ", stderr );
@ -268,6 +464,67 @@ lisp_quote( struct stack_frame *frame, struct cons_pointer env ) {
return frame->arg[0];
}
/**
* (set name value)
* (set name value namespace)
*
* Function.
* `namespace` defaults to the oblist.
* Binds the value of `name` in the `namespace` to value of `value`, altering
* the namespace in so doing. `namespace` defaults to the value of `oblist`.
*/
struct cons_pointer
lisp_set( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer result = NIL;
struct cons_pointer namespace =
nilp( frame->arg[2] ) ? oblist : frame->arg[2];
if ( symbolp( frame->arg[0] ) ) {
deep_bind( frame->arg[0], frame->arg[1] );
result = frame->arg[1];
} else {
result =
make_exception( make_cons
( c_string_to_lisp_string
( "The first argument to `set!` is not a symbol: " ),
make_cons( frame->arg[0], NIL ) ), frame );
}
return result;
}
/**
* (set! symbol value)
* (set! symbol value namespace)
*
* Special form.
* `namespace` defaults to the oblist.
* Binds `symbol` in the `namespace` to value of `value`, altering
* the namespace in so doing. `namespace` defaults to the value of `oblist`.
*/
struct cons_pointer
lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer result = NIL;
struct cons_pointer namespace =
nilp( frame->arg[2] ) ? oblist : frame->arg[2];
if ( symbolp( frame->arg[0] ) ) {
struct cons_pointer val = eval_form( frame, frame->arg[1], env );
deep_bind( frame->arg[0], val );
result = val;
} else {
result =
make_exception( make_cons
( c_string_to_lisp_string
( "The first argument to `set!` is not a symbol: " ),
make_cons( frame->arg[0], NIL ) ), frame );
}
return result;
}
/**
* (cons a b)
*
@ -384,7 +641,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 );
}
@ -421,7 +678,9 @@ lisp_type( struct stack_frame *frame, struct cons_pointer env ) {
/**
* Function; evaluate the forms which are listed in my single argument
* (progn forms...)
*
* Special form; evaluate the forms which are listed in my arguments
* sequentially and return the value of the last. This function is called 'do'
* in some dialects of Lisp.
*
@ -432,14 +691,17 @@ lisp_type( struct stack_frame *frame, struct cons_pointer env ) {
*/
struct cons_pointer
lisp_progn( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer remaining = frame->arg[0];
struct cons_pointer remaining = frame->more;
struct cons_pointer result = NIL;
while ( consp( remaining ) ) {
struct cons_space_object cell = pointer2cell( remaining );
result = eval_form( frame, cell.payload.cons.car, env );
for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) {
result = eval_form( frame, frame->arg[i], env );
}
remaining = cell.payload.cons.cdr;
while ( consp( remaining ) ) {
result = eval_form( frame, c_car( remaining ), env );
remaining = c_cdr( remaining );
}
return result;
@ -466,19 +728,25 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) {
if ( consp( clause_pointer ) ) {
struct cons_space_object cell = pointer2cell( clause_pointer );
result = eval_form( frame, c_car( clause_pointer ), env );
if ( !nilp( result ) ) {
struct cons_pointer vals =
eval_forms( frame, c_cdr( clause_pointer ), env );
while ( consp( vals ) ) {
result = c_car( vals );
vals = c_cdr( vals );
}
if ( !nilp( eval_form( frame, cell.payload.cons.car, env ) ) ) {
struct stack_frame *next = make_empty_frame( frame, env );
next->arg[0] = cell.payload.cons.cdr;
inc_ref( next->arg[0] );
result = lisp_progn( next, env );
done = true;
}
} else if ( nilp( clause_pointer ) ) {
done = true;
} else {
lisp_throw( c_string_to_lisp_string
( "Arguments to `cond` must be lists" ), frame );
result = lisp_throw( c_string_to_lisp_string
( "Arguments to `cond` must be lists" ),
frame );
}
}
/* TODO: if there are more than 8 clauses we need to continue into the
@ -489,13 +757,25 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) {
/**
* TODO: make this do something sensible somehow.
* This requires that a frame be a heap-space object with a cons-space
* object pointing to it. Then this should become a normal lisp function
* which expects a normally bound frame and environment, such that
* frame->arg[0] is the message, and frame->arg[1] is the cons-space
* pointer to the frame in which the exception occurred.
*/
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;
}

62
src/lispops.h
View file

@ -30,6 +30,39 @@
*/
struct cons_pointer c_type( struct cons_pointer pointer );
/**
* Implementation of car in C. If arg is not a cons, does not error but returns nil.
*/
struct cons_pointer c_car( struct cons_pointer arg );
/**
* Implementation of cdr in C. If arg is not a cons, does not error but returns nil.
*/
struct cons_pointer c_cdr( struct cons_pointer arg );
/**
* Useful building block; evaluate this single form in the context of this
* parent stack frame and this environment.
* @param parent the parent stack frame.
* @param form the form to be evaluated.
* @param env the evaluation environment.
* @return the result of evaluating the form.
*/
struct cons_pointer eval_form( struct stack_frame *parent,
struct cons_pointer form,
struct cons_pointer env );
/**
* eval all the forms in this `list` in the context of this stack `frame`
* and this `env`, and return a list of their values. If the arg passed as
* `list` is not in fact a list, return nil.
*/
struct cons_pointer eval_forms( struct stack_frame *frame,
struct cons_pointer list,
struct cons_pointer env );
/*
* special forms
*/
@ -37,6 +70,35 @@ struct cons_pointer lisp_eval( struct stack_frame *frame,
struct cons_pointer env );
struct cons_pointer lisp_apply( struct stack_frame *frame,
struct cons_pointer env );
struct cons_pointer
lisp_oblist( struct stack_frame *frame, struct cons_pointer env );
struct cons_pointer
lisp_set( struct stack_frame *frame, struct cons_pointer env );
struct cons_pointer
lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env );
/**
* Construct an interpretable function.
*
* @param frame the stack frame in which the expression is to be interpreted;
* @param lexpr the lambda expression to be interpreted;
* @param env the environment in which it is to be intepreted.
*/
struct cons_pointer lisp_lambda( struct stack_frame *frame,
struct cons_pointer env );
/**
* Construct an interpretable special form.
*
* @param frame the stack frame in which the expression is to be interpreted;
* @param env the environment in which it is to be intepreted.
*/
struct cons_pointer
lisp_nlambda( struct stack_frame *frame, struct cons_pointer env );
struct cons_pointer lisp_quote( struct stack_frame *frame,
struct cons_pointer env );

164
src/peano.c
View file

@ -25,6 +25,36 @@
#include "real.h"
#include "stack.h"
/**
* Internal guts of add. Dark and mysterious.
*/
struct cons_pointer add_accumulate( struct cons_pointer arg,
struct stack_frame *frame,
long int *i_accumulator,
long double *d_accumulator, int *is_int ) {
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( arg );
switch ( cell.tag.value ) {
case INTEGERTV:
( *i_accumulator ) += cell.payload.integer.value;
( *d_accumulator ) += numeric_value( arg );
break;
case REALTV:
( *d_accumulator ) += cell.payload.real.value;
( *is_int ) &= false;
break;
case EXCEPTIONTV:
result = arg;
break;
default:
result = lisp_throw( c_string_to_lisp_string
( "Cannot multiply: not a number" ), frame );
}
return result;
}
/**
* Add an indefinite number of numbers together
* @param env the evaluation environment - ignored;
@ -36,28 +66,21 @@ lisp_add( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer result = NIL;
long int i_accumulator = 0;
long double d_accumulator = 0;
bool is_int = true;
int is_int = true;
for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) {
struct cons_space_object current = pointer2cell( frame->arg[i] );
switch ( current.tag.value ) {
case INTEGERTV:
i_accumulator += current.payload.integer.value;
d_accumulator += numeric_value( frame->arg[i] );
break;
case REALTV:
d_accumulator += current.payload.real.value;
is_int = false;
break;
default:
lisp_throw( c_string_to_lisp_string( "Cannot add: not a number" ),
frame );
result =
add_accumulate( frame->arg[i], frame, &i_accumulator,
&d_accumulator, &is_int );
}
if ( !nilp( frame->more ) ) {
lisp_throw( c_string_to_lisp_string
( "Cannot yet add more than 8 numbers" ), frame );
struct cons_pointer more = frame->more;
while ( consp( more ) ) {
result =
add_accumulate( c_car( more ), frame, &i_accumulator,
&d_accumulator, &is_int );
more = c_cdr( more );
}
if ( is_int ) {
@ -65,8 +88,37 @@ lisp_add( struct stack_frame *frame, struct cons_pointer env ) {
} else {
result = make_real( d_accumulator );
}
return result;
}
/**
* Internal guts of multiply. Dark and mysterious.
*/
struct cons_pointer multiply_accumulate( struct cons_pointer arg,
struct stack_frame *frame,
long int *i_accumulator,
long double *d_accumulator,
int *is_int ) {
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( arg );
switch ( cell.tag.value ) {
case INTEGERTV:
( *i_accumulator ) *= cell.payload.integer.value;
( *d_accumulator ) *= numeric_value( arg );
break;
case REALTV:
( *d_accumulator ) *= cell.payload.real.value;
( *is_int ) &= false;
break;
case EXCEPTIONTV:
result = arg;
break;
default:
result = lisp_throw( c_string_to_lisp_string
( "Cannot multiply: not a number" ), frame );
}
return result;
}
@ -81,30 +133,26 @@ lisp_multiply( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer result = NIL;
long int i_accumulator = 1;
long double d_accumulator = 1;
bool is_int = true;
int is_int = true;
for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) {
struct cons_space_object arg = pointer2cell( frame->arg[i] );
switch ( arg.tag.value ) {
case INTEGERTV:
i_accumulator *= arg.payload.integer.value;
d_accumulator *= numeric_value( frame->arg[i] );
break;
case REALTV:
d_accumulator *= arg.payload.real.value;
is_int = false;
break;
default:
lisp_throw( c_string_to_lisp_string
( "Cannot multiply: not a number" ), frame );
for ( int i = 0;
i < args_in_frame && !nilp( frame->arg[i] ) && !exceptionp( result );
i++ ) {
result =
multiply_accumulate( frame->arg[i], frame, &i_accumulator,
&d_accumulator, &is_int );
}
if ( !nilp( frame->more ) ) {
lisp_throw( c_string_to_lisp_string
( "Cannot yet multiply more than 8 numbers" ), frame );
struct cons_pointer more = frame->more;
while ( consp( more ) && !exceptionp( result ) ) {
result =
multiply_accumulate( c_car( more ), frame, &i_accumulator,
&d_accumulator, &is_int );
more = c_cdr( more );
}
if ( !exceptionp( result ) ) {
if ( is_int ) {
result = make_integer( i_accumulator );
} else {
@ -142,10 +190,48 @@ 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 ( numberp( frame->arg[0] ) && numberp( frame->arg[1] ) ) {
long int i = ( long int ) numeric_value( frame->arg[0] ) /
numeric_value( frame->arg[1] );
long double r = ( long double ) numeric_value( frame->arg[0] ) /
numeric_value( frame->arg[1] );
if ( fabsl( ( long double ) i - r ) < 0.0000000001 ) {
result = make_integer( i );
} else {
result = make_real( r );
}
} else {
lisp_throw( c_string_to_lisp_string
( "Cannot divide: not a number" ), frame );
}
return result;
}

9
src/peano.h
View file

@ -43,6 +43,15 @@ extern "C" {
struct cons_pointer
lisp_subtract( struct stack_frame *frame, struct cons_pointer env );
/**
* 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 );
#ifdef __cplusplus
}
#endif

130
src/print.c
View file

@ -9,6 +9,7 @@
#include <ctype.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
/*
* wide characters
@ -21,18 +22,34 @@
#include "integer.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( FILE * output, struct cons_pointer pointer ) {
if ( stringp( pointer ) || symbolp( pointer ) ) {
while ( stringp( pointer ) || symbolp( pointer ) ) {
struct cons_space_object *cell = &pointer2cell( pointer );
wint_t c = cell->payload.string.character;
if ( c != '\0' ) {
fputwc( c, output );
}
print_string_contents( output, cell->payload.string.cdr );
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( FILE * output, struct cons_pointer pointer ) {
fputwc( btowc( '"' ), output );
print_string_contents( output, pointer );
@ -40,7 +57,9 @@ void print_string( FILE * output, struct cons_pointer pointer ) {
}
/**
* Print a single list cell (cons cell).
* 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( FILE * output, struct cons_pointer pointer,
@ -65,13 +84,28 @@ print_list_contents( FILE * output, struct cons_pointer pointer,
}
void print_list( FILE * output, struct cons_pointer pointer ) {
fputwc( btowc( '(' ), output );
if ( print_use_colours ) {
fwprintf( output, L"%s(%s", "\x1B[31m", "\x1B[39m" );
} else {
fputws( L"(", output );
};
print_list_contents( output, pointer, false );
fputwc( btowc( ')' ), output );
if ( print_use_colours ) {
fwprintf( output, L"%s)%s", "\x1B[31m", "\x1B[39m" );
} else {
fputws( L")", output );
}
}
/**
* Print the cons-space object indicated by `pointer` to the stream indicated
* by `output`.
*/
void print( 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
@ -81,35 +115,85 @@ void print( FILE * output, struct cons_pointer pointer ) {
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" );
case EXCEPTIONTV:
fwprintf( output, L"\n%sException: ",
print_use_colours ? "\x1B[31m" : "" );
print_string_contents( output, cell.payload.exception.message );
break;
case FUNCTIONTV:
fwprintf( output, L"(Function)" );
break;
case INTEGERTV:
if ( print_use_colours ) {
fputws( L"\x1B[34m", output );
}
fwprintf( output, L"%ld%", cell.payload.integer.value );
break;
case LAMBDATV:
print( output, make_cons( c_string_to_lisp_symbol( "lambda" ),
make_cons( cell.payload.lambda.args,
cell.payload.
lambda.body ) ) );
break;
case NILTV:
fwprintf( output, L"nil" );
break;
case NLAMBDATV:
print( output, make_cons( c_string_to_lisp_symbol( "nlambda" ),
make_cons( cell.payload.lambda.args,
cell.payload.
lambda.body ) ) );
break;
case READTV:
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 ) {
fputws( L"\x1B[34m", output );
}
fwprintf( output, L"%s", buffer );
free( buffer );
break;
case STRINGTV:
if ( print_use_colours ) {
fputws( L"\x1B[36m", output );
}
print_string( output, pointer );
break;
case SYMBOLTV:
if ( print_use_colours ) {
fputws( L"\x1B[1;33m", output );
}
print_string_contents( output, pointer );
break;
case SPECIALTV:
fwprintf( output, L"(Special form)" );
break;
case TRUETV:
fwprintf( output, L"t" );
break;
default:
fwprintf( stderr,
L"Error: Unrecognised tag value %d (%c%c%c%c)\n",
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 ) {
fputws( L"\x1B[39m", output );
}
}

1
src/print.h
View file

@ -15,5 +15,6 @@
#define __print_h
void print( FILE * output, struct cons_pointer pointer );
extern int print_use_colours;
#endif

93
src/read.c
View file

@ -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,8 @@
*/
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 +50,8 @@ 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;
@ -56,18 +59,33 @@ struct cons_pointer read_continuation( FILE * input, wint_t initial ) {
for ( c = initial;
c == '\0' || iswblank( c ) || iswcntrl( c ); c = fgetwc( input ) );
if ( feof( input ) ) {
result =
make_exception( c_string_to_lisp_string
( "End of file while reading" ), frame );
} else {
switch ( c ) {
case ';':
for ( c = fgetwc( input ); c != '\n'; c = fgetwc( input ) );
/* skip all characters from semi-colon to the end of the line */
break;
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 ) );
break;
default:
if ( c == '.' ) {
case '.':
{
wint_t next = fgetwc( input );
if ( iswdigit( next ) ) {
ungetwc( next, input );
@ -75,17 +93,24 @@ 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 );
}
} else if ( iswdigit( c ) ) {
}
break;
default:
if ( iswdigit( c ) ) {
result = read_number( input, c );
} else if ( iswprint( c ) ) {
result = read_symbol( input, c );
} else {
fwprintf( stderr, L"Unrecognised start of input character %c\n",
c );
result =
make_exception( c_string_to_lisp_string
( "Unrecognised start of input character" ),
frame );
}
}
}
@ -101,19 +126,16 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) {
int places_of_decimals = 0;
bool seen_period = false;
wint_t c;
fwprintf( stderr, L"read_number starting '%c' (%d)\n", initial, initial );
for ( c = initial; iswdigit( c ) || c == btowc( '.' );
c = fgetwc( input ) ) {
for ( c = initial; iswdigit( c )
|| c == btowc( '.' ); c = fgetwc( input ) ) {
if ( c == btowc( '.' ) ) {
seen_period = true;
} else {
accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' );
fwprintf( stderr, L"Added character %c, accumulator now %ld\n", c,
accumulator );
fwprintf( stderr,
L"Added character %c, accumulator now %ld\n",
c, accumulator );
if ( seen_period ) {
places_of_decimals++;
}
@ -124,11 +146,9 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) {
* push back the character read which was not a digit
*/
ungetwc( c, input );
if ( seen_period ) {
long double rv = ( long double )
( accumulator / pow( 10, places_of_decimals ) );
fwprintf( stderr, L"read_numer returning %Lf\n", rv );
result = make_real( rv );
} else {
@ -142,14 +162,16 @@ 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,
fwprintf( stderr,
L"read_list starting '%C' (%d)\n", initial, initial );
struct cons_pointer car = read_continuation( frame, input,
initial );
struct cons_pointer car = read_continuation( input, initial );
result = make_cons( car, read_list( input, fgetwc( input ) ) );
result = make_cons( car, read_list( frame, input, fgetwc( input ) ) );
} else {
fwprintf( stderr, L"End of list detected\n" );
}
@ -167,7 +189,6 @@ struct cons_pointer read_list( FILE * input, wint_t initial ) {
struct cons_pointer read_string( FILE * input, wint_t initial ) {
struct cons_pointer cdr = NIL;
struct cons_pointer result;
switch ( initial ) {
case '\0':
result = make_string( initial, NIL );
@ -176,7 +197,8 @@ struct cons_pointer read_string( FILE * input, wint_t initial ) {
result = make_string( '\0', NIL );
break;
default:
result = make_string( initial, read_string( input, fgetwc( input ) ) );
result =
make_string( initial, read_string( input, fgetwc( input ) ) );
break;
}
@ -186,7 +208,6 @@ struct cons_pointer read_string( FILE * input, wint_t initial ) {
struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
struct cons_pointer cdr = NIL;
struct cons_pointer result;
switch ( initial ) {
case '\0':
result = make_symbol( initial, NIL );
@ -195,7 +216,8 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
/*
* THIS IS NOT A GOOD IDEA, but is legal
*/
result = make_symbol( initial, read_symbol( input, fgetwc( input ) ) );
result =
make_symbol( initial, read_symbol( input, fgetwc( input ) ) );
break;
case ')':
/*
@ -208,9 +230,11 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
ungetwc( initial, input );
break;
default:
if ( iswprint( initial ) && !iswblank( initial ) ) {
if ( iswprint( initial )
&& !iswblank( initial ) ) {
result =
make_symbol( initial, read_symbol( input, fgetwc( input ) ) );
make_symbol( initial,
read_symbol( input, fgetwc( input ) ) );
} else {
result = NIL;
/*
@ -224,13 +248,14 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
fputws( L"Read symbol '", stderr );
print( stderr, result );
fputws( L"'\n", stderr );
return result;
}
/**
* 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 ) );
}

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.
*/
struct cons_pointer read( FILE * input );
struct cons_pointer read( struct stack_frame *frame, FILE * input );
#endif

87
src/repl.c
View file

@ -19,6 +19,58 @@
#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] = input;
struct cons_pointer result = lisp_eval( frame, oblist );
if ( !exceptionp( result ) ) {
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 +81,30 @@
void
repl( FILE * in_stream, FILE * out_stream, FILE * error_stream,
bool show_prompt ) {
while ( !feof( in_stream ) ) {
struct cons_pointer input_stream = make_read_stream( in_stream );
struct cons_pointer output_stream = make_write_stream( out_stream );
while ( !feof( pointer2cell( input_stream ).payload.stream.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 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 );
struct cons_pointer input = repl_read( input_stream );
if ( exceptionp( input ) ) {
break;
} else {
struct cons_pointer val = repl_eval( input );
if ( feof( pointer2cell( input_stream ).payload.stream.stream ) ) {
/* suppress the 'end of stream' exception */
if ( !exceptionp( val ) ) {
repl_print( output_stream, val );
}
} else {
repl_print( output_stream, val );
}
}
}
}

43
src/stack.c
View file

@ -66,10 +66,11 @@ struct stack_frame *make_empty_frame( struct stack_frame *previous,
*/
struct stack_frame *make_stack_frame( struct stack_frame *previous,
struct cons_pointer args,
struct cons_pointer env ) {
struct cons_pointer env,
struct cons_pointer *exception ) {
struct stack_frame *result = make_empty_frame( previous, env );
for ( int i = 0; i < args_in_frame && !nilp( args ); i++ ) {
for ( int i = 0; i < args_in_frame && consp( args ); i++ ) {
/* iterate down the arg list filling in the arg slots in the
* frame. When there are no more slots, if there are still args,
* stash them on more */
@ -81,21 +82,31 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous,
* processor to be evaled in parallel; but see notes here:
* https://github.com/simon-brooke/post-scarcity/wiki/parallelism
*/
struct stack_frame *arg_frame = make_empty_frame( previous, env );
struct stack_frame *arg_frame = make_empty_frame( result, 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 ( exceptionp( val ) ) {
exception = &val;
break;
} else {
result->arg[i] = val;
}
inc_ref( val );
free_stack_frame( arg_frame );
args = cell.payload.cons.cdr;
}
/*
* TODO: this isn't right. These args should also each be evaled.
*/
result->more = args;
inc_ref( result->more );
if ( consp( args ) ) {
/* if we still have args, eval them and stick the values on `more` */
struct cons_pointer more = eval_forms( previous, args, env );
result->more = more;
inc_ref( more );
}
dump_frame( stderr, result );
return result;
}
@ -123,8 +134,10 @@ struct stack_frame *make_special_frame( struct stack_frame *previous,
args = cell.payload.cons.cdr;
}
if ( consp( args ) ) {
result->more = args;
inc_ref( args );
}
return result;
}
@ -139,7 +152,9 @@ void free_stack_frame( struct stack_frame *frame ) {
for ( int i = 0; i < args_in_frame; i++ ) {
dec_ref( frame->arg[i] );
}
if ( !nilp( frame->more ) ) {
dec_ref( frame->more );
}
free( frame );
}
@ -155,13 +170,17 @@ void dump_frame( FILE * output, struct stack_frame *frame ) {
for ( int arg = 0; arg < args_in_frame; arg++ ) {
struct cons_space_object cell = pointer2cell( frame->arg[arg] );
fwprintf( output, L"Arg %d:\t%c%c%c%c\t", arg,
fwprintf( output, L"Arg %d:\t%c%c%c%c\tcount: %10u\tvalue: ", arg,
cell.tag.bytes[0],
cell.tag.bytes[1], cell.tag.bytes[2], cell.tag.bytes[3] );
cell.tag.bytes[1], cell.tag.bytes[2], cell.tag.bytes[3],
cell.count );
print( output, frame->arg[arg] );
fputws( L"\n", output );
}
fputws( L"More: \t", output );
print( output, frame->more );
fputws( L"\n", output );
}

3
src/stack.h
View file

@ -35,7 +35,8 @@ struct stack_frame *make_empty_frame( struct stack_frame *previous,
struct stack_frame *make_stack_frame( struct stack_frame *previous,
struct cons_pointer args,
struct cons_pointer env );
struct cons_pointer env,
struct cons_pointer *exception );
void free_stack_frame( struct stack_frame *frame );
/**

2
src/version.h
View file

@ -8,4 +8,4 @@
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#define VERSION "0.0.2"
#define VERSION "0.0.3"

2
unit-tests/add.sh
View file

@ -11,7 +11,7 @@ else
exit 1
fi
expected='5.500000'
expected='5.5'
actual=`echo "(add 2.5 3)" | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]

7
unit-tests/eval-real.sh
View file

@ -8,10 +8,15 @@ actual=`echo "(eval 5.05)" |\
head -2 |\
tail -1`
if [ "${expected}" = "${actual}" ]
outcome=`echo "sqrt((${expected} - ${actual})^2) < 0.0000001" | bc`
if [ "${outcome}" = "1" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi

12
unit-tests/intepreter.sh Normal file
View file

@ -0,0 +1,12 @@
#!/bin/bash
expected='6'
actual=`echo "(apply '(lambda (x y z) (/ (* y z) x)) '(2 3 4))" | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi

16
unit-tests/lambda.sh Normal file
View file

@ -0,0 +1,16 @@
#!/bin/bash
expected='(lambda (l) l)(1 2 3 4 5 6 7 8 9 10)'
actual=`target/psse 2>/dev/null <<EOF
(set! list (lambda (l) l))
(list '(1 2 3 4 5 6 7 8 9 10))
EOF`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
exit 0
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi

13
unit-tests/many-args.sh Normal file
View file

@ -0,0 +1,13 @@
#!/bin/bash
expected="120"
actual=`echo "(+ 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)" | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
exit 0
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi

2
unit-tests/multiply.sh
View file

@ -11,7 +11,7 @@ else
exit 1
fi
expected='7.500000'
expected='7.5'
actual=`echo "(multiply 2.5 3)" | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]

4
unit-tests/progn.sh
View file

@ -1,7 +1,7 @@
#!/bin/bash
expected='5'
actual=`echo "(progn '((add 2 3)))" | target/psse 2> /dev/null | head -2 | tail -1`
actual=`echo "(progn (add 2 3))" | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]
then
@ -12,7 +12,7 @@ else
fi
expected='"foo"'
actual=`echo "(progn '((add 2.5 3) \"foo\"))" | target/psse 2> /dev/null | head -2 | tail -1`
actual=`echo "(progn (add 2.5 3) \"foo\")" | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]
then

21
unit-tests/recursion.sh Normal file
View file

@ -0,0 +1,21 @@
#!/bin/bash
expected='nil3628800'
actual=`target/psse 2>/dev/null <<EOF
(progn
(set! fact
(lambda (n)
(cond ((= n 1) 1)
(t (* n (fact (- n 1)))))))
nil)
(fact 10)
EOF`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
exit 0
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi

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

@ -1,14 +1,17 @@
#!/bin/bash
log=log.$$
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 > ${log} 2>/dev/null
grep "${expected}" ${log} > /dev/null
if [ $? -eq 0 ]
then
echo "OK"
rm ${log}
exit 0
else
echo "Expected '${expected}', not found"
echo "Expected '${expected}', not found in ${log}"
exit 1
fi

16
unit-tests/varargs.sh Normal file
View file

@ -0,0 +1,16 @@
#!/bin/bash
expected='(lambda l l)(1 2 3 4 5 6 7 8 9 10)'
actual=`target/psse 2>/dev/null <<EOF
(set! list (lambda l l))
(list 1 2 3 4 5 6 7 8 9 10)
EOF`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
exit 0
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi