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

Interpreter working!

Browse source
This commit is contained in:
Simon Brooke 2018-12-12 18:49:05 +00:00
parent 7189c0172c
commit 676b231743
7 changed files with 108 additions and 91 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
src/conspage.c
View file

@ -54,7 +54,7 @@ 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 < 3 ) {
if ( initialised_cons_pages == 0 && i < 2 ) {
switch ( i ) {
case 0:
/*
@ -78,16 +78,6 @@ void make_cons_page( ) {
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 {
/*

24
src/consspaceobject.c
View file

@ -128,6 +128,12 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
L"\t\tInteger cell: value %ld, count %u\n",
cell.payload.integer.value, cell.count );
break;
case LAMBDATV:
fwprintf( output, L"Lambda cell; args: " );
print( output, cell.payload.lambda.args );
fwprintf( output, L";\n\t\t\tbody: " );
print( output, cell.payload.lambda.args );
break;
case READTV:
fwprintf( output, L"\t\tInput stream\n" );
case REALTV:
@ -152,8 +158,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 );
@ -195,6 +200,21 @@ 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( 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

28
src/consspaceobject.h
View file

@ -61,8 +61,7 @@
#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}
* A lambda cell.
*/
#define LAMBDATAG "LMDA"
#define LAMBDATV 1094995276
@ -134,11 +133,6 @@
*/
#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
*/
@ -173,7 +167,7 @@
#define functionp(conspoint) (check_tag(conspoint,FUNCTIONTAG))
/**
* true if conspointer points to the special Lambda cell, else false
* true if conspointer points to a special Lambda cell, else false
*/
#define lambdap(conspoint) (check_tag(conspoint,LAMBDATAG))
@ -309,11 +303,15 @@ struct integer_payload {
long int value;
};
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;
};
@ -403,6 +401,10 @@ struct cons_space_object {
* if tag == INTEGERTAG
*/
struct integer_payload integer;
/*
* if tag == LAMBDATAG
*/
struct lambda_payload lambda;
/*
* if tag == NILTAG; we'll treat the special cell NIL as just a cons
*/
@ -472,6 +474,12 @@ 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 a cell which points to an executable Lisp special form.
*/

4
src/equal.c
View file

@ -78,8 +78,8 @@ 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:
case REALTV:

3
src/init.c
View file

@ -74,8 +74,6 @@ int main( int argc, char *argv[] ) {
*/
deep_bind( c_string_to_lisp_symbol( "nil" ), NIL );
deep_bind( c_string_to_lisp_symbol( "t" ), TRUE );
/* lambda is even more privileged than a special form */
deep_bind( c_string_to_lisp_symbol( "lambda" ), LAMBDA );
/*
* primitive function operations
@ -106,6 +104,7 @@ int main( int argc, char *argv[] ) {
* primitive special forms
*/
bind_special( "cond", &lisp_cond );
bind_special( "lambda", &lisp_lambda );
bind_special( "quote", &lisp_quote );

100
src/lispops.c
View file

@ -100,58 +100,58 @@ struct cons_pointer eval_form( struct stack_frame *parent,
* The Lisp interpreter.
*
* @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 ) {
struct cons_pointer result = NIL;
struct cons_pointer lexpr = frame->arg[0];
struct cons_pointer should_be_lambda =
eval_form( frame, c_car( lexpr ), env );
dump_frame( stderr, 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( frame->arg[i] ) ) {
body = make_cons( frame->arg[i], body );
}
}
return make_lambda( frame->arg[0], body );
}
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" );
if ( lambdap( should_be_lambda ) ) {
struct cons_pointer new_env = env;
struct cons_pointer args = c_car( c_cdr( lexpr ) );
struct cons_pointer body = c_cdr( c_cdr( lexpr ) );
struct cons_pointer args = cell.payload.lambda.args;
struct cons_pointer body = cell.payload.lambda.body;
struct cons_pointer vals = frame->arg[0];
for ( int i = 1; i < args_in_frame && consp( args ); i++ ) {
args = c_cdr( args );
while ( consp( args ) && consp( vals ) ) {
struct cons_pointer arg = c_car( args );
struct cons_pointer val = c_car( vals );
print( stderr, c_string_to_lisp_string( "\n\tBinding " ) );
print( stderr, arg );
print( stderr, c_string_to_lisp_string( " to " ) );
print( stderr, frame->arg[i] );
print( stderr, val );
fputws( L"\"\n", stderr );
new_env = make_cons( make_cons( arg, val ), new_env );
args = c_cdr( args );
vals = c_cdr( vals );
new_env = make_cons( make_cons( arg, frame->arg[i] ), 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 );
}
} else {
if ( exceptionp( should_be_lambda ) ) {
result = should_be_lambda;
} else {
char *buffer = malloc( 1024 );
struct cons_space_object not_lambda =
pointer2cell( should_be_lambda );
memset( buffer, '\0', 1024 );
sprintf( buffer,
"Expected lambda, but found cell with tag %d (%c%c%c%c)",
not_lambda.tag.value, not_lambda.tag.bytes[0],
not_lambda.tag.bytes[1], not_lambda.tag.bytes[2],
not_lambda.tag.bytes[3] );
struct cons_pointer message = c_string_to_lisp_string( buffer );
free( buffer );
result = lisp_throw( message, frame );
}
}
return result;
}
@ -178,13 +178,9 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer args = c_cdr( frame->arg[0] );
switch ( fn_cell.tag.value ) {
case SPECIALTV:
{
struct stack_frame *next =
make_special_frame( frame, args, env );
result = ( *fn_cell.payload.special.executable ) ( next, env );
free_stack_frame( next );
}
case EXCEPTIONTV:
/* just pass exceptions straight back */
result = fn_pointer;
break;
case FUNCTIONTV:
{
@ -194,16 +190,21 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
free_stack_frame( next );
}
break;
case CONSTV:
case LAMBDATV:
{
fwprintf( stdout,
L"Treating cons as lambda expression (apply)\n" );
result = lisp_lambda( frame, env );
struct stack_frame *next =
make_stack_frame( frame, args, env );
result = eval_lambda( fn_cell, next, env );
free_stack_frame( next );
}
break;
case EXCEPTIONTV:
/* just pass exceptions straight back */
result = fn_pointer;
case SPECIALTV:
{
struct stack_frame *next =
make_special_frame( frame, args, env );
result = ( *fn_cell.payload.special.executable ) ( next, env );
free_stack_frame( next );
}
break;
default:
{
@ -266,12 +267,7 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
switch ( cell.tag.value ) {
case CONSTV:
print( stderr, frame->arg[0] );
if ( lambdap( c_car( frame->arg[0] ) ) ) {
fwprintf( stdout,
L"Treating cons as lambda expression (eval)\n" );
result = lisp_lambda( frame, env );
} else {
{
result = c_apply( frame, env );
}
break;

6
src/print.c
View file

@ -131,7 +131,11 @@ void print( FILE * output, struct cons_pointer pointer ) {
}
break;
case LAMBDATV:
fwprintf( output, L"lambda" /* "λ" */ );
fputws( L"(lambda ", output );
print( output, cell.payload.lambda.args );
fputws( L" ", output );
print( output, cell.payload.lambda.body );
fputws( L")", output );
break;
case NILTV:
fwprintf( output, L"nil" );