Much work, all I think positive, but defun still doesn't work.
This commit is contained in:
parent
efea0192f3
commit
637d78fb1b
|
|
@ -4,8 +4,8 @@
|
|||
(nlambda
|
||||
form
|
||||
(cond ((symbolp (car form))
|
||||
(set! (car form) (apply lambda (cdr form)))))
|
||||
(t nil)))
|
||||
(set (car form) (apply lambda (cdr form))))
|
||||
(t nil))))
|
||||
|
||||
(defun! square (x) (* x x))
|
||||
|
||||
|
|
|
|||
|
|
@ -127,6 +127,33 @@ 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 " );
|
||||
|
|
|
|||
|
|
@ -177,6 +177,9 @@ struct cons_pointer make_exception( struct cons_pointer message,
|
|||
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;
|
||||
|
||||
|
|
@ -206,6 +209,9 @@ 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;
|
||||
|
|
@ -221,6 +227,9 @@ struct cons_pointer make_lambda( struct cons_pointer args,
|
|||
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 );
|
||||
|
|
|
|||
|
|
@ -80,8 +80,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:
|
||||
result =
|
||||
|
|
|
|||
|
|
@ -92,8 +92,10 @@ int main( int argc, char *argv[] ) {
|
|||
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 );
|
||||
|
||||
|
|
@ -112,11 +114,6 @@ int main( int argc, char *argv[] ) {
|
|||
bind_special( "quote", &lisp_quote );
|
||||
bind_special( "set!", &lisp_set_shriek );
|
||||
|
||||
|
||||
/* 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 );
|
||||
|
||||
repl( stdin, stdout, stderr, show_prompt );
|
||||
|
||||
if ( dump_at_end ) {
|
||||
|
|
|
|||
15
src/intern.c
15
src/intern.c
|
|
@ -4,11 +4,11 @@
|
|||
* For now this implements an oblist and shallow binding; local environments can
|
||||
* be consed onto the front of the oblist. Later, this won't do; bindings will happen
|
||||
* in namespaces, which will probably be implemented as hash tables.
|
||||
*
|
||||
*
|
||||
* Doctrine is that cons cells are immutable, and life is a lot more simple if they are;
|
||||
* so when a symbol is rebound in the master oblist, what in fact we do is construct
|
||||
* a new oblist without the previous binding but with the new binding. Anything which,
|
||||
* prior to this action, held a pointer to the old oblist (as all current threads'
|
||||
* prior to this action, held a pointer to the old oblist (as all current threads'
|
||||
* environments must do) continues to hold a pointer to the old oblist, and consequently
|
||||
* doesn't see the change. This is probably good but does mean you cannot use bindings
|
||||
* on the oblist to signal between threads.
|
||||
|
|
@ -26,12 +26,12 @@
|
|||
#include "print.h"
|
||||
|
||||
/**
|
||||
* The object list. What is added to this during system setup is 'global', that is,
|
||||
* The object list. What is added to this during system setup is 'global', that is,
|
||||
* visible to all sessions/threads. What is added during a session/thread is local to
|
||||
* that session/thread (because shallow binding). There must be some way for a user to
|
||||
* make the contents of their own environment persistent between threads but I don't
|
||||
* know what it is yet. At some stage there must be a way to rebind deep values so
|
||||
* they're visible to all users/threads, but again I don't yet have any idea how
|
||||
* they're visible to all users/threads, but again I don't yet have any idea how
|
||||
* that will work.
|
||||
*/
|
||||
struct cons_pointer oblist = NIL;
|
||||
|
|
@ -114,8 +114,8 @@ bind( struct cons_pointer key, struct cons_pointer value,
|
|||
}
|
||||
|
||||
/**
|
||||
* Binds this key to this value in the global oblist, but doesn't affect the
|
||||
* current environment. May not be useful except in bootstrapping (and even
|
||||
* Binds this key to this value in the global oblist, but doesn't affect the
|
||||
* current environment. May not be useful except in bootstrapping (and even
|
||||
* there it may not be especially useful).
|
||||
*/
|
||||
struct cons_pointer
|
||||
|
|
@ -133,10 +133,9 @@ 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
|
||||
* not currently bound
|
||||
*/
|
||||
result = bind( key, NIL, environment );
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
||||
|
|
@ -115,6 +115,16 @@ struct cons_pointer eval_forms( struct stack_frame *frame,
|
|||
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.
|
||||
|
|
@ -123,12 +133,18 @@ 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( frame->arg[i] ) ) {
|
||||
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;
|
||||
}
|
||||
|
||||
|
|
@ -169,7 +185,7 @@ 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" );
|
||||
fwprintf( stderr, L"eval_lambda called\n" );
|
||||
|
||||
struct cons_pointer new_env = env;
|
||||
struct cons_pointer names = cell.payload.lambda.args;
|
||||
|
|
@ -278,7 +294,9 @@ 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 );
|
||||
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
|
||||
|
|
@ -440,13 +458,45 @@ 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` to `value` in the namespace, altering the namespace in so doing.
|
||||
* 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 ) {
|
||||
|
|
@ -455,13 +505,15 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ) {
|
|||
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];
|
||||
struct cons_pointer val = eval_form( frame, frame->arg[1], env );
|
||||
deep_bind( frame->arg[0], val );
|
||||
result = val;
|
||||
} else {
|
||||
result =
|
||||
make_exception( c_string_to_lisp_string
|
||||
( "The first argument to `set!` is not a symbol" ),
|
||||
frame );
|
||||
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;
|
||||
|
|
@ -670,15 +722,16 @@ 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);
|
||||
result = eval_form( frame, c_car( clause_pointer ), env );
|
||||
|
||||
if ( !nilp( result ) ) {
|
||||
struct cons_pointer vals = eval_forms( frame, c_cdr( clause_pointer ), env );
|
||||
struct cons_pointer vals =
|
||||
eval_forms( frame, c_cdr( clause_pointer ), env );
|
||||
|
||||
while (consp( vals)) {
|
||||
result = c_car(vals);
|
||||
vals = c_cdr(vals);
|
||||
}
|
||||
while ( consp( vals ) ) {
|
||||
result = c_car( vals );
|
||||
vals = c_cdr( vals );
|
||||
}
|
||||
|
||||
done = true;
|
||||
}
|
||||
|
|
@ -698,6 +751,11 @@ 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 ) {
|
||||
|
|
|
|||
|
|
@ -71,6 +71,12 @@ struct cons_pointer lisp_eval( struct stack_frame *frame,
|
|||
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 );
|
||||
|
||||
|
|
|
|||
17
src/print.c
17
src/print.c
|
|
@ -132,8 +132,8 @@ void print( FILE * output, struct cons_pointer pointer ) {
|
|||
case LAMBDATV:
|
||||
print( output, make_cons( c_string_to_lisp_symbol( "lambda" ),
|
||||
make_cons( cell.payload.lambda.args,
|
||||
cell.payload.lambda.
|
||||
body ) ) );
|
||||
cell.payload.
|
||||
lambda.body ) ) );
|
||||
break;
|
||||
case NILTV:
|
||||
fwprintf( output, L"nil" );
|
||||
|
|
@ -141,8 +141,8 @@ void print( FILE * output, struct cons_pointer pointer ) {
|
|||
case NLAMBDATV:
|
||||
print( output, make_cons( c_string_to_lisp_symbol( "nlambda" ),
|
||||
make_cons( cell.payload.lambda.args,
|
||||
cell.payload.lambda.
|
||||
body ) ) );
|
||||
cell.payload.
|
||||
lambda.body ) ) );
|
||||
break;
|
||||
case READTV:
|
||||
fwprintf( output, L"(Input stream)" );
|
||||
|
|
@ -173,8 +173,9 @@ void print( FILE * output, struct cons_pointer pointer ) {
|
|||
print_string( output, pointer );
|
||||
break;
|
||||
case SYMBOLTV:
|
||||
if ( print_use_colours )
|
||||
if ( print_use_colours ) {
|
||||
fputws( L"\x1B[1;33m", output );
|
||||
}
|
||||
print_string_contents( output, pointer );
|
||||
break;
|
||||
case SPECIALTV:
|
||||
|
|
@ -185,10 +186,10 @@ void print( FILE * output, struct cons_pointer pointer ) {
|
|||
break;
|
||||
default:
|
||||
fwprintf( stderr,
|
||||
L"%sError: Unrecognised tag value %d (%c%c%c%c)%s\n",
|
||||
"\x1B[31m",
|
||||
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], "\x1B[39m" );
|
||||
cell.tag.bytes[2], cell.tag.bytes[3] );
|
||||
break;
|
||||
}
|
||||
|
||||
|
|
|
|||
10
src/repl.c
10
src/repl.c
|
|
@ -97,10 +97,12 @@ repl( FILE * in_stream, FILE * out_stream, FILE * error_stream,
|
|||
|
||||
struct cons_pointer val = repl_eval( input );
|
||||
|
||||
/* suppress the 'end of stream' exception */
|
||||
if ( !exceptionp( val ) &&
|
||||
!feof( pointer2cell( input_stream ).payload.stream.
|
||||
stream ) ) {
|
||||
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 );
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -169,9 +169,10 @@ 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 );
|
||||
|
|
|
|||
16
unit-tests/lambda.sh
Normal file
16
unit-tests/lambda.sh
Normal 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
|
||||
Loading…
Reference in a new issue