Progress, but there's something wrong with nlambdas

This commit is contained in:
Simon Brooke 2018-12-13 23:20:34 +00:00
parent 11409301da
commit cec32eff54
12 changed files with 288 additions and 204 deletions

View file

@ -2,17 +2,18 @@
;; to defun as a list of sexprs. ;; to defun as a list of sexprs.
(set! defun! (set! defun!
(nlambda (nlambda
(name args body) form
(cond (symbolp name) (cond ((symbolp (car form))
(set! name (apply lambda (cons args body)))))) (set! (car form) (apply lambda (cdr form)))))
(t nil)))
(defun! square (x) ((* x x))) (defun! square (x) (* x x))
(set! defsp! (set! defsp!
(nlambda (nlambda
(name args body) form
(cond (symbolp name) (cond (symbolp (car form))
(set! name (nlambda args body))))) (set! (car form) (apply nlambda (cdr form))))))
(defsp! cube (x) ((* x x x))) (defsp! cube (x) ((* x x x)))

4
lisp/fact.lisp Normal file
View file

@ -0,0 +1,4 @@
(set! fact
(lambda (n)
(cond ((= n 1) 1)
(true (* n (fact (- n 1)))))))

View file

@ -46,7 +46,7 @@ int main( int argc, char *argv[] ) {
bool dump_at_end = false; bool dump_at_end = false;
bool show_prompt = false; bool show_prompt = false;
while ( ( option = getopt( argc, argv, "pd" ) ) != -1 ) { while ( ( option = getopt( argc, argv, "pdc" ) ) != -1 ) {
switch ( option ) { switch ( option ) {
case 'c': case 'c':
print_use_colours = true; print_use_colours = true;
@ -108,6 +108,7 @@ int main( int argc, char *argv[] ) {
bind_special( "cond", &lisp_cond ); bind_special( "cond", &lisp_cond );
bind_special( "lambda", &lisp_lambda ); bind_special( "lambda", &lisp_lambda );
bind_special( "nlambda", &lisp_nlambda ); bind_special( "nlambda", &lisp_nlambda );
bind_special( "progn", &lisp_progn );
bind_special( "quote", &lisp_quote ); bind_special( "quote", &lisp_quote );
bind_special( "set!", &lisp_set_shriek ); bind_special( "set!", &lisp_set_shriek );

View file

@ -111,8 +111,8 @@ struct cons_pointer eval_forms( struct stack_frame *frame,
struct cons_pointer list, struct cons_pointer list,
struct cons_pointer env ) { struct cons_pointer env ) {
return consp( list ) ? return consp( list ) ?
make_cons( eval_form( frame, c_car( list ), env ), eval_forms( frame, c_cdr( list), env)) : make_cons( eval_form( frame, c_car( list ), env ),
NIL; eval_forms( frame, c_cdr( list ), env ) ) : NIL;
} }
@ -382,12 +382,16 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
} }
break; break;
/* /*
* TODO:
* the Clojure practice of having a map serve in the function place of * the Clojure practice of having a map serve in the function place of
* an s-expression is a good one and I should adopt it; also if the * an s-expression is a good one and I should adopt it; also if the
* object is a consp it could be interpretable source code but in the * object is a consp it could be interpretable source code but in the
* long run I don't want an interpreter, and if I can get away without * long run I don't want an interpreter, and if I can get away without
* so much the better. * so much the better.
*/ */
default:
result = frame->arg[0];
break;
} }
fputws( L"Eval returning ", stderr ); fputws( L"Eval returning ", stderr );
@ -616,7 +620,9 @@ lisp_type( struct stack_frame *frame, struct cons_pointer env ) {
/** /**
* Function; evaluate the forms which are listed in my single argument * (progn forms...)
*
* Special form; evaluate the forms which are listed in my arguments
* sequentially and return the value of the last. This function is called 'do' * sequentially and return the value of the last. This function is called 'do'
* in some dialects of Lisp. * in some dialects of Lisp.
* *
@ -627,14 +633,17 @@ lisp_type( struct stack_frame *frame, struct cons_pointer env ) {
*/ */
struct cons_pointer struct cons_pointer
lisp_progn( struct stack_frame *frame, struct cons_pointer env ) { lisp_progn( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer remaining = frame->arg[0]; struct cons_pointer remaining = frame->more;
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
while ( consp( remaining ) ) { for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) {
struct cons_space_object cell = pointer2cell( remaining ); result = eval_form( frame, frame->arg[i], env );
result = eval_form( frame, cell.payload.cons.car, env ); }
remaining = cell.payload.cons.cdr; while ( consp( remaining ) ) {
result = eval_form( frame, c_car( remaining ), env );
remaining = c_cdr( remaining );
} }
return result; return result;
@ -661,12 +670,16 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) {
if ( consp( clause_pointer ) ) { if ( consp( clause_pointer ) ) {
struct cons_space_object cell = pointer2cell( clause_pointer ); struct cons_space_object cell = pointer2cell( clause_pointer );
result = eval_form( frame, c_car( clause_pointer ), env);
if ( !nilp( result ) ) {
struct cons_pointer vals = eval_forms( frame, c_cdr( clause_pointer ), env );
while (consp( vals)) {
result = c_car(vals);
vals = c_cdr(vals);
}
if ( !nilp( eval_form( frame, cell.payload.cons.car, env ) ) ) {
struct stack_frame *next = make_empty_frame( frame, env );
next->arg[0] = cell.payload.cons.cdr;
inc_ref( next->arg[0] );
result = lisp_progn( next, env );
done = true; done = true;
} }
} else if ( nilp( clause_pointer ) ) { } else if ( nilp( clause_pointer ) ) {

View file

@ -25,6 +25,36 @@
#include "real.h" #include "real.h"
#include "stack.h" #include "stack.h"
/**
* Internal guts of add. Dark and mysterious.
*/
struct cons_pointer add_accumulate( struct cons_pointer arg,
struct stack_frame *frame,
long int *i_accumulator,
long double *d_accumulator, int *is_int ) {
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( arg );
switch ( cell.tag.value ) {
case INTEGERTV:
( *i_accumulator ) += cell.payload.integer.value;
( *d_accumulator ) += numeric_value( arg );
break;
case REALTV:
( *d_accumulator ) += cell.payload.real.value;
( *is_int ) &= false;
break;
case EXCEPTIONTV:
result = arg;
break;
default:
result = lisp_throw( c_string_to_lisp_string
( "Cannot multiply: not a number" ), frame );
}
return result;
}
/** /**
* Add an indefinite number of numbers together * Add an indefinite number of numbers together
* @param env the evaluation environment - ignored; * @param env the evaluation environment - ignored;
@ -36,46 +66,21 @@ lisp_add( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
long int i_accumulator = 0; long int i_accumulator = 0;
long double d_accumulator = 0; long double d_accumulator = 0;
bool is_int = true; int is_int = true;
for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) { for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) {
struct cons_space_object current = pointer2cell( frame->arg[i] ); result =
add_accumulate( frame->arg[i], frame, &i_accumulator,
switch ( current.tag.value ) { &d_accumulator, &is_int );
case INTEGERTV:
i_accumulator += current.payload.integer.value;
d_accumulator += numeric_value( frame->arg[i] );
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 );
}
} }
struct cons_pointer more = frame->more; struct cons_pointer more = frame->more;
while ( consp( more ) ) { while ( consp( more ) ) {
struct cons_pointer pointer = c_car( more ); result =
add_accumulate( c_car( more ), frame, &i_accumulator,
&d_accumulator, &is_int );
more = c_cdr( 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 ) { if ( is_int ) {
@ -87,6 +92,36 @@ lisp_add( struct stack_frame *frame, struct cons_pointer env ) {
return result; return result;
} }
/**
* Internal guts of multiply. Dark and mysterious.
*/
struct cons_pointer multiply_accumulate( struct cons_pointer arg,
struct stack_frame *frame,
long int *i_accumulator,
long double *d_accumulator,
int *is_int ) {
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( arg );
switch ( cell.tag.value ) {
case INTEGERTV:
( *i_accumulator ) *= cell.payload.integer.value;
( *d_accumulator ) *= numeric_value( arg );
break;
case REALTV:
( *d_accumulator ) *= cell.payload.real.value;
( *is_int ) &= false;
break;
case EXCEPTIONTV:
result = arg;
break;
default:
result = lisp_throw( c_string_to_lisp_string
( "Cannot multiply: not a number" ), frame );
}
return result;
}
/** /**
* Multiply an indefinite number of numbers together * Multiply an indefinite number of numbers together
* @param env the evaluation environment - ignored; * @param env the evaluation environment - ignored;
@ -98,53 +133,32 @@ lisp_multiply( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
long int i_accumulator = 1; long int i_accumulator = 1;
long double d_accumulator = 1; long double d_accumulator = 1;
bool is_int = true; int is_int = true;
for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) { for ( int i = 0;
struct cons_space_object arg = pointer2cell( frame->arg[i] ); i < args_in_frame && !nilp( frame->arg[i] ) && !exceptionp( result );
i++ ) {
switch ( arg.tag.value ) { result =
case INTEGERTV: multiply_accumulate( frame->arg[i], frame, &i_accumulator,
i_accumulator *= arg.payload.integer.value; &d_accumulator, &is_int );
d_accumulator *= numeric_value( frame->arg[i] );
break;
case REALTV:
d_accumulator *= arg.payload.real.value;
is_int = false;
break;
default:
lisp_throw( c_string_to_lisp_string
( "Cannot multiply: not a number" ), frame );
}
} }
struct cons_pointer more = frame->more; struct cons_pointer more = frame->more;
while ( consp( more ) ) { while ( consp( more ) && !exceptionp( result ) ) {
struct cons_pointer pointer = c_car( more ); result =
multiply_accumulate( c_car( more ), frame, &i_accumulator,
&d_accumulator, &is_int );
more = c_cdr( 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 ( !exceptionp( result ) ) {
if ( is_int ) { if ( is_int ) {
result = make_integer( i_accumulator ); result = make_integer( i_accumulator );
} else { } else {
result = make_real( d_accumulator ); result = make_real( d_accumulator );
} }
}
return result; return result;
} }

View file

@ -120,6 +120,9 @@ void print( FILE * output, struct cons_pointer pointer ) {
print_use_colours ? "\x1B[31m" : "" ); print_use_colours ? "\x1B[31m" : "" );
print_string_contents( output, cell.payload.exception.message ); print_string_contents( output, cell.payload.exception.message );
break; break;
case FUNCTIONTV:
fwprintf( output, L"(Function)" );
break;
case INTEGERTV: case INTEGERTV:
if ( print_use_colours ) { if ( print_use_colours ) {
fputws( L"\x1B[34m", output ); fputws( L"\x1B[34m", output );
@ -141,6 +144,9 @@ void print( FILE * output, struct cons_pointer pointer ) {
cell.payload.lambda. cell.payload.lambda.
body ) ) ); body ) ) );
break; break;
case READTV:
fwprintf( output, L"(Input stream)" );
break;
case REALTV: case REALTV:
/* TODO: using the C heap is a bad plan because it will fragment. /* TODO: using the C heap is a bad plan because it will fragment.
* As soon as I have working vector space I'll use a special purpose * As soon as I have working vector space I'll use a special purpose
@ -171,15 +177,12 @@ void print( FILE * output, struct cons_pointer pointer ) {
fputws( L"\x1B[1;33m", output ); fputws( L"\x1B[1;33m", output );
print_string_contents( output, pointer ); print_string_contents( output, pointer );
break; break;
case TRUETV:
fwprintf( output, L"t" );
break;
case FUNCTIONTV:
fwprintf( output, L"(Function)" );
break;
case SPECIALTV: case SPECIALTV:
fwprintf( output, L"(Special form)" ); fwprintf( output, L"(Special form)" );
break; break;
case TRUETV:
fwprintf( output, L"t" );
break;
default: default:
fwprintf( stderr, fwprintf( stderr,
L"%sError: Unrecognised tag value %d (%c%c%c%c)%s\n", L"%sError: Unrecognised tag value %d (%c%c%c%c)%s\n",

View file

@ -59,6 +59,11 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
for ( c = initial; for ( c = initial;
c == '\0' || iswblank( c ) || iswcntrl( c ); c = fgetwc( input ) ); c == '\0' || iswblank( c ) || iswcntrl( c ); c = fgetwc( input ) );
if ( feof( input ) ) {
result =
make_exception( c_string_to_lisp_string
( "End of file while reading" ), frame );
} else {
switch ( c ) { switch ( c ) {
case ';': case ';':
for ( c = fgetwc( input ); c != '\n'; c = fgetwc( input ) ); for ( c = fgetwc( input ); c != '\n'; c = fgetwc( input ) );
@ -70,7 +75,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
break; break;
case '\'': case '\'':
result = result =
c_quote( read_continuation( frame, input, fgetwc( input ) ) ); c_quote( read_continuation
( frame, input, fgetwc( input ) ) );
break; break;
case '(': case '(':
result = read_list( frame, input, fgetwc( input ) ); result = read_list( frame, input, fgetwc( input ) );
@ -78,8 +84,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
case '"': case '"':
result = read_string( input, fgetwc( input ) ); result = read_string( input, fgetwc( input ) );
break; break;
default: case '.':
if ( c == '.' ) { {
wint_t next = fgetwc( input ); wint_t next = fgetwc( input );
if ( iswdigit( next ) ) { if ( iswdigit( next ) ) {
ungetwc( next, input ); ungetwc( next, input );
@ -92,13 +98,19 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
} else { } else {
read_symbol( input, c ); read_symbol( input, c );
} }
} else if ( iswdigit( c ) ) { }
break;
default:
if ( iswdigit( c ) ) {
result = read_number( input, c ); result = read_number( input, c );
} else if ( iswprint( c ) ) { } else if ( iswprint( c ) ) {
result = read_symbol( input, c ); result = read_symbol( input, c );
} else { } else {
fwprintf( stderr, result =
L"Unrecognised start of input character %c\n", c ); make_exception( c_string_to_lisp_string
( "Unrecognised start of input character" ),
frame );
}
} }
} }
@ -114,19 +126,16 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) {
int places_of_decimals = 0; int places_of_decimals = 0;
bool seen_period = false; bool seen_period = false;
wint_t c; wint_t c;
fwprintf( stderr, L"read_number starting '%c' (%d)\n", initial, initial ); fwprintf( stderr, L"read_number starting '%c' (%d)\n", initial, initial );
for ( c = initial; iswdigit( c )
for ( c = initial; iswdigit( c ) || c == btowc( '.' ); || c == btowc( '.' ); c = fgetwc( input ) ) {
c = fgetwc( input ) ) {
if ( c == btowc( '.' ) ) { if ( c == btowc( '.' ) ) {
seen_period = true; seen_period = true;
} else { } else {
accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' ); accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' );
fwprintf( stderr,
fwprintf( stderr, L"Added character %c, accumulator now %ld\n", c, L"Added character %c, accumulator now %ld\n",
accumulator ); c, accumulator );
if ( seen_period ) { if ( seen_period ) {
places_of_decimals++; places_of_decimals++;
} }
@ -137,11 +146,9 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) {
* push back the character read which was not a digit * push back the character read which was not a digit
*/ */
ungetwc( c, input ); ungetwc( c, input );
if ( seen_period ) { if ( seen_period ) {
long double rv = ( long double ) long double rv = ( long double )
( accumulator / pow( 10, places_of_decimals ) ); ( accumulator / pow( 10, places_of_decimals ) );
fwprintf( stderr, L"read_numer returning %Lf\n", rv ); fwprintf( stderr, L"read_numer returning %Lf\n", rv );
result = make_real( rv ); result = make_real( rv );
} else { } else {
@ -155,14 +162,15 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) {
* Read a list from this input stream, which no longer contains the opening * Read a list from this input stream, which no longer contains the opening
* left parenthesis. * left parenthesis.
*/ */
struct cons_pointer read_list( struct stack_frame *frame, FILE * input, struct cons_pointer read_list( struct
wint_t initial ) { stack_frame
*frame, FILE * input, wint_t initial ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
if ( initial != ')' ) { if ( initial != ')' ) {
fwprintf( stderr, L"read_list starting '%C' (%d)\n", initial, fwprintf( stderr,
L"read_list starting '%C' (%d)\n", initial, initial );
struct cons_pointer car = read_continuation( frame, input,
initial ); initial );
struct cons_pointer car = read_continuation( frame, input, initial );
result = make_cons( car, read_list( frame, input, fgetwc( input ) ) ); result = make_cons( car, read_list( frame, input, fgetwc( input ) ) );
} else { } else {
fwprintf( stderr, L"End of list detected\n" ); fwprintf( stderr, L"End of list detected\n" );
@ -181,7 +189,6 @@ struct cons_pointer read_list( struct stack_frame *frame, FILE * input,
struct cons_pointer read_string( FILE * input, wint_t initial ) { struct cons_pointer read_string( FILE * input, wint_t initial ) {
struct cons_pointer cdr = NIL; struct cons_pointer cdr = NIL;
struct cons_pointer result; struct cons_pointer result;
switch ( initial ) { switch ( initial ) {
case '\0': case '\0':
result = make_string( initial, NIL ); result = make_string( initial, NIL );
@ -201,7 +208,6 @@ struct cons_pointer read_string( FILE * input, wint_t initial ) {
struct cons_pointer read_symbol( FILE * input, wint_t initial ) { struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
struct cons_pointer cdr = NIL; struct cons_pointer cdr = NIL;
struct cons_pointer result; struct cons_pointer result;
switch ( initial ) { switch ( initial ) {
case '\0': case '\0':
result = make_symbol( initial, NIL ); result = make_symbol( initial, NIL );
@ -224,7 +230,8 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
ungetwc( initial, input ); ungetwc( initial, input );
break; break;
default: default:
if ( iswprint( initial ) && !iswblank( initial ) ) { if ( iswprint( initial )
&& !iswblank( initial ) ) {
result = result =
make_symbol( initial, make_symbol( initial,
read_symbol( input, fgetwc( input ) ) ); read_symbol( input, fgetwc( input ) ) );
@ -241,13 +248,14 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
fputws( L"Read symbol '", stderr ); fputws( L"Read symbol '", stderr );
print( stderr, result ); print( stderr, result );
fputws( L"'\n", stderr ); fputws( L"'\n", stderr );
return result; return result;
} }
/** /**
* Read the next object on this input stream and return a cons_pointer to it. * Read the next object on this input stream and return a cons_pointer to it.
*/ */
struct cons_pointer read( struct stack_frame *frame, FILE * input ) { struct cons_pointer read( struct
stack_frame
*frame, FILE * input ) {
return read_continuation( frame, input, fgetwc( input ) ); return read_continuation( frame, input, fgetwc( input ) );
} }

View file

@ -48,7 +48,10 @@ struct cons_pointer repl_eval( struct cons_pointer input ) {
frame->arg[0] = input; frame->arg[0] = input;
struct cons_pointer result = lisp_eval( frame, oblist ); struct cons_pointer result = lisp_eval( frame, oblist );
if ( !exceptionp( result ) ) {
free_stack_frame( frame ); free_stack_frame( frame );
}
return result; return result;
} }
@ -86,12 +89,20 @@ repl( FILE * in_stream, FILE * out_stream, FILE * error_stream,
fwprintf( out_stream, L"\n:: " ); fwprintf( out_stream, L"\n:: " );
} }
struct cons_pointer val = repl_eval( repl_read( input_stream ) ); struct cons_pointer input = repl_read( input_stream );
if ( exceptionp( input ) ) {
break;
} else {
struct cons_pointer val = repl_eval( input );
/* suppress the 'end of stream' exception */ /* suppress the 'end of stream' exception */
if ( !exceptionp( val ) && if ( !exceptionp( val ) &&
!feof( pointer2cell( input_stream ).payload.stream.stream ) ) { !feof( pointer2cell( input_stream ).payload.stream.
stream ) ) {
repl_print( output_stream, val ); repl_print( output_stream, val );
} }
} }
} }
}

13
unit-tests/many-args.sh Normal file
View file

@ -0,0 +1,13 @@
#!/bin/bash
expected="120"
actual=`echo "(+ 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)" | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
exit 0
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi

View file

@ -1,7 +1,7 @@
#!/bin/bash #!/bin/bash
expected='5' expected='5'
actual=`echo "(progn '((add 2 3)))" | target/psse 2> /dev/null | head -2 | tail -1` actual=`echo "(progn (add 2 3))" | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ] if [ "${expected}" = "${actual}" ]
then then
@ -12,7 +12,7 @@ else
fi fi
expected='"foo"' expected='"foo"'
actual=`echo "(progn '((add 2.5 3) \"foo\"))" | target/psse 2> /dev/null | head -2 | tail -1` actual=`echo "(progn (add 2.5 3) \"foo\")" | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ] if [ "${expected}" = "${actual}" ]
then then

16
unit-tests/varargs.sh Normal file
View 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