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

Apply works; all unit tests pass.

Browse source
This commit is contained in:
simon 2017-10-15 18:27:55 +01:00
parent 8e7d1ab913
commit 685790df43
5 changed files with 66 additions and 32 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
src/init.c
View file

@ -94,11 +94,11 @@ int main( int argc, char *argv[] ) {
bind_function( "*", &lisp_multiply );
bind_function( "subtract", &lisp_subtract );
bind_function( "-", &lisp_subtract );
bind_function( "apply", &lisp_apply );
/*
* primitive special forms
*/
bind_special( "apply", &lisp_apply );
bind_special( "eval", &lisp_eval );
bind_special( "quote", &lisp_quote );

47
src/lispops.c
View file

@ -73,9 +73,15 @@ struct cons_pointer c_cdr( struct cons_pointer arg ) {
}
/**
* Internal guts of apply.
* @param frame the stack frame, expected to have only one argument, a list
* comprising something that evaluates to a function and its arguments.
* @param env The evaluation environment.
* @return the result of evaluating the function with its arguments.
*/
struct cons_pointer
eval_cons( struct stack_frame *frame, struct cons_pointer env ) {
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 );
@ -143,9 +149,12 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer result = frame->arg[0];
struct cons_space_object cell = pointer2cell( frame->arg[0] );
fputws( L"Eval: ", stderr );
dump_frame( stderr, frame );
switch ( cell.tag.value ) {
case CONSTV:
result = eval_cons( frame, env );
result = c_apply( frame, env );
break;
case SYMBOLTV:
@ -170,37 +179,35 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
*/
}
fputws( L"Eval returning ", stderr );
print( stderr, result );
fputws( L"\n", stderr );
return result;
}
/**
* (apply fn args)
*
* Special form. Apply the function which is the result of evaluating the
* function. Apply the function which is the result of evaluating the
* first argoment to the list of arguments which is the result of evaluating
* the second argument
*/
struct cons_pointer
lisp_apply( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer result = NIL;
fputws( L"Apply: ", stderr );
dump_frame( stderr, frame );
if ( nilp( frame->arg[1] ) || !nilp( frame->arg[2] ) ) {
result =
lisp_throw( c_string_to_lisp_string( "(apply <function> <args>" ),
frame );
}
frame->arg[0] = make_cons( frame->arg[0], frame->arg[1] );
inc_ref( frame->arg[0] );
frame->arg[1] = NIL;
struct stack_frame *fn_frame = make_empty_frame( frame, env );
fn_frame->arg[0] = frame->arg[0];
inc_ref( fn_frame->arg[0] );
struct cons_pointer fn_pointer = lisp_eval( fn_frame, env );
free_stack_frame( fn_frame );
struct cons_pointer result = c_apply( frame, env );
struct stack_frame *next_frame =
make_special_frame( frame, make_cons( fn_pointer, frame->arg[1] ),
env );
result = eval_cons( next_frame, env );
free_stack_frame( next_frame );
fputws( L"Apply returning ", stderr );
print( stderr, result );
fputws( L"\n", stderr );
return result;
}

24
src/read.c
View file

@ -67,23 +67,25 @@ struct cons_pointer read_continuation( FILE * input, wint_t initial ) {
result = read_string( input, fgetwc( input ) );
break;
default:
if ( c == '.' ) {
if ( c == '.' ) {
wint_t next = fgetwc( input );
if ( iswdigit( next) ) {
if ( iswdigit( next ) ) {
ungetwc( next, input );
result = read_number( input, c );
} else if ( iswblank( next ) ) {
result = read_continuation(input, fgetwc( input));
/* dotted pair. TODO: this isn't right, we
* really need to backtrack up a level. */
result = read_continuation( input, fgetwc( input ) );
} else {
read_symbol( input, c );
}
}
else if ( iswdigit( c ) ) {
} else 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 );
fwprintf( stderr, L"Unrecognised start of input character %c\n",
c );
}
}
@ -206,7 +208,7 @@ 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 ) ) );
} else {
@ -218,10 +220,10 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
}
break;
}
fputws(L"Read symbol '", stderr);
print(stderr, result);
fputws(L"'\n", stderr);
fputws( L"Read symbol '", stderr );
print( stderr, result );
fputws( L"'\n", stderr );
return result;
}

17
src/stack.c
View file

@ -83,6 +83,7 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous,
*/
struct stack_frame *arg_frame = make_empty_frame( previous, env );
arg_frame->arg[0] = cell.payload.cons.car;
inc_ref( arg_frame->arg[0] );
result->arg[i] = lisp_eval( arg_frame, env );
inc_ref( result->arg[i] );
free_stack_frame( arg_frame );
@ -143,6 +144,22 @@ void free_stack_frame( struct stack_frame *frame ) {
free( frame );
}
/**
* Dump a stackframe to this stream for debugging
* @param output the stream
* @param frame the frame
*/
void dump_frame( FILE * output, struct stack_frame *frame ) {
fputws( L"Dumping stack frame\n", output );
for ( int arg = 0; arg < args_in_frame; arg++ ) {
fwprintf( output, L"Arg %d:", arg );
print( output, frame->arg[arg] );
fputws( L"\n", output );
}
}
/**
* Fetch a pointer to the value of the local variable at this index.
*/

8
src/stack.h
View file

@ -37,6 +37,14 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous,
struct cons_pointer args,
struct cons_pointer env );
void free_stack_frame( struct stack_frame *frame );
/**
* Dump a stackframe to this stream for debugging
* @param output the stream
* @param frame the frame
*/
void dump_frame( FILE * output, struct stack_frame *frame );
struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int n );
/**