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

And now the interpreter works (I think) correctly!

Browse source
This commit is contained in:
Simon Brooke 2018-12-12 21:12:49 +00:00
parent 676b231743
commit 0550b0168f
6 changed files with 71 additions and 22 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

9
src/conspage.c
View file

@ -73,9 +73,11 @@ void make_cons_page( ) {
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;
}
@ -110,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
} );
}
}
}

6
src/consspaceobject.c
View file

@ -63,7 +63,7 @@ void dec_ref( struct cons_pointer pointer ) {
}
}
void dump_string_cell( FILE * output, wchar_t * prefix,
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 ) {
@ -129,10 +129,10 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
cell.payload.integer.value, cell.count );
break;
case LAMBDATV:
fwprintf( output, L"Lambda cell; args: " );
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.args );
print( output, cell.payload.lambda.body );
break;
case READTV:
fwprintf( output, L"\t\tInput stream\n" );

5
src/init.c
View file

@ -48,12 +48,14 @@ int main( int argc, char *argv[] ) {
while ( ( option = getopt( argc, argv, "pd" ) ) != -1 ) {
switch ( option ) {
case 'c':
print_use_colours = true;
break;
case 'd':
dump_at_end = true;
break;
case 'p':
show_prompt = true;
print_use_colours = true;
break;
default:
fwprintf( stderr, L"Unexpected option %c\n", option );
@ -106,6 +108,7 @@ int main( int argc, char *argv[] ) {
bind_special( "cond", &lisp_cond );
bind_special( "lambda", &lisp_lambda );
bind_special( "quote", &lisp_quote );
bind_special( "set!", &lisp_set_shriek );
/* bind the oblist last, at this stage. Something clever needs to be done

37
src/lispops.c
View file

@ -128,11 +128,10 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
struct cons_pointer new_env = env;
struct cons_pointer args = cell.payload.lambda.args;
struct cons_pointer body = cell.payload.lambda.body;
struct cons_pointer vals = frame->arg[0];
while ( consp( args ) && consp( vals ) ) {
for ( int i = 0; i < args_in_frame && consp( args ); i++ ) {
struct cons_pointer arg = c_car( args );
struct cons_pointer val = c_car( vals );
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 " ) );
@ -141,8 +140,6 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
new_env = make_cons( make_cons( arg, val ), new_env );
args = c_cdr( args );
vals = c_cdr( vals );
}
while ( !nilp( body ) ) {
@ -194,6 +191,8 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
{
struct stack_frame *next =
make_stack_frame( frame, args, env );
fputws( L"Stack frame for lambda\n", stderr );
dump_frame( stderr, next );
result = eval_lambda( fn_cell, next, env );
free_stack_frame( next );
}
@ -283,6 +282,7 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
result = lisp_throw( message, frame );
} else {
result = c_assoc( canonical, env );
inc_ref( result );
}
}
break;
@ -341,6 +341,33 @@ lisp_quote( struct stack_frame *frame, struct cons_pointer env ) {
return frame->arg[0];
}
/**
* (set! symbol value)
* (set! symbol value namespace)
*
* Special form.
* `namespace` defaults to the oblist.
* Binds `symbol` to `value` in the namespace, altering the namespace in so doing.
*/
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] ) ) {
deep_bind( frame->arg[0], eval_form( frame, frame->arg[1], env ) );
result = frame->arg[1];
} else {
result =
make_exception( c_string_to_lisp_string
( "The first argument to `set!` is not a symbol" ),
frame );
}
return result;
}
/**
* (cons a b)
*

24
src/lispops.h
View file

@ -31,13 +31,17 @@
struct cons_pointer c_type( struct cons_pointer pointer );
/*
* special forms
* special forms
*/
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_set_shriek( struct stack_frame *frame, struct cons_pointer env );
/**
* The Lisp interpreter.
*
* @param frame the stack frame in which the expression is to be interpreted;
@ -51,7 +55,7 @@ struct cons_pointer lisp_quote( struct stack_frame *frame,
struct cons_pointer env );
/*
* functions
* functions
*/
struct cons_pointer lisp_cons( struct stack_frame *frame,
struct cons_pointer env );
@ -80,22 +84,22 @@ lisp_type( struct stack_frame *frame, struct cons_pointer env );
/**
* Function; evaluate the forms which are listed in my single argument
* Function; evaluate the forms which are listed in my single argument
* sequentially and return the value of the last. This function is called 'do'
* in some dialects of Lisp.
*
*
* @param frame My stack frame.
* @param env My environment (ignored).
* @return the value of the last form on the sequence which is my single
* @return the value of the last form on the sequence which is my single
* argument.
*/
struct cons_pointer
lisp_progn( struct stack_frame *frame, struct cons_pointer env );
/**
* Special form: conditional. Each arg is expected to be a list; if the first
* item in such a list evaluates to non-NIL, the remaining items in that list
* are evaluated in turn and the value of the last returned. If no arg (clause)
* Special form: conditional. Each arg is expected to be a list; if the first
* item in such a list evaluates to non-NIL, the remaining items in that list
* are evaluated in turn and the value of the last returned. If no arg (clause)
* has a first element which evaluates to non NIL, then NIL is returned.
* @param frame My stack frame.
* @param env My environment (ignored).
@ -105,7 +109,7 @@ struct cons_pointer
lisp_cond( struct stack_frame *frame, struct cons_pointer env );
/*
* neither, at this stage, really
* neither, at this stage, really
*/
struct cons_pointer lisp_throw( struct cons_pointer message,
struct stack_frame *frame );

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