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

Tactical commit before trying adventurous change in peano

Browse source
This commit is contained in:
Simon Brooke 2018-12-13 19:23:44 +00:00
parent facd5ccc94
commit 11409301da
10 changed files with 215 additions and 69 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
src/conspage.c
View file

@ -129,7 +129,7 @@ void free_cell( struct cons_pointer pointer ) {
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;

5
src/consspaceobject.c
View file

@ -92,7 +92,7 @@ void dump_string_cell( FILE * output, wchar_t *prefix,
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],
@ -112,7 +112,6 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
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 );
@ -220,7 +219,7 @@ struct cons_pointer make_lambda( struct cons_pointer args,
* 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 body ) {
struct cons_pointer pointer = allocate_cell( NLAMBDATAG );
struct cons_space_object *cell = &pointer2cell( pointer );
inc_ref( args );

2
src/consspaceobject.h
View file

@ -494,7 +494,7 @@ struct cons_pointer make_lambda( struct cons_pointer args,
* 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 body );
/**
* Construct a cell which points to an executable Lisp special form.

22
src/equal.c
View file

@ -15,7 +15,7 @@
#include "integer.h"
/**
* Shallow, and thus cheap, equality: true if these two objects are
* Shallow, and thus cheap, equality: true if these two objects are
* the same object, else false.
*/
bool eq( struct cons_pointer a, struct cons_pointer b ) {
@ -26,7 +26,7 @@ bool eq( struct cons_pointer a, struct cons_pointer b ) {
* True if the objects at these two cons pointers have the same tag, else false.
* @param a a pointer to a cons-space object;
* @param b another pointer to a cons-space object.
* @return true if the objects at these two cons pointers have the same tag,
* @return true if the objects at these two cons pointers have the same tag,
* else false.
*/
bool same_type( struct cons_pointer a, struct cons_pointer b ) {
@ -60,6 +60,8 @@ 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,
@ -70,7 +72,7 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
/*
* slightly complex because a string may or may not have a '\0'
* cell at the end, but I'll ignore that for now. I think in
* practice only the empty string will.
* practice only the empty string will.
*/
result =
cell_a->payload.string.character ==
@ -78,10 +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 );
@ -91,7 +97,7 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
fabs( num_b ) ? fabs( num_a ) : fabs( num_b );
/*
* not more different than one part in a million - close enough
* not more different than one part in a million - close enough
*/
result = fabs( num_a - num_b ) < ( max / 1000000.0 );
}
@ -103,8 +109,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
/*
* there's only supposed ever to be one T and one NIL cell, so each
* should be caught by eq; equality of vector-space objects is a whole
* other ball game so we won't deal with it now (and indeed may never).
* should be caught by eq; equality of vector-space objects is a whole
* other ball game so we won't deal with it now (and indeed may never).
* I'm not certain what equality means for read and write streams, so
* I'll ignore them, too, for now.
*/

109
src/lispops.c
View file

@ -91,12 +91,35 @@ 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;
}
struct cons_pointer compose_body( struct stack_frame *frame ) {
/**
* 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;
}
/**
* 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;
@ -106,7 +129,7 @@ struct cons_pointer compose_body( struct stack_frame *frame ) {
}
}
return body;
return body;
}
/**
@ -131,7 +154,17 @@ 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 ) {
@ -139,20 +172,36 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
fwprintf( stderr, L"eval_lambda called" );
struct cons_pointer new_env = env;
struct cons_pointer args = cell.payload.lambda.args;
struct cons_pointer names = cell.payload.lambda.args;
struct cons_pointer body = cell.payload.lambda.body;
for ( int i = 0; i < args_in_frame && consp( args ); i++ ) {
struct cons_pointer arg = c_car( args );
struct cons_pointer val = frame->arg[i];
print( stderr, c_string_to_lisp_string( "\n\tBinding " ) );
print( stderr, arg );
print( stderr, c_string_to_lisp_string( " to " ) );
print( stderr, val );
fputws( L"\"\n", stderr );
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 = make_cons( make_cons( arg, val ), new_env );
args = c_cdr( args );
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 ) ) {
@ -181,7 +230,13 @@ c_apply( struct stack_frame *frame, struct cons_pointer 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] );
@ -196,7 +251,12 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
struct stack_frame *next =
make_stack_frame( frame, args, env );
result = ( *fn_cell.payload.special.executable ) ( next, env );
free_stack_frame( next );
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 LAMBDATV:
@ -206,7 +266,12 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
fputws( L"Stack frame for lambda\n", stderr );
dump_frame( stderr, next );
result = eval_lambda( fn_cell, next, env );
free_stack_frame( next );
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 NLAMBDATV:
@ -214,7 +279,12 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
struct stack_frame *next =
make_special_frame( frame, args, env );
result = ( *fn_cell.payload.special.executable ) ( next, env );
free_stack_frame( next );
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:
@ -222,7 +292,12 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
struct stack_frame *next =
make_special_frame( frame, args, env );
result = ( *fn_cell.payload.special.executable ) ( next, env );
free_stack_frame( next );
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;
default:

33
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
*/

58
src/peano.c
View file

@ -54,19 +54,36 @@ lisp_add( struct stack_frame *frame, struct cons_pointer env ) {
lisp_throw( c_string_to_lisp_string
( "Cannot add: not a number" ), frame );
}
}
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;
if ( is_int ) {
result = make_integer( i_accumulator );
} else {
result = make_real( d_accumulator );
while ( consp( more ) ) {
struct cons_pointer pointer = c_car( more );
more = c_cdr( more);
struct cons_space_object current = pointer2cell( pointer );
switch ( current.tag.value ) {
case INTEGERTV:
i_accumulator += current.payload.integer.value;
d_accumulator += numeric_value( pointer );
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 );
}
}
if ( is_int ) {
result = make_integer( i_accumulator );
} else {
result = make_real( d_accumulator );
}
return result;
}
@ -99,18 +116,35 @@ lisp_multiply( struct stack_frame *frame, struct cons_pointer env ) {
lisp_throw( c_string_to_lisp_string
( "Cannot multiply: not a number" ), frame );
}
}
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 ) ) {
struct cons_pointer pointer = c_car( more );
more = c_cdr( more);
struct cons_space_object current = pointer2cell( pointer );
switch ( current.tag.value ) {
case INTEGERTV:
i_accumulator *= current.payload.integer.value;
d_accumulator *= numeric_value( pointer );
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 );
}
}
if ( is_int ) {
result = make_integer( i_accumulator );
} else {
result = make_real( d_accumulator );
}
}
return result;
}

30
src/print.c
View file

@ -119,29 +119,27 @@ void print( FILE * output, struct cons_pointer pointer ) {
fwprintf( output, L"\n%sException: ",
print_use_colours ? "\x1B[31m" : "" );
print_string_contents( output, cell.payload.exception.message );
fputws( L"\x1B[39m", output );
break;
case INTEGERTV:
if ( print_use_colours ) {
fputws( L"\x1B[34m", output );
}
fwprintf( output, L"%ld%", cell.payload.integer.value );
if ( print_use_colours ) {
fputws( L"\x1B[39m", output );
}
break;
case LAMBDATV:
print( output, make_cons( c_string_to_lisp_symbol("lambda"),
make_cons( cell.payload.lambda.args,
cell.payload.lambda.body ) ) );
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 ) ) );
print( output, make_cons( c_string_to_lisp_symbol( "nlambda" ),
make_cons( cell.payload.lambda.args,
cell.payload.lambda.
body ) ) );
break;
case REALTV:
/* TODO: using the C heap is a bad plan because it will fragment.
@ -160,9 +158,6 @@ void print( FILE * output, struct cons_pointer pointer ) {
fputws( L"\x1B[34m", output );
}
fwprintf( output, L"%s", buffer );
if ( print_use_colours ) {
fputws( L"\x1B[39m", output );
}
free( buffer );
break;
case STRINGTV:
@ -170,16 +165,11 @@ void print( FILE * output, struct cons_pointer pointer ) {
fputws( L"\x1B[36m", output );
}
print_string( output, pointer );
if ( print_use_colours ) {
fputws( L"\x1B[39m", output );
}
break;
case SYMBOLTV:
if ( print_use_colours )
fputws( L"\x1B[1;33m", output );
print_string_contents( output, pointer );
if ( print_use_colours )
fputws( L"\x1B[0;39m", output );
break;
case TRUETV:
fwprintf( output, L"t" );
@ -198,4 +188,8 @@ void print( FILE * output, struct cons_pointer pointer ) {
cell.tag.bytes[2], cell.tag.bytes[3], "\x1B[39m" );
break;
}
if ( print_use_colours ) {
fputws( L"\x1B[39m", output );
}
}

2
src/read.c
View file

@ -61,7 +61,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
switch ( c ) {
case ';':
for ( c= fgetwc( input ); c != '\n'; c= fgetwc( input ));
for ( c = fgetwc( input ); c != '\n'; c = fgetwc( input ) );
/* skip all characters from semi-colon to the end of the line */
break;
case EOF:

21
src/stack.c
View file

@ -98,14 +98,14 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous,
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 );
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;
}
@ -133,8 +133,10 @@ struct stack_frame *make_special_frame( struct stack_frame *previous,
args = cell.payload.cons.cdr;
}
result->more = args;
inc_ref( args );
if ( consp( args ) ) {
result->more = args;
inc_ref( args );
}
return result;
}
@ -174,6 +176,9 @@ void dump_frame( FILE * output, struct stack_frame *frame ) {
print( output, frame->arg[arg] );
fputws( L"\n", output );
}
fputws( L"More: \t", output);
print( output, frame->more);
fputws( L"\n", output );
}