Progress, but there's something wrong with nlambdas
This commit is contained in:
parent
11409301da
commit
cec32eff54
|
@ -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
4
lisp/fact.lisp
Normal file
|
@ -0,0 +1,4 @@
|
||||||
|
(set! fact
|
||||||
|
(lambda (n)
|
||||||
|
(cond ((= n 1) 1)
|
||||||
|
(true (* n (fact (- n 1)))))))
|
|
@ -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 );
|
||||||
|
|
||||||
|
|
|
@ -92,7 +92,7 @@ struct cons_pointer eval_form( struct stack_frame *parent,
|
||||||
inc_ref( next->arg[0] );
|
inc_ref( next->arg[0] );
|
||||||
result = lisp_eval( next, env );
|
result = lisp_eval( next, env );
|
||||||
|
|
||||||
if (!exceptionp( result)) {
|
if ( !exceptionp( result ) ) {
|
||||||
/* if we're returning an exception, we should NOT free the
|
/* if we're returning an exception, we should NOT free the
|
||||||
* stack frame. Corollary is, when we free an exception, we
|
* stack frame. Corollary is, when we free an exception, we
|
||||||
* should free all the frames it's holding on to. */
|
* should free all the frames it's holding on to. */
|
||||||
|
@ -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;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
|
@ -231,7 +231,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
|
||||||
inc_ref( fn_frame->arg[0] );
|
inc_ref( fn_frame->arg[0] );
|
||||||
struct cons_pointer fn_pointer = lisp_eval( fn_frame, env );
|
struct cons_pointer fn_pointer = lisp_eval( fn_frame, env );
|
||||||
|
|
||||||
if (!exceptionp( result)) {
|
if ( !exceptionp( result ) ) {
|
||||||
/* if we're returning an exception, we should NOT free the
|
/* if we're returning an exception, we should NOT free the
|
||||||
* stack frame. Corollary is, when we free an exception, we
|
* stack frame. Corollary is, when we free an exception, we
|
||||||
* should free all the frames it's holding on to. */
|
* should free all the frames it's holding on to. */
|
||||||
|
@ -251,7 +251,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
|
||||||
struct stack_frame *next =
|
struct stack_frame *next =
|
||||||
make_stack_frame( frame, args, env );
|
make_stack_frame( frame, args, env );
|
||||||
result = ( *fn_cell.payload.special.executable ) ( next, env );
|
result = ( *fn_cell.payload.special.executable ) ( next, env );
|
||||||
if (!exceptionp( result)) {
|
if ( !exceptionp( result ) ) {
|
||||||
/* if we're returning an exception, we should NOT free the
|
/* if we're returning an exception, we should NOT free the
|
||||||
* stack frame. Corollary is, when we free an exception, we
|
* stack frame. Corollary is, when we free an exception, we
|
||||||
* should free all the frames it's holding on to. */
|
* should free all the frames it's holding on to. */
|
||||||
|
@ -266,7 +266,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
|
||||||
fputws( L"Stack frame for lambda\n", stderr );
|
fputws( L"Stack frame for lambda\n", stderr );
|
||||||
dump_frame( stderr, next );
|
dump_frame( stderr, next );
|
||||||
result = eval_lambda( fn_cell, next, env );
|
result = eval_lambda( fn_cell, next, env );
|
||||||
if (!exceptionp( result)) {
|
if ( !exceptionp( result ) ) {
|
||||||
/* if we're returning an exception, we should NOT free the
|
/* if we're returning an exception, we should NOT free the
|
||||||
* stack frame. Corollary is, when we free an exception, we
|
* stack frame. Corollary is, when we free an exception, we
|
||||||
* should free all the frames it's holding on to. */
|
* should free all the frames it's holding on to. */
|
||||||
|
@ -279,7 +279,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
|
||||||
struct stack_frame *next =
|
struct stack_frame *next =
|
||||||
make_special_frame( frame, args, env );
|
make_special_frame( frame, args, env );
|
||||||
result = ( *fn_cell.payload.special.executable ) ( next, env );
|
result = ( *fn_cell.payload.special.executable ) ( next, env );
|
||||||
if (!exceptionp( result)) {
|
if ( !exceptionp( result ) ) {
|
||||||
/* if we're returning an exception, we should NOT free the
|
/* if we're returning an exception, we should NOT free the
|
||||||
* stack frame. Corollary is, when we free an exception, we
|
* stack frame. Corollary is, when we free an exception, we
|
||||||
* should free all the frames it's holding on to. */
|
* should free all the frames it's holding on to. */
|
||||||
|
@ -292,7 +292,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
|
||||||
struct stack_frame *next =
|
struct stack_frame *next =
|
||||||
make_special_frame( frame, args, env );
|
make_special_frame( frame, args, env );
|
||||||
result = ( *fn_cell.payload.special.executable ) ( next, env );
|
result = ( *fn_cell.payload.special.executable ) ( next, env );
|
||||||
if (!exceptionp( result)) {
|
if ( !exceptionp( result ) ) {
|
||||||
/* if we're returning an exception, we should NOT free the
|
/* if we're returning an exception, we should NOT free the
|
||||||
* stack frame. Corollary is, when we free an exception, we
|
* stack frame. Corollary is, when we free an exception, we
|
||||||
* should free all the frames it's holding on to. */
|
* should free all the frames it's holding on to. */
|
||||||
|
@ -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 ) ) {
|
||||||
|
|
150
src/peano.c
150
src/peano.c
|
@ -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 =
|
||||||
more = c_cdr( more);
|
add_accumulate( c_car( more ), frame, &i_accumulator,
|
||||||
struct cons_space_object current = pointer2cell( pointer );
|
&d_accumulator, &is_int );
|
||||||
|
more = c_cdr( more );
|
||||||
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 =
|
||||||
more = c_cdr( more);
|
multiply_accumulate( c_car( more ), frame, &i_accumulator,
|
||||||
struct cons_space_object current = pointer2cell( pointer );
|
&d_accumulator, &is_int );
|
||||||
|
more = c_cdr( more );
|
||||||
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;
|
||||||
}
|
}
|
||||||
|
|
15
src/print.c
15
src/print.c
|
@ -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",
|
||||||
|
|
60
src/read.c
60
src/read.c
|
@ -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 ) );
|
||||||
}
|
}
|
||||||
|
|
15
src/repl.c
15
src/repl.c
|
@ -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 );
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
}
|
||||||
}
|
}
|
||||||
|
|
|
@ -176,8 +176,8 @@ void dump_frame( FILE * output, struct stack_frame *frame ) {
|
||||||
print( output, frame->arg[arg] );
|
print( output, frame->arg[arg] );
|
||||||
fputws( L"\n", output );
|
fputws( L"\n", output );
|
||||||
}
|
}
|
||||||
fputws( L"More: \t", output);
|
fputws( L"More: \t", output );
|
||||||
print( output, frame->more);
|
print( output, frame->more );
|
||||||
fputws( L"\n", output );
|
fputws( L"\n", output );
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
13
unit-tests/many-args.sh
Normal file
13
unit-tests/many-args.sh
Normal 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
|
|
@ -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
16
unit-tests/varargs.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