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

Complete reworking of the REPL

Browse source 
which is good in itself, but not what I was meant to be working on.
This commit is contained in:
Simon Brooke 2018-12-30 17:56:15 +00:00
parent 47f4b4c7f7
commit 02fe5669d8
43 changed files with 415 additions and 281 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
Makefile
View file

@ -15,13 +15,11 @@ INDENT_FLAGS := -nbad -bap -nbc -br -brf -brs -c33 -cd33 -ncdb -ce -ci4 -cli4 \
-d0 -di1 -nfc1 -i4 -ip0 -l75 -lp -npcs \
-npsl -nsc -nsob -nss -nut -prs -l79 -ts2
VERSION := "0.0.2"
CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g -DDEBUG
LDFLAGS := -lm
$(TARGET): $(OBJS) Makefile
$(CC) $(LDFLAGS) $(OBJS) -DVERSION=$(VERSION) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS)
$(CC) $(LDFLAGS) $(OBJS) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS)
doc: $(SRCS) Makefile Doxyfile
doxygen

6
lisp/expt.lisp Normal file
View file

@ -0,0 +1,6 @@
(set! expt (lambda
(n x)
"Return the value of `n` raised to the `x`th power."
(cond
((= x 1) n)
(t (* n (expt n (- x 1)))))))

24
lisp/types.lisp Normal file
View file

@ -0,0 +1,24 @@
(set! cons? (lambda (o) "True if o is a cons cell." (= (type o) "CONS") ) )
(set! exception? (lambda (o) "True if o is an exception." (= (type o) "EXEP")))
(set! free? (lambda (o) "Trus if o is a free cell - this should be impossible!" (= (type o) "FREE")))
(set! function? (lambda (o) "True if o is a compiled function." (= (type o) "EXEP")))
(set! integer? (lambda (o) "True if o is an integer." (= (type o) "INTR")))
(set! lambda? (lambda (o) "True if o is an interpreted (source) function." (= (type o) "LMDA")))
(set! nil? (lambda (o) "True if o is the canonical nil value." (= (type o) "NIL ")))
(set! nlambda? (lambda (o) "True if o is an interpreted (source) special form." (= (type o) "NLMD")))
(set! rational? (lambda (o) "True if o is an rational number." (= (type o) "RTIO")))
(set! read? (lambda (o) "True if o is a read stream." (= (type o) "READ") ) )
(set! real? (lambda (o) "True if o is an real number." (= (type o) "REAL")))
(set! special? (lambda (o) "True if o is a compiled special form." (= (type o) "SPFM") ) )
(set! string? (lambda (o) "True if o is a string." (= (type o) "STRG") ) )
(set! symbol? (lambda (o) "True if o is a symbol." (= (type o) "SYMB") ) )
(set! true? (lambda (o) "True if o is the canonical true value." (= (type o) "TRUE") ) )
(set! write? (lambda (o) "True if o is a write stream." (= (type o) "WRIT") ) )
(set! or (lambda values
"True if any of `values` are non-nil."
(cond ((car values) t) (t (apply 'or (cdr values))))))
(set! number?
(lambda (o)
"I don't yet have an `or` operator

105
src/arith/integer.c
View file

@ -68,7 +68,7 @@ long double numeric_value( struct cons_pointer pointer ) {
*/
struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) {
struct cons_pointer result = NIL;
debug_print(L"Entering make_integer\n", DEBUG_ARITH);
debug_print( L"Entering make_integer\n", DEBUG_ARITH );
if ( integerp( more ) || nilp( more ) ) {
result = allocate_cell( INTEGERTAG );
@ -78,7 +78,7 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) {
}
debug_print(L"make_integer: returning\n", DEBUG_ARITH);
debug_print( L"make_integer: returning\n", DEBUG_ARITH );
debug_dump_object( result, DEBUG_ARITH );
return result;
}
@ -89,18 +89,18 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) {
*/
struct cons_pointer add_integers( struct cons_pointer a,
struct cons_pointer b ) {
debug_print(L"Entering add_integers\n", DEBUG_ARITH);
debug_print( L"Entering add_integers\n", DEBUG_ARITH );
struct cons_pointer result = NIL;
int64_t carry = 0;
if ( integerp( a ) && integerp( b ) ) {
while ( !nilp( a ) || !nilp( b ) || carry != 0 ) {
debug_print(L"add_integers: ", DEBUG_ARITH);
debug_print_object(a, DEBUG_ARITH);
debug_print(L" x ", DEBUG_ARITH);
debug_print_object(b, DEBUG_ARITH);
debug_printf(DEBUG_ARITH, L"; carry = %ld\n", carry);
while ( !nilp( a ) || !nilp( b ) || carry != 0 ) {
debug_print( L"add_integers: ", DEBUG_ARITH );
debug_print_object( a, DEBUG_ARITH );
debug_print( L" x ", DEBUG_ARITH );
debug_print_object( b, DEBUG_ARITH );
debug_printf( DEBUG_ARITH, L"; carry = %ld\n", carry );
int64_t av =
integerp( a ) ? pointer2cell( a ).payload.integer.value : 0;
@ -110,7 +110,9 @@ struct cons_pointer add_integers( struct cons_pointer a,
__int128_t rv = av + bv + carry;
if ( rv > LONG_MAX || rv < LONG_MIN ) {
debug_printf( DEBUG_ARITH, L"add_integers: 64 bit overflow; setting carry to %ld\n", carry);
debug_printf( DEBUG_ARITH,
L"add_integers: 64 bit overflow; setting carry to %ld\n",
carry );
carry = llabs( rv / LONG_MAX );
rv = rv % LONG_MAX;
} else {
@ -122,9 +124,9 @@ struct cons_pointer add_integers( struct cons_pointer a,
b = pointer2cell( b ).payload.integer.more;
}
}
debug_print(L"add_integers returning: ", DEBUG_ARITH);
debug_print_object(result, DEBUG_ARITH);
debug_println(DEBUG_ARITH);
debug_print( L"add_integers returning: ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH );
debug_println( DEBUG_ARITH );
return result;
}
@ -139,11 +141,11 @@ struct cons_pointer multiply_integers( struct cons_pointer a,
int64_t carry = 0;
if ( integerp( a ) && integerp( b ) ) {
debug_print(L"multiply_integers: ", DEBUG_ARITH);
debug_print_object(a, DEBUG_ARITH);
debug_print(L" x ", DEBUG_ARITH);
debug_print_object(b, DEBUG_ARITH);
debug_println(DEBUG_ARITH);
debug_print( L"multiply_integers: ", DEBUG_ARITH );
debug_print_object( a, DEBUG_ARITH );
debug_print( L" x ", DEBUG_ARITH );
debug_print_object( b, DEBUG_ARITH );
debug_println( DEBUG_ARITH );
while ( !nilp( a ) || !nilp( b ) || carry != 0 ) {
int64_t av =
@ -154,7 +156,9 @@ struct cons_pointer multiply_integers( struct cons_pointer a,
__int128_t rv = ( av * bv ) + carry;
if ( rv > LONG_MAX || rv < LONG_MIN ) {
debug_printf( DEBUG_ARITH, L"multiply_integers: 64 bit overflow; setting carry to %ld\n", carry);
debug_printf( DEBUG_ARITH,
L"multiply_integers: 64 bit overflow; setting carry to %ld\n",
carry );
carry = llabs( rv / LONG_MAX );
rv = rv % LONG_MAX;
} else {
@ -166,9 +170,9 @@ struct cons_pointer multiply_integers( struct cons_pointer a,
b = pointer2cell( b ).payload.integer.more;
}
}
debug_print(L"multiply_integers returning: ", DEBUG_ARITH);
debug_print_object(result, DEBUG_ARITH);
debug_println(DEBUG_ARITH);
debug_print( L"multiply_integers returning: ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH );
debug_println( DEBUG_ARITH );
return result;
}
@ -192,36 +196,43 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer,
bool is_negative = accumulator < 0;
accumulator = llabs( accumulator );
if (accumulator == 0) {
result = c_string_to_lisp_string( L"0");
} else {
while ( accumulator > 0 ) {
debug_printf(DEBUG_ARITH, L"integer_to_string: accumulator is %ld\n:",
accumulator);
do {
debug_printf(DEBUG_ARITH, L"integer_to_string: digit is %ld, hexadecimal is %lc\n:",
accumulator % base, hex_digits[accumulator % base]);
wint_t digit = (wint_t)hex_digits[accumulator % base];
if ( accumulator == 0 ) {
result = c_string_to_lisp_string( L"0" );
} else {
while ( accumulator > 0 ) {
debug_printf( DEBUG_ARITH,
L"integer_to_string: accumulator is %ld\n:",
accumulator );
do {
debug_printf( DEBUG_ARITH,
L"integer_to_string: digit is %ld, hexadecimal is %lc\n:",
accumulator % base,
hex_digits[accumulator % base] );
wint_t digit = ( wint_t ) hex_digits[accumulator % base];
result = make_string( (wint_t)hex_digits[accumulator % base], result );
accumulator = accumulator / base;
} while ( accumulator > base );
result =
make_string( ( wint_t ) hex_digits[accumulator % base],
result );
accumulator = accumulator / base;
} while ( accumulator > base );
if ( integerp( integer.payload.integer.more ) ) {
integer = pointer2cell( integer.payload.integer.more );
int64_t i = integer.payload.integer.value;
if ( integerp( integer.payload.integer.more ) ) {
integer = pointer2cell( integer.payload.integer.more );
int64_t i = integer.payload.integer.value;
/* TODO: I don't believe it's as simple as this! */
accumulator += ( base * ( i % base ) );
result = make_string( (wint_t)hex_digits[accumulator % base], result );
accumulator += ( base * ( i / base ) );
/* TODO: I don't believe it's as simple as this! */
accumulator += ( base * ( i % base ) );
result =
make_string( ( wint_t ) hex_digits[accumulator % base],
result );
accumulator += ( base * ( i / base ) );
}
}
if ( is_negative ) {
result = make_string( L'-', result );
}
}
if ( is_negative ) {
result = make_string( L'-', result );
}
}
return result;
}

12
src/arith/peano.c
View file

@ -284,7 +284,9 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
result = arg2;
break;
case INTEGERTV:
result = make_integer(cell1.payload.integer.value * cell2.payload.integer.value, NIL);
result =
make_integer( cell1.payload.integer.value *
cell2.payload.integer.value, NIL );
//result = multiply_integers( arg1, arg2 );
break;
case RATIOTV:
@ -412,8 +414,9 @@ struct cons_pointer inverse( struct cons_pointer frame,
case RATIOTV:
result = make_ratio( frame,
make_integer( 0 -
to_long_int( cell.payload.ratio.
dividend ), NIL ),
to_long_int( cell.payload.
ratio.dividend ),
NIL ),
cell.payload.ratio.divisor );
break;
case REALTV:
@ -453,7 +456,8 @@ struct cons_pointer lisp_subtract( struct
break;
case INTEGERTV:
result = make_integer( cell0.payload.integer.value
- cell1.payload.integer.value, NIL );
- cell1.payload.integer.value,
NIL );
break;
case RATIOTV:{
struct cons_pointer tmp =

16
src/arith/ratio.c
View file

@ -61,10 +61,10 @@ struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer,
if ( ratiop( arg ) ) {
int64_t ddrv =
pointer2cell( pointer2cell( arg ).payload.ratio.dividend ).
payload.integer.value, drrv =
pointer2cell( pointer2cell( arg ).payload.ratio.divisor ).
payload.integer.value, gcd = greatest_common_divisor( ddrv, drrv );
pointer2cell( pointer2cell( arg ).payload.ratio.dividend ).payload.
integer.value, drrv =
pointer2cell( pointer2cell( arg ).payload.ratio.divisor ).payload.
integer.value, gcd = greatest_common_divisor( ddrv, drrv );
if ( gcd > 1 ) {
if ( drrv / gcd == 1 ) {
@ -203,10 +203,10 @@ struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 ) {
struct cons_pointer i = make_ratio( frame_pointer,
pointer2cell( arg2 ).payload.
ratio.divisor,
pointer2cell( arg2 ).payload.
ratio.dividend ), result =
pointer2cell( arg2 ).payload.ratio.
divisor,
pointer2cell( arg2 ).payload.ratio.
dividend ), result =
multiply_ratio_ratio( frame_pointer, arg1, i );
dec_ref( i );

29
src/init.c
View file

@ -62,12 +62,6 @@ void bind_value( wchar_t *name, struct cons_pointer value ) {
}
int main( int argc, char *argv[] ) {
/*
* attempt to set wide character acceptance on all streams
*/
fwide( stdin, 1 );
fwide( stdout, 1 );
fwide( stderr, 1 );
int option;
bool dump_at_end = false;
bool show_prompt = false;
@ -110,6 +104,26 @@ int main( int argc, char *argv[] ) {
bind_value( L"nil", NIL );
bind_value( L"t", TRUE );
/*
* standard input, output, error and sink streams
* attempt to set wide character acceptance on all streams
*/
FILE *sink = fopen( "/dev/null", "w" );
fwide( stdin, 1 );
fwide( stdout, 1 );
fwide( stderr, 1 );
fwide( sink, 1 );
bind_value( L"*in*", make_read_stream( stdin ) );
bind_value( L"*out*", make_write_stream( stdout ) );
bind_value( L"*log*", make_write_stream( stderr ) );
bind_value( L"*sink*", make_write_stream( sink ) );
/*
* the default prompt
*/
bind_value( L"*prompt*",
show_prompt ? c_string_to_lisp_symbol( L":: " ) : NIL );
/*
* primitive function operations
*/
@ -126,6 +140,7 @@ int main( int argc, char *argv[] ) {
bind_function( L"exception", &lisp_exception );
bind_function( L"multiply", &lisp_multiply );
bind_function( L"read", &lisp_read );
bind_function( L"repl", &lisp_repl );
bind_function( L"oblist", &lisp_oblist );
bind_function( L"print", &lisp_print );
bind_function( L"progn", &lisp_progn );
@ -156,7 +171,7 @@ int main( int argc, char *argv[] ) {
debug_print( L"Initialised oblist\n", DEBUG_BOOTSTRAP );
debug_dump_object( oblist, DEBUG_BOOTSTRAP );
repl( stdin, stdout, stderr, show_prompt );
repl( show_prompt );
debug_print( L"Freeing oblist\n", DEBUG_BOOTSTRAP );
dec_ref( oblist );

14
src/memory/dump.c
View file

@ -83,9 +83,9 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
fwprintf( output,
L"\t\tInteger cell: value %ld, count %u\n",
cell.payload.integer.value, cell.count );
if (!nilp(cell.payload.integer.more)) {
fputws( L"\t\tBIGNUM! More at\n:", output);
dump_object(output, cell.payload.integer.more);
if ( !nilp( cell.payload.integer.more ) ) {
fputws( L"\t\tBIGNUM! More at\n:", output );
dump_object( output, cell.payload.integer.more );
}
break;
case LAMBDATV:
@ -107,10 +107,10 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
case RATIOTV:
fwprintf( output,
L"\t\tRational cell: value %ld/%ld, count %u\n",
pointer2cell( cell.payload.ratio.dividend ).
payload.integer.value,
pointer2cell( cell.payload.ratio.divisor ).
payload.integer.value, cell.count );
pointer2cell( cell.payload.ratio.dividend ).payload.
integer.value,
pointer2cell( cell.payload.ratio.divisor ).payload.
integer.value, cell.count );
break;
case READTV:
fwprintf( output, L"\t\tInput stream\n" );

4
src/ops/equal.c
View file

@ -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 =

268
src/ops/lispops.c
View file

@ -117,11 +117,16 @@ struct cons_pointer eval_forms( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer list,
struct cons_pointer env ) {
/* TODO: refactor. This runs up the C stack. */
return consp( list ) ?
make_cons( eval_form( frame, frame_pointer, c_car( list ), env ),
eval_forms( frame, frame_pointer, c_cdr( list ),
env ) ) : NIL;
struct cons_pointer result = NIL;
while ( consp( list ) ) {
result =
make_cons( eval_form( frame, frame_pointer, c_car( list ), env ),
result );
list = c_cdr( list );
}
return result;
}
/**
@ -220,7 +225,8 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
/* if `names` is a symbol, rather than a list of symbols,
* then bind a list of the values of args to that symbol. */
/* TODO: eval all the things in frame->more */
struct cons_pointer vals = frame->more;
struct cons_pointer vals =
eval_forms( frame, frame_pointer, frame->more, env );
for ( int i = args_in_frame - 1; i >= 0; i-- ) {
struct cons_pointer val =
@ -353,10 +359,9 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
result = next_pointer;
} else {
result =
( *fn_cell.payload.
special.executable ) ( get_stack_frame
( next_pointer ),
next_pointer, env );
( *fn_cell.payload.special.
executable ) ( get_stack_frame( next_pointer ),
next_pointer, env );
debug_print( L"Special form returning: ", DEBUG_EVAL );
debug_print_object( result, DEBUG_EVAL );
debug_println( DEBUG_EVAL );
@ -480,10 +485,9 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer
lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
#ifdef DEBUG
debug_print( L"Apply: ", DEBUG_EVAL );
dump_frame( stderr, frame_pointer );
#endif
debug_dump_object( frame_pointer, DEBUG_EVAL );
set_reg( frame, 0, make_cons( frame->arg[0], frame->arg[1] ) );
set_reg( frame, 1, NIL );
@ -612,17 +616,24 @@ struct cons_pointer
lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( frame->arg[0] );
if ( consp( frame->arg[0] ) ) {
struct cons_space_object cell = pointer2cell( frame->arg[0] );
result = cell.payload.cons.car;
} else if ( stringp( frame->arg[0] ) ) {
struct cons_space_object cell = pointer2cell( frame->arg[0] );
result = make_string( cell.payload.string.character, NIL );
} else {
struct cons_pointer message =
c_string_to_lisp_string( L"Attempt to take CAR of non sequence" );
result = throw_exception( message, frame_pointer );
switch ( cell.tag.value ) {
case CONSTV:
result = cell.payload.cons.car;
break;
case READTV:
result = make_string( fgetwc( cell.payload.stream.stream ), NIL );
case STRINGTV:
result = make_string( cell.payload.string.character, NIL );
break;
case NILTV:
break;
default:
result =
throw_exception( c_string_to_lisp_string
( L"Attempt to take CAR of non sequence" ),
frame_pointer );
}
return result;
@ -632,22 +643,33 @@ lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer,
* (cdr s_expr)
* Returns the remainder of a sequence when the head is removed. Valid for cons cells,
* strings, and TODO read streams and other things which can be considered as sequences.
* NOTE that if the argument is an input stream, the first character is removed AND
* DISCARDED.
*/
struct cons_pointer
lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( frame->arg[0] );
if ( consp( frame->arg[0] ) ) {
struct cons_space_object cell = pointer2cell( frame->arg[0] );
result = cell.payload.cons.cdr;
} else if ( stringp( frame->arg[0] ) ) {
struct cons_space_object cell = pointer2cell( frame->arg[0] );
result = cell.payload.string.cdr;
} else {
struct cons_pointer message =
c_string_to_lisp_string( L"Attempt to take CDR of non sequence" );
result = throw_exception( message, frame_pointer );
switch ( cell.tag.value ) {
case CONSTV:
result = cell.payload.cons.cdr;
break;
case READTV:
fgetwc( cell.payload.stream.stream );
result = frame->arg[0];
break;
case STRINGTV:
result = cell.payload.string.cdr;
break;
case NILTV:
break;
default:
result =
throw_exception( c_string_to_lisp_string
( L"Attempt to take CDR of non sequence" ),
frame_pointer );
}
return result;
@ -683,6 +705,26 @@ lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer,
return equal( frame->arg[0], frame->arg[1] ) ? TRUE : NIL;
}
/**
* Resutn the current default input, or of `inputp` is false, output stream from
* this `env`ironment.
*/
struct cons_pointer get_default_stream( bool inputp, struct cons_pointer env ) {
struct cons_pointer result = NIL;
struct cons_pointer stream_name =
c_string_to_lisp_symbol( inputp ? L"*in*" : L"*out*" );
inc_ref( stream_name );
result = c_assoc( stream_name, env );
dec_ref( stream_name );
return result;
}
/**
* (read)
* (read read-stream)
@ -696,15 +738,24 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer,
debug_print( L"entering lisp_read\n", DEBUG_IO );
#endif
FILE *input = stdin;
struct cons_pointer in_stream = readp( frame->arg[0] ) ?
frame->arg[0] : get_default_stream( true, env );
if ( readp( frame->arg[0] ) ) {
input = pointer2cell( frame->arg[0] ).payload.stream.stream;
if ( readp( in_stream ) ) {
debug_print( L"lisp_print: setting input stream\n", DEBUG_IO );
debug_dump_object( in_stream, DEBUG_IO );
input = pointer2cell( in_stream ).payload.stream.stream;
inc_ref( in_stream );
}
struct cons_pointer result = read( frame, frame_pointer, input );
debug_print( L"lisp_read returning\n", DEBUG_IO );
debug_dump_object( result, DEBUG_IO );
if ( readp( in_stream ) ) {
dec_ref( in_stream );
}
return result;
}
@ -757,12 +808,16 @@ lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer,
debug_print( L"Entering print\n", DEBUG_IO );
struct cons_pointer result = NIL;
FILE *output = stdout;
struct cons_pointer out_stream = writep( frame->arg[1] ) ?
frame->arg[1] : get_default_stream( false, env );
if ( writep( frame->arg[1] ) ) {
if ( writep( out_stream ) ) {
debug_print( L"lisp_print: setting output stream\n", DEBUG_IO );
debug_dump_object( frame->arg[1], DEBUG_IO );
output = pointer2cell( frame->arg[1] ).payload.stream.stream;
debug_dump_object( out_stream, DEBUG_IO );
output = pointer2cell( out_stream ).payload.stream.stream;
inc_ref( out_stream );
}
debug_print( L"lisp_print: about to print\n", DEBUG_IO );
debug_dump_object( frame->arg[0], DEBUG_IO );
@ -771,6 +826,10 @@ lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer,
debug_print( L"lisp_print returning\n", DEBUG_IO );
debug_dump_object( result, DEBUG_IO );
if ( writep( out_stream ) ) {
dec_ref( out_stream );
}
return result;
}
@ -787,6 +846,27 @@ lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer,
return c_type( frame->arg[0] );
}
/**
* Evaluate each of these forms in this `env`ironment over this `frame`,
* returning only the value of the last.
*/
struct cons_pointer
c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer forms, struct cons_pointer env ) {
struct cons_pointer result = NIL;
while ( consp( forms ) ) {
struct cons_pointer r = result;
inc_ref( r );
result = eval_form( frame, frame_pointer, c_car( forms ), env );
dec_ref( r );
forms = c_cdr( forms );
}
return result;
}
/**
* (progn forms...)
@ -803,17 +883,19 @@ lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer
lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer remaining = frame->more;
struct cons_pointer result = NIL;
for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) {
struct cons_pointer r = result;
inc_ref( r );
result = eval_form( frame, frame_pointer, frame->arg[i], env );
dec_ref( r );
}
while ( consp( remaining ) ) {
result = eval_form( frame, frame_pointer, c_car( remaining ), env );
remaining = c_cdr( remaining );
if ( consp( frame->more ) ) {
result = c_progn( frame, frame_pointer, frame->more, env );
}
return result;
@ -846,15 +928,9 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer,
env );
if ( !nilp( result ) ) {
struct cons_pointer vals =
eval_forms( frame, frame_pointer, c_cdr( clause_pointer ),
env );
while ( consp( vals ) ) {
result = c_car( vals );
vals = c_cdr( vals );
}
result =
c_progn( frame, frame_pointer, c_cdr( clause_pointer ),
env );
done = true;
}
} else if ( nilp( clause_pointer ) ) {
@ -915,3 +991,91 @@ lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer,
return exceptionp( message ) ? message : make_exception( message,
frame->previous );
}
/**
* (repl)
* (repl prompt)
* (repl prompt input_stream output_stream)
*
* Function: the read/eval/print loop. Returns the value of the last expression
* entered.
*/
struct cons_pointer lisp_repl( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer expr = NIL;
/* TODO: bind *prompt*, *input*, *output* in the environment to the values
* of arguments 0, 1, and 2 respectively, but in each case only if the
* argument is not nil */
struct cons_pointer input = get_default_stream( true, env );
struct cons_pointer output = get_default_stream( false, env );
FILE *os = pointer2cell( output ).payload.stream.stream;
struct cons_pointer prompt_name = c_string_to_lisp_symbol( L"*prompt*" );
struct cons_pointer old_oblist = oblist;
struct cons_pointer new_env = env;
inc_ref( input );
inc_ref( output );
inc_ref( prompt_name );
inc_ref( new_env );
/* TODO: this is subtly wrong. If we were evaluating
* (print (eval (read)))
* then the stack frame for read would have the stack frame for
* eval as parent, and it in turn would have the stack frame for
* print as parent.
*/
while ( readp( input ) && writep( output )
&& !feof( pointer2cell( input ).payload.stream.stream ) ) {
/* OK, here's a really subtle problem: because lists are immutable, anything
* bound in the oblist subsequent to this function being invoked isn't in the
* environment. So, for example, changes to *prompt* or *log* made in the oblist
* are not visible. So copy changes made in the oblist into the enviroment.
* TODO: the whole process of resolving symbol values needs to be revisited
* when we get onto namespaces. */
struct cons_pointer cursor = oblist;
while ( !nilp( cursor ) && !eq( cursor, old_oblist ) ) {
debug_print
( L"lisp_repl: copying new oblist binding into REPL environment:\n",
DEBUG_REPL );
debug_print_object( c_car( cursor ), DEBUG_REPL );
debug_println( DEBUG_REPL );
new_env = make_cons( c_car( cursor ), new_env );
cursor = c_cdr( cursor );
}
old_oblist = oblist;
println( os );
struct cons_pointer prompt = c_assoc( prompt_name, new_env );
if ( !nilp( prompt ) ) {
print( os, prompt );
}
expr = lisp_read( get_stack_frame( frame_pointer ), frame_pointer,
new_env );
inc_ref( expr );
if ( exceptionp( expr )
&& feof( pointer2cell( input ).payload.stream.stream ) ) {
/* suppress printing end of stream exception */
break;
}
println( os );
print( os, eval_form( frame, frame_pointer, expr, new_env ) );
dec_ref( expr );
}
dec_ref( input );
dec_ref( output );
dec_ref( prompt_name );
dec_ref( new_env );
return expr;
}

4
src/ops/lispops.h
View file

@ -140,9 +140,13 @@ struct cons_pointer lisp_print( struct stack_frame *frame,
struct cons_pointer lisp_read( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_repl( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_reverse( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
/**
* Function: Get the Lisp type of the single argument.
* @param frame My stack frame.

4
src/ops/print.c
View file

@ -224,3 +224,7 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
return pointer;
}
void println( FILE * output ) {
fputws( L"\n", output );
}

1
src/ops/print.h
View file

@ -15,6 +15,7 @@
#define __print_h
struct cons_pointer print( FILE * output, struct cons_pointer pointer );
void println( FILE * output );
extern int print_use_colours;
#endif

108
src/repl.c
View file

@ -11,118 +11,28 @@
#include <stdio.h>
#include <wchar.h>
#include "conspage.h"
#include "consspaceobject.h"
#include "debug.h"
#include "intern.h"
#include "lispops.h"
#include "read.h"
#include "print.h"
#include "stack.h"
/* TODO: this is subtly wrong. If we were evaluating
* (print (eval (read)))
* then the stack frame for read would have the stack frame for
* eval as parent, and it in turn would have the stack frame for
* print as parent.
*/
/**
* Dummy up a Lisp read call with its own stack frame.
* The read/eval/print loop.
*/
struct cons_pointer repl_read( struct cons_pointer stream_pointer ) {
struct cons_pointer result = NIL;
debug_print( L"Entered repl_read\n", DEBUG_REPL );
struct cons_pointer frame_pointer =
make_stack_frame( NIL, make_cons( stream_pointer, NIL ), oblist );
debug_print( L"repl_read: got stack_frame pointer\n", DEBUG_REPL );
debug_dump_object( frame_pointer, DEBUG_REPL );
void repl( ) {
debug_print( L"Entered repl\n", DEBUG_REPL );
struct cons_pointer frame_pointer = make_stack_frame( NIL, NIL, oblist );
if ( !nilp( frame_pointer ) ) {
inc_ref( frame_pointer );
result =
lisp_read( get_stack_frame( frame_pointer ), frame_pointer,
oblist );
lisp_repl( get_stack_frame( frame_pointer ), frame_pointer, oblist );
dec_ref( frame_pointer );
}
debug_print( L"repl_read: returning\n", DEBUG_REPL );
debug_dump_object( result, DEBUG_REPL );
return result;
}
/**
* Dummy up a Lisp eval call with its own stack frame.
*/
struct cons_pointer repl_eval( struct cons_pointer input ) {
debug_print( L"Entered repl_eval\n", DEBUG_REPL );
struct cons_pointer result = NIL;
result = eval_form( NULL, NIL, input, oblist );
debug_print( L"repl_eval: returning\n", DEBUG_REPL );
debug_dump_object( result, DEBUG_REPL );
return result;
}
/**
* Dummy up a Lisp print call with its own stack frame.
*/
struct cons_pointer repl_print( struct cons_pointer stream_pointer,
struct cons_pointer value ) {
debug_print( L"Entered repl_print\n", DEBUG_REPL );
debug_dump_object( value, DEBUG_REPL );
struct cons_pointer result =
print( pointer2cell( stream_pointer ).payload.stream.stream, value );
debug_print( L"repl_print: returning\n", DEBUG_REPL );
debug_dump_object( result, DEBUG_REPL );
return result;
}
/**
* The read/eval/print loop
* @param in_stream the stream to read from;
* @param out_stream the stream to write to;
* @param err_stream the stream to send errors to;
* @param show_prompt true if prompts should be shown.
*/
void
repl( FILE * in_stream, FILE * out_stream, FILE * error_stream,
bool show_prompt ) {
debug_print( L"Entered repl\n", DEBUG_REPL );
struct cons_pointer input_stream = make_read_stream( in_stream );
inc_ref( input_stream );
struct cons_pointer output_stream = make_write_stream( out_stream );
inc_ref( output_stream );
while ( !feof( pointer2cell( input_stream ).payload.stream.stream ) ) {
if ( show_prompt ) {
fwprintf( out_stream, L"\n:: " );
}
struct cons_pointer input = repl_read( input_stream );
inc_ref( input );
if ( exceptionp( input ) ) {
/* suppress the end-of-stream exception */
if ( !feof( pointer2cell( input_stream ).payload.stream.stream ) ) {
repl_print( output_stream, input );
}
break;
} else {
struct cons_pointer val = repl_eval( input );
inc_ref( val );
repl_print( output_stream, val );
dec_ref( val );
}
dec_ref( input );
}
dec_ref( input_stream );
dec_ref( output_stream );
debug_print( L"Leaving repl\n", DEBUG_REPL );
}

7
src/repl.h
View file

@ -20,13 +20,8 @@ extern "C" {
/**
* The read/eval/print loop
* @param in_stream the stream to read from;
* @param out_stream the stream to write to;
* @param err_stream the stream to send errors to;
* @param show_prompt true if prompts should be shown.
*/
void repl( FILE * in_stream, FILE * out_stream,
FILE * error_stream, bool show_prompt );
void repl( );
#ifdef __cplusplus
}

10
unit-tests/add.sh
View file

@ -1,7 +1,7 @@
#!/bin/bash
expected='5'
actual=`echo "(add 2 3)" | target/psse 2> /dev/null | head -2 | tail -1`
actual=`echo "(add 2 3)" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
@ -12,7 +12,7 @@ else
fi
expected='5.5'
actual=`echo "(add 2.5 3)" | target/psse 2> /dev/null | head -2 | tail -1`
actual=`echo "(add 2.5 3)" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
@ -24,7 +24,7 @@ else
fi
expected='1/4'
actual=`echo "(+ 3/14 1/28)" | target/psse 2> /dev/null | head -2 | tail -1`
actual=`echo "(+ 3/14 1/28)" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
@ -36,7 +36,7 @@ fi
# (+ integer ratio) should be ratio
expected='25/4'
actual=`echo "(+ 6 1/4)" | target/psse 2> /dev/null | head -2 | tail -1`
actual=`echo "(+ 6 1/4)" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
@ -48,7 +48,7 @@ fi
# (+ ratio integer) should be ratio
expected='25/4'
actual=`echo "(+ 1/4 6)" | target/psse 2> /dev/null | head -2 | tail -1`
actual=`echo "(+ 1/4 6)" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then

2
unit-tests/apply.sh
View file

@ -1,7 +1,7 @@
#!/bin/bash
expected='1'
actual=`echo "(apply 'add '(1))"| target/psse 2> /dev/null | head -2 | tail -1`
actual=`echo "(apply 'add '(1))"| target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then

2
unit-tests/complex-list.sh
View file

@ -1,7 +1,7 @@
#!/bin/bash
expected='(1 2 3 ("Fred") nil 77354)'
actual=`echo "'(1 2 3 (\"Fred\") () 77354)" | target/psse 2> /dev/null | head -2 | tail -1`
actual=`echo "'(1 2 3 (\"Fred\") () 77354)" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then

4
unit-tests/cond.sh
View file

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

4
unit-tests/empty-list.sh
View file

@ -1,5 +1,5 @@
#!/bin/bash
#
#
# File: empty-list.sh.bash
# Author: simon
#
@ -7,7 +7,7 @@
#
expected=nil
actual=`echo "'()" | target/psse 2> /dev/null | head -2 | tail -1`
actual=`echo "'()" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then

2
unit-tests/empty-string.sh
View file

@ -1,7 +1,7 @@
#!/bin/bash
expected="\"\""
actual=`echo '""' | target/psse 2> /dev/null | head -2 | tail -1`
actual=`echo '""' | target/psse | tail -1`
if [ "$expected" = "$actual" ]
then

2
unit-tests/eval-integer.sh
View file

@ -1,7 +1,7 @@
#!/bin/bash
expected='5'
actual=`echo "(eval 5)" | target/psse 2> /dev/null | head -2 | tail -1`
actual=`echo "(eval 5)" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then

2
unit-tests/eval-quote-sexpr.sh
View file

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

2
unit-tests/eval-quote-symbol.sh
View file

@ -1,7 +1,7 @@
#!/bin/bash
expected='(Special form)'
actual=`echo "(eval 'cond)" | target/psse 2> /dev/null | head -2 | tail -1`
actual=`echo "(eval 'cond)" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then

3
unit-tests/eval-real.sh
View file

@ -5,12 +5,11 @@ expected='5.05'
actual=`echo "(eval 5.05)" |\
target/psse 2> /dev/null |\
sed 's/0*$//' |\
head -2 |\
tail -1`
# one part in a million is close enough...
outcome=`echo "sqrt((${expected} - ${actual})^2) < 0.0000001" | bc`
if [ "${outcome}" = "1" ]
then
echo "OK"

2
unit-tests/eval-string.sh
View file

@ -1,7 +1,7 @@
#!/bin/bash
expected='"5"'
actual=`echo '(eval "5")' | target/psse 2> /dev/null | head -2 | tail -1`
actual=`echo '(eval "5")' | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then

2
unit-tests/fred.sh
View file

@ -1,7 +1,7 @@
#!/bin/bash
expected='"Fred"'
actual=`echo ${expected} | target/psse 2> /dev/null | head -2 | tail -1`
actual=`echo ${expected} | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then

4
unit-tests/integer.sh
View file

@ -1,7 +1,7 @@
#!/bin/bash
expected="354"
actual=`echo ${expected} | target/psse 2> /dev/null | head -2 | tail -1`
expected='354'
actual=`echo ${expected} | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then

2
unit-tests/intepreter.sh
View file

@ -1,7 +1,7 @@
#!/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`
actual=`echo "(apply '(lambda (x y z) (/ (* y z) x)) '(2 3 4))" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then

5
unit-tests/lambda.sh
View file

@ -1,10 +1,11 @@
#!/bin/bash
expected='(lambda (l) l)(1 2 3 4 5 6 7 8 9 10)'
actual=`target/psse 2>/dev/null <<EOF
expected='(lambda (l) l) (1 2 3 4 5 6 7 8 9 10)'
output=`target/psse 2>/dev/null <<EOF
(set! list (lambda (l) l))
(list '(1 2 3 4 5 6 7 8 9 10))
EOF`
actual=`echo $output | tail -1`
if [ "${expected}" = "${actual}" ]
then

2
unit-tests/many-args.sh
View file

@ -1,7 +1,7 @@
#!/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`
actual=`echo "(+ 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then

4
unit-tests/multiply.sh
View file

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

2
unit-tests/nil.sh
View file

@ -1,7 +1,7 @@
#!/bin/bash
expected=nil
actual=`echo 'nil' | target/psse 2> /dev/null | head -2 | tail -1`
actual=`echo 'nil' | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then

2
unit-tests/nlambda.sh
View file

@ -1,7 +1,7 @@
#!/bin/bash
expected='a'
actual=`echo "((nlambda (x) x) a)" | target/psse 2> /dev/null | head -2 | tail -1`
actual=`echo "((nlambda (x) x) a)" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then

4
unit-tests/progn.sh
View file

@ -1,7 +1,7 @@
#!/bin/bash
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 | tail -1`
if [ "${expected}" = "${actual}" ]
then
@ -12,7 +12,7 @@ else
fi
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 | tail -1`
if [ "${expected}" = "${actual}" ]
then

2
unit-tests/quote.sh
View file

@ -1,7 +1,7 @@
#!/bin/bash
expected='Fred'
actual=`echo "'Fred" | target/psse 2> /dev/null | head -2 | tail -1`
actual=`echo "'Fred" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then

2
unit-tests/quoted-list.sh
View file

@ -1,7 +1,7 @@
#!/bin/bash
expected='(123 (4 (5 nil)) Fred)'
actual=`echo "'(123 (4 (5 ())) Fred)" | target/psse 2> /dev/null | head -2 | tail -1`
actual=`echo "'(123 (4 (5 ())) Fred)" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then

2
unit-tests/ratio-addition.sh
View file

@ -1,7 +1,7 @@
#!/bin/bash
expected='1/4'
actual=`echo "(+ 3/14 1/28)" | target/psse 2> /dev/null | head -2 | tail -1`
actual=`echo "(+ 3/14 1/28)" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then

5
unit-tests/recursion.sh
View file

@ -1,7 +1,7 @@
#!/bin/bash
expected='nil3628800'
actual=`target/psse 2>/dev/null <<EOF
expected='nil 3628800'
output=`target/psse 2>/dev/null <<EOF
(progn
(set! fact
(lambda (n)
@ -10,6 +10,7 @@ actual=`target/psse 2>/dev/null <<EOF
nil)
(fact 10)
EOF`
actual=`echo $output | tail -1`
if [ "${expected}" = "${actual}" ]
then

6
unit-tests/reverse.sh
View file

@ -1,7 +1,7 @@
#!/bin/bash
expected='"god yzal eht revo depmuj xof nworb kciuq ehT"'
actual=`echo '(reverse "The quick brown fox jumped over the lazy dog")' | target/psse 2> /dev/null | head -2 | tail -1`
actual=`echo '(reverse "The quick brown fox jumped over the lazy dog")' | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
@ -12,7 +12,7 @@ else
fi
expected='(1024 512 256 128 64 32 16 8 4 2)'
actual=`echo "(reverse '(2 4 8 16 32 64 128 256 512 1024))" | target/psse 2> /dev/null | head -2 | tail -1`
actual=`echo "(reverse '(2 4 8 16 32 64 128 256 512 1024))" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
@ -23,7 +23,7 @@ else
fi
expected='esrever'
actual=`echo "(reverse 'reverse)" | target/psse 2> /dev/null | head -2 | tail -1`
actual=`echo "(reverse 'reverse)" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then

2
unit-tests/simple-list.sh
View file

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

2
unit-tests/string-with-spaces.sh
View file

@ -1,7 +1,7 @@
#!/bin/bash
expected='"Strings should be able to include spaces (and other stuff)!"'
actual=`echo ${expected} | target/psse 2> /dev/null | head -2 | tail -1`
actual=`echo ${expected} | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then

7
unit-tests/varargs.sh
View file

@ -1,10 +1,7 @@
#!/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`
expected='(1 2 3 4 5 6 7 8 9 10)'
actual=`echo "(set! list (lambda l l))(list 1 2 3 4 5 6 7 8 9 10)" |target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then