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

Major refactoring. Major problems!

Browse source 
On the right path but it doesn't work yet.
This commit is contained in:
Simon Brooke 2018-12-26 20:30:14 +00:00
parent ae8ba67ed7
commit 9937f344dc
20 changed files with 695 additions and 506 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Makefile
View file

@ -38,7 +38,7 @@ test: $(OBJS) $(TESTS) Makefile
.PHONY: clean .PHONY: clean
clean: clean:
$(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ *~ $(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ $(SRC_DIRS)/*/*~ *~
repl: repl:
$(TARGET) -p 2> psse.log $(TARGET) -p 2> psse.log

121
src/arith/peano.c
View file

@ -8,11 +8,11 @@
*/ */
#include <ctype.h> #include <ctype.h>
#include <math.h>
#include <stdbool.h> #include <stdbool.h>
#include <stdio.h> #include <stdio.h>
#include <stdlib.h> #include <stdlib.h>
#include <string.h> #include <string.h>
#include <math.h>
#include "consspaceobject.h" #include "consspaceobject.h"
#include "conspage.h" #include "conspage.h"
@ -28,7 +28,7 @@
long double to_long_double( struct cons_pointer arg ); long double to_long_double( struct cons_pointer arg );
int64_t to_long_int( struct cons_pointer arg ); int64_t to_long_int( struct cons_pointer arg );
struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer arg1,
struct cons_pointer arg2 ); struct cons_pointer arg2 );
@ -119,7 +119,7 @@ int64_t to_long_int( struct cons_pointer arg ) {
* return a cons_pointer indicating a number which is the sum of * return a cons_pointer indicating a number which is the sum of
* the numbers indicated by `arg1` and `arg2`. * the numbers indicated by `arg1` and `arg2`.
*/ */
struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer arg1,
struct cons_pointer arg2 ) { struct cons_pointer arg2 ) {
struct cons_pointer result; struct cons_pointer result;
struct cons_space_object cell1 = pointer2cell( arg1 ); struct cons_space_object cell1 = pointer2cell( arg1 );
@ -153,7 +153,7 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1,
cell2.payload.integer.value ); cell2.payload.integer.value );
break; break;
case RATIOTV: case RATIOTV:
result = add_integer_ratio( frame, arg1, arg2 ); result = add_integer_ratio( frame_pointer, arg1, arg2 );
break; break;
case REALTV: case REALTV:
result = result =
@ -161,9 +161,9 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1,
to_long_double( arg2 ) ); to_long_double( arg2 ) );
break; break;
default: default:
result = lisp_throw( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot add: not a number" ), ( "Cannot add: not a number" ),
frame ); frame_pointer );
break; break;
} }
break; break;
@ -173,10 +173,10 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1,
result = arg2; result = arg2;
break; break;
case INTEGERTV: case INTEGERTV:
result = add_integer_ratio( frame, arg2, arg1 ); result = add_integer_ratio( frame_pointer, arg2, arg1 );
break; break;
case RATIOTV: case RATIOTV:
result = add_ratio_ratio( frame, arg1, arg2 ); result = add_ratio_ratio( frame_pointer, arg1, arg2 );
break; break;
case REALTV: case REALTV:
result = result =
@ -184,9 +184,9 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1,
to_long_double( arg2 ) ); to_long_double( arg2 ) );
break; break;
default: default:
result = lisp_throw( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot add: not a number" ), ( "Cannot add: not a number" ),
frame ); frame_pointer );
break; break;
} }
break; break;
@ -197,8 +197,8 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1,
break; break;
default: default:
result = exceptionp( arg2 ) ? arg2 : result = exceptionp( arg2 ) ? arg2 :
lisp_throw( c_string_to_lisp_string throw_exception( c_string_to_lisp_string
( "Cannot add: not a number" ), frame ); ( "Cannot add: not a number" ), frame_pointer );
} }
} }
@ -218,7 +218,7 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1,
* @return a pointer to an integer or real. * @return a pointer to an integer or real.
*/ */
struct cons_pointer lisp_add( struct stack_frame struct cons_pointer lisp_add( struct stack_frame
*frame, struct *frame, struct cons_pointer frame_pointer, struct
cons_pointer env ) { cons_pointer env ) {
struct cons_pointer result = make_integer( 0 ); struct cons_pointer result = make_integer( 0 );
struct cons_pointer tmp; struct cons_pointer tmp;
@ -227,7 +227,7 @@ struct cons_pointer lisp_add( struct stack_frame
i < args_in_frame && i < args_in_frame &&
!nilp( frame->arg[i] ) && !exceptionp( result ); i++ ) { !nilp( frame->arg[i] ) && !exceptionp( result ); i++ ) {
tmp = result; tmp = result;
result = add_2( frame, result, frame->arg[i] ); result = add_2( frame, frame_pointer, result, frame->arg[i] );
if ( !eq( tmp, result ) ) { if ( !eq( tmp, result ) ) {
dec_ref( tmp ); dec_ref( tmp );
} }
@ -236,7 +236,7 @@ struct cons_pointer lisp_add( struct stack_frame
struct cons_pointer more = frame->more; struct cons_pointer more = frame->more;
while ( consp( more ) && !exceptionp( result ) ) { while ( consp( more ) && !exceptionp( result ) ) {
tmp = result; tmp = result;
result = add_2( frame, result, c_car( more ) ); result = add_2( frame, frame_pointer, result, c_car( more ) );
if ( !eq( tmp, result ) ) { if ( !eq( tmp, result ) ) {
dec_ref( tmp ); dec_ref( tmp );
} }
@ -252,7 +252,7 @@ struct cons_pointer lisp_add( struct stack_frame
* return a cons_pointer indicating a number which is the product of * return a cons_pointer indicating a number which is the product of
* the numbers indicated by `arg1` and `arg2`. * the numbers indicated by `arg1` and `arg2`.
*/ */
struct cons_pointer multiply_2( struct stack_frame *frame, struct cons_pointer multiply_2( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer arg1, struct cons_pointer arg1,
struct cons_pointer arg2 ) { struct cons_pointer arg2 ) {
struct cons_pointer result; struct cons_pointer result;
@ -286,7 +286,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
cell2.payload.integer.value ); cell2.payload.integer.value );
break; break;
case RATIOTV: case RATIOTV:
result = multiply_integer_ratio( frame, arg1, arg2 ); result = multiply_integer_ratio( frame_pointer, arg1, arg2 );
break; break;
case REALTV: case REALTV:
result = result =
@ -294,9 +294,9 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
to_long_double( arg2 ) ); to_long_double( arg2 ) );
break; break;
default: default:
result = lisp_throw( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot multiply: not a number" ), ( "Cannot multiply: not a number" ),
frame ); frame_pointer );
break; break;
} }
break; break;
@ -306,10 +306,10 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
result = arg2; result = arg2;
break; break;
case INTEGERTV: case INTEGERTV:
result = multiply_integer_ratio( frame, arg2, arg1 ); result = multiply_integer_ratio( frame_pointer, arg2, arg1 );
break; break;
case RATIOTV: case RATIOTV:
result = multiply_ratio_ratio( frame, arg1, arg2 ); result = multiply_ratio_ratio( frame_pointer, arg1, arg2 );
break; break;
case REALTV: case REALTV:
result = result =
@ -317,9 +317,9 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
to_long_double( arg2 ) ); to_long_double( arg2 ) );
break; break;
default: default:
result = lisp_throw( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot multiply: not a number" ), ( "Cannot multiply: not a number" ),
frame ); frame_pointer );
} }
break; break;
case REALTV: case REALTV:
@ -328,9 +328,9 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
to_long_double( arg2 ) ); to_long_double( arg2 ) );
break; break;
default: default:
result = lisp_throw( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot multiply: not a number" ), ( "Cannot multiply: not a number" ),
frame ); frame_pointer );
break; break;
} }
} }
@ -353,7 +353,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
*/ */
struct cons_pointer lisp_multiply( struct struct cons_pointer lisp_multiply( struct
stack_frame stack_frame
*frame, struct *frame, struct cons_pointer frame_pointer, struct
cons_pointer env ) { cons_pointer env ) {
struct cons_pointer result = make_integer( 1 ); struct cons_pointer result = make_integer( 1 );
struct cons_pointer tmp; struct cons_pointer tmp;
@ -361,7 +361,7 @@ struct cons_pointer lisp_multiply( struct
for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ) for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] )
&& !exceptionp( result ); i++ ) { && !exceptionp( result ); i++ ) {
tmp = result; tmp = result;
result = multiply_2( frame, result, frame->arg[i] ); result = multiply_2( frame, frame_pointer, result, frame->arg[i] );
if ( !eq( tmp, result ) ) { if ( !eq( tmp, result ) ) {
dec_ref( tmp ); dec_ref( tmp );
@ -372,7 +372,7 @@ struct cons_pointer lisp_multiply( struct
while ( consp( more ) while ( consp( more )
&& !exceptionp( result ) ) { && !exceptionp( result ) ) {
tmp = result; tmp = result;
result = multiply_2( frame, result, c_car( more ) ); result = multiply_2( frame, frame_pointer, result, c_car( more ) );
if ( !eq( tmp, result ) ) { if ( !eq( tmp, result ) ) {
dec_ref( tmp ); dec_ref( tmp );
@ -388,7 +388,7 @@ struct cons_pointer lisp_multiply( struct
* return a cons_pointer indicating a number which is the * return a cons_pointer indicating a number which is the
* inverse of the number indicated by `arg`. * inverse of the number indicated by `arg`.
*/ */
struct cons_pointer inverse( struct stack_frame *frame, struct cons_pointer inverse( struct cons_pointer frame,
struct cons_pointer arg ) { struct cons_pointer arg ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( arg ); struct cons_space_object cell = pointer2cell( arg );
@ -430,7 +430,7 @@ struct cons_pointer inverse( struct stack_frame *frame,
*/ */
struct cons_pointer lisp_subtract( struct struct cons_pointer lisp_subtract( struct
stack_frame stack_frame
*frame, struct *frame, struct cons_pointer frame_pointer, struct
cons_pointer env ) { cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct cons_space_object cell0 = pointer2cell( frame->arg[0] ); struct cons_space_object cell0 = pointer2cell( frame->arg[0] );
@ -451,10 +451,11 @@ struct cons_pointer lisp_subtract( struct
break; break;
case RATIOTV:{ case RATIOTV:{
struct cons_pointer tmp = struct cons_pointer tmp =
make_ratio( frame, frame->arg[0], make_ratio( frame_pointer, frame->arg[0],
make_integer( 1 ) ); make_integer( 1 ) );
inc_ref(tmp);
result = result =
subtract_ratio_ratio( frame, tmp, frame->arg[1] ); subtract_ratio_ratio( frame_pointer, tmp, frame->arg[1] );
dec_ref( tmp ); dec_ref( tmp );
} }
break; break;
@ -464,9 +465,9 @@ struct cons_pointer lisp_subtract( struct
to_long_double( frame->arg[1] ) ); to_long_double( frame->arg[1] ) );
break; break;
default: default:
result = lisp_throw( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot multiply: not a number" ), ( "Cannot subtract: not a number" ),
frame ); frame_pointer );
break; break;
} }
break; break;
@ -477,16 +478,17 @@ struct cons_pointer lisp_subtract( struct
break; break;
case INTEGERTV:{ case INTEGERTV:{
struct cons_pointer tmp = struct cons_pointer tmp =
make_ratio( frame, frame->arg[1], make_ratio( frame_pointer, frame->arg[1],
make_integer( 1 ) ); make_integer( 1 ) );
inc_ref(tmp);
result = result =
subtract_ratio_ratio( frame, frame->arg[0], tmp ); subtract_ratio_ratio( frame_pointer, frame->arg[0], tmp );
dec_ref( tmp ); dec_ref( tmp );
} }
break; break;
case RATIOTV: case RATIOTV:
result = result =
subtract_ratio_ratio( frame, frame->arg[0], subtract_ratio_ratio( frame_pointer, frame->arg[0],
frame->arg[1] ); frame->arg[1] );
break; break;
case REALTV: case REALTV:
@ -495,9 +497,9 @@ struct cons_pointer lisp_subtract( struct
to_long_double( frame->arg[1] ) ); to_long_double( frame->arg[1] ) );
break; break;
default: default:
result = lisp_throw( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot multiply: not a number" ), ( "Cannot subtract: not a number" ),
frame ); frame_pointer );
break; break;
} }
break; break;
@ -507,8 +509,8 @@ struct cons_pointer lisp_subtract( struct
to_long_double( frame->arg[1] ) ); to_long_double( frame->arg[1] ) );
break; break;
default: default:
result = lisp_throw( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot multiply: not a number" ), frame ); ( "Cannot subtract: not a number" ), frame_pointer );
break; break;
} }
@ -525,7 +527,7 @@ struct cons_pointer lisp_subtract( struct
*/ */
struct cons_pointer lisp_divide( struct struct cons_pointer lisp_divide( struct
stack_frame stack_frame
*frame, struct *frame, struct cons_pointer frame_pointer, struct
cons_pointer env ) { cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct cons_space_object arg0 = pointer2cell( frame->arg[0] ); struct cons_space_object arg0 = pointer2cell( frame->arg[0] );
@ -542,8 +544,10 @@ struct cons_pointer lisp_divide( struct
break; break;
case INTEGERTV:{ case INTEGERTV:{
struct cons_pointer unsimplified = struct cons_pointer unsimplified =
make_ratio( frame, frame->arg[0], frame->arg[1] ); make_ratio( frame_pointer, frame->arg[0], frame->arg[1] );
result = simplify_ratio( frame, unsimplified ); /* OK, if result may be unsimplified, we should not inc_ref it
* - but if not, we should dec_ref it. */
result = simplify_ratio( frame_pointer, unsimplified );
if ( !eq( unsimplified, result ) ) { if ( !eq( unsimplified, result ) ) {
dec_ref( unsimplified ); dec_ref( unsimplified );
} }
@ -552,9 +556,9 @@ struct cons_pointer lisp_divide( struct
case RATIOTV:{ case RATIOTV:{
struct cons_pointer one = make_integer( 1 ); struct cons_pointer one = make_integer( 1 );
struct cons_pointer ratio = struct cons_pointer ratio =
make_ratio( frame, frame->arg[0], one ); make_ratio( frame_pointer, frame->arg[0], one );
result = result =
divide_ratio_ratio( frame, ratio, frame->arg[1] ); divide_ratio_ratio( frame_pointer, ratio, frame->arg[1] );
dec_ref( ratio ); dec_ref( ratio );
} }
break; break;
@ -564,9 +568,9 @@ struct cons_pointer lisp_divide( struct
to_long_double( frame->arg[1] ) ); to_long_double( frame->arg[1] ) );
break; break;
default: default:
result = lisp_throw( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot divide: not a number" ), ( "Cannot divide: not a number" ),
frame ); frame_pointer );
break; break;
} }
break; break;
@ -577,16 +581,19 @@ struct cons_pointer lisp_divide( struct
break; break;
case INTEGERTV:{ case INTEGERTV:{
struct cons_pointer one = make_integer( 1 ); struct cons_pointer one = make_integer( 1 );
inc_ref( one);
struct cons_pointer ratio = struct cons_pointer ratio =
make_ratio( frame, frame->arg[1], one ); make_ratio( frame_pointer, frame->arg[1], one );
inc_ref(ratio);
result = result =
divide_ratio_ratio( frame, frame->arg[0], ratio ); divide_ratio_ratio( frame_pointer, frame->arg[0], ratio );
dec_ref( ratio ); dec_ref( ratio );
dec_ref(one);
} }
break; break;
case RATIOTV: case RATIOTV:
result = result =
divide_ratio_ratio( frame, frame->arg[0], divide_ratio_ratio( frame_pointer, frame->arg[0],
frame->arg[1] ); frame->arg[1] );
break; break;
case REALTV: case REALTV:
@ -595,9 +602,9 @@ struct cons_pointer lisp_divide( struct
to_long_double( frame->arg[1] ) ); to_long_double( frame->arg[1] ) );
break; break;
default: default:
result = lisp_throw( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot divide: not a number" ), ( "Cannot divide: not a number" ),
frame ); frame_pointer );
break; break;
} }
break; break;
@ -607,8 +614,8 @@ struct cons_pointer lisp_divide( struct
to_long_double( frame->arg[1] ) ); to_long_double( frame->arg[1] ) );
break; break;
default: default:
result = lisp_throw( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot divide: not a number" ), frame ); ( "Cannot divide: not a number" ), frame_pointer );
break; break;
} }

8
src/arith/peano.h
View file

@ -23,7 +23,7 @@ extern "C" {
* @return a pointer to an integer or real. * @return a pointer to an integer or real.
*/ */
struct cons_pointer struct cons_pointer
lisp_add( struct stack_frame *frame, struct cons_pointer env ); lisp_add( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env );
/** /**
* Multiply an indefinite number of numbers together * Multiply an indefinite number of numbers together
@ -32,7 +32,7 @@ extern "C" {
* @return a pointer to an integer or real. * @return a pointer to an integer or real.
*/ */
struct cons_pointer struct cons_pointer
lisp_multiply( struct stack_frame *frame, struct cons_pointer env ); lisp_multiply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env );
/** /**
* Subtract one number from another. * Subtract one number from another.
@ -41,7 +41,7 @@ extern "C" {
* @return a pointer to an integer or real. * @return a pointer to an integer or real.
*/ */
struct cons_pointer struct cons_pointer
lisp_subtract( struct stack_frame *frame, struct cons_pointer env ); lisp_subtract( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env );
/** /**
* Divide one number by another. * Divide one number by another.
@ -50,7 +50,7 @@ extern "C" {
* @return a pointer to an integer or real. * @return a pointer to an integer or real.
*/ */
struct cons_pointer struct cons_pointer
lisp_divide( struct stack_frame *frame, struct cons_pointer env ); lisp_divide( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env );
#ifdef __cplusplus #ifdef __cplusplus
} }

77
src/arith/ratio.c
View file

@ -13,6 +13,7 @@
#include "conspage.h" #include "conspage.h"
#include "consspaceobject.h" #include "consspaceobject.h"
#include "dump.h"
#include "equal.h" #include "equal.h"
#include "integer.h" #include "integer.h"
#include "lispops.h" #include "lispops.h"
@ -24,7 +25,7 @@
* declared in peano.c, can't include piano.h here because * declared in peano.c, can't include piano.h here because
* circularity. TODO: refactor. * circularity. TODO: refactor.
*/ */
struct cons_pointer inverse( struct stack_frame *frame, struct cons_pointer inverse( struct cons_pointer frame_pointer,
struct cons_pointer arg ); struct cons_pointer arg );
/** /**
@ -54,7 +55,7 @@ int64_t least_common_multiple( int64_t m, int64_t n ) {
* be in a simplified representation. If `arg` isn't a ratio, * be in a simplified representation. If `arg` isn't a ratio,
* will throw exception. * will throw exception.
*/ */
struct cons_pointer simplify_ratio( struct stack_frame *frame, struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg ) { struct cons_pointer arg ) {
struct cons_pointer result = arg; struct cons_pointer result = arg;
@ -70,15 +71,15 @@ struct cons_pointer simplify_ratio( struct stack_frame *frame,
result = make_integer( ddrv / gcd ); result = make_integer( ddrv / gcd );
} else { } else {
result = result =
make_ratio( frame, make_integer( ddrv / gcd ), make_ratio( frame_pointer, make_integer( ddrv / gcd ),
make_integer( drrv / gcd ) ); make_integer( drrv / gcd ) );
} }
} }
} else { } else {
result = result =
lisp_throw( make_cons( c_string_to_lisp_string throw_exception( make_cons( c_string_to_lisp_string
( "Shouldn't happen: bad arg to simplify_ratio" ), ( "Shouldn't happen: bad arg to simplify_ratio" ),
arg ), frame ); arg ), frame_pointer );
} }
return result; return result;
@ -91,7 +92,7 @@ struct cons_pointer simplify_ratio( struct stack_frame *frame,
* the ratios indicated by `arg1` and `arg2`. If you pass non-ratios, * the ratios indicated by `arg1` and `arg2`. If you pass non-ratios,
* this is going to break horribly. * this is going to break horribly.
*/ */
struct cons_pointer add_ratio_ratio( struct stack_frame *frame, struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1, struct cons_pointer arg1,
struct cons_pointer arg2 ) { struct cons_pointer arg2 ) {
struct cons_pointer r, result; struct cons_pointer r, result;
@ -123,7 +124,7 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame,
#endif #endif
if ( dr1v == dr2v ) { if ( dr1v == dr2v ) {
r = make_ratio( frame, r = make_ratio( frame_pointer,
make_integer( dd1v + dd2v ), make_integer( dd1v + dd2v ),
cell1.payload.ratio.divisor ); cell1.payload.ratio.divisor );
} else { } else {
@ -131,10 +132,10 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame,
dr1vm = make_integer( dr1v * m1 ), dr1vm = make_integer( dr1v * m1 ),
dd2vm = make_integer( dd2v * m2 ), dd2vm = make_integer( dd2v * m2 ),
dr2vm = make_integer( dr2v * m2 ), dr2vm = make_integer( dr2v * m2 ),
r1 = make_ratio( frame, dd1vm, dr1vm ), r1 = make_ratio( frame_pointer, dd1vm, dr1vm ),
r2 = make_ratio( frame, dd2vm, dr2vm ); r2 = make_ratio( frame_pointer, dd2vm, dr2vm );
r = add_ratio_ratio( frame, r1, r2 ); r = add_ratio_ratio( frame_pointer, r1, r2 );
/* because the references on dd1vm, dr1vm, dd2vm and dr2vm were /* because the references on dd1vm, dr1vm, dd2vm and dr2vm were
* never incremented except when making r1 and r2, decrementing * never incremented except when making r1 and r2, decrementing
@ -143,17 +144,17 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame,
dec_ref( r2 ); dec_ref( r2 );
} }
result = simplify_ratio( frame, r ); result = simplify_ratio( frame_pointer, r );
if ( !eq( r, result ) ) { if ( !eq( r, result ) ) {
dec_ref( r ); dec_ref( r );
} }
} else { } else {
result = result =
lisp_throw( make_cons( c_string_to_lisp_string throw_exception( make_cons( c_string_to_lisp_string
( "Shouldn't happen: bad arg to add_ratio_ratio" ), ( "Shouldn't happen: bad arg to add_ratio_ratio" ),
make_cons( arg1, make_cons( arg1,
make_cons( arg2, NIL ) ) ), make_cons( arg2, NIL ) ) ),
frame ); frame_pointer );
} }
#ifdef DEBUG #ifdef DEBUG
@ -171,26 +172,26 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame,
* the intger indicated by `intarg` and the ratio indicated by * the intger indicated by `intarg` and the ratio indicated by
* `ratarg`. If you pass other types, this is going to break horribly. * `ratarg`. If you pass other types, this is going to break horribly.
*/ */
struct cons_pointer add_integer_ratio( struct stack_frame *frame, struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer,
struct cons_pointer intarg, struct cons_pointer intarg,
struct cons_pointer ratarg ) { struct cons_pointer ratarg ) {
struct cons_pointer result; struct cons_pointer result;
if ( integerp( intarg ) && ratiop( ratarg ) ) { if ( integerp( intarg ) && ratiop( ratarg ) ) {
struct cons_pointer one = make_integer( 1 ), struct cons_pointer one = make_integer( 1 ),
ratio = make_ratio( frame, intarg, one ); ratio = make_ratio( frame_pointer, intarg, one );
result = add_ratio_ratio( frame, ratio, ratarg ); result = add_ratio_ratio( frame_pointer, ratio, ratarg );
dec_ref( one ); dec_ref( one );
dec_ref( ratio ); dec_ref( ratio );
} else { } else {
result = result =
lisp_throw( make_cons( c_string_to_lisp_string throw_exception( make_cons( c_string_to_lisp_string
( "Shouldn't happen: bad arg to add_integer_ratio" ), ( "Shouldn't happen: bad arg to add_integer_ratio" ),
make_cons( intarg, make_cons( intarg,
make_cons( ratarg, NIL ) ) ), make_cons( ratarg, NIL ) ) ),
frame ); frame_pointer );
} }
return result; return result;
@ -201,15 +202,15 @@ struct cons_pointer add_integer_ratio( struct stack_frame *frame,
* indicated by `arg1` divided by the ratio indicated by `arg2`. If either * indicated by `arg1` divided by the ratio indicated by `arg2`. If either
* of these aren't RTIO cells, something horrid will happen and it is YOUR FAULT. * of these aren't RTIO cells, something horrid will happen and it is YOUR FAULT.
*/ */
struct cons_pointer divide_ratio_ratio( struct stack_frame *frame, struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1, struct cons_pointer arg1,
struct cons_pointer arg2 ) { struct cons_pointer arg2 ) {
struct cons_pointer i = make_ratio( frame, struct cons_pointer i = make_ratio( frame_pointer,
pointer2cell( arg2 ).payload.ratio. pointer2cell( arg2 ).payload.ratio.
divisor, divisor,
pointer2cell( arg2 ).payload.ratio. pointer2cell( arg2 ).payload.ratio.
dividend ), result = dividend ), result =
multiply_ratio_ratio( frame, arg1, i ); multiply_ratio_ratio( frame_pointer, arg1, i );
dec_ref( i ); dec_ref( i );
@ -221,9 +222,7 @@ struct cons_pointer divide_ratio_ratio( struct stack_frame *frame,
* the ratios indicated by `arg1` and `arg2`. If you pass non-ratios, * the ratios indicated by `arg1` and `arg2`. If you pass non-ratios,
* this is going to break horribly. * this is going to break horribly.
*/ */
struct cons_pointer multiply_ratio_ratio( struct struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, struct
stack_frame
*frame, struct
cons_pointer arg1, struct cons_pointer arg1, struct
cons_pointer arg2 ) { cons_pointer arg2 ) {
struct cons_pointer result; struct cons_pointer result;
@ -249,18 +248,18 @@ struct cons_pointer multiply_ratio_ratio( struct
ddrv = dd1v * dd2v, drrv = dr1v * dr2v; ddrv = dd1v * dd2v, drrv = dr1v * dr2v;
struct cons_pointer unsimplified = struct cons_pointer unsimplified =
make_ratio( frame, make_integer( ddrv ), make_ratio( frame_pointer, make_integer( ddrv ),
make_integer( drrv ) ); make_integer( drrv ) );
result = simplify_ratio( frame, unsimplified ); result = simplify_ratio( frame_pointer, unsimplified );
if ( !eq( unsimplified, result ) ) { if ( !eq( unsimplified, result ) ) {
dec_ref( unsimplified ); dec_ref( unsimplified );
} }
} else { } else {
result = result =
lisp_throw( c_string_to_lisp_string throw_exception( c_string_to_lisp_string
( "Shouldn't happen: bad arg to multiply_ratio_ratio" ), ( "Shouldn't happen: bad arg to multiply_ratio_ratio" ),
frame ); frame_pointer );
} }
return result; return result;
@ -271,23 +270,23 @@ struct cons_pointer multiply_ratio_ratio( struct
* the intger indicated by `intarg` and the ratio indicated by * the intger indicated by `intarg` and the ratio indicated by
* `ratarg`. If you pass other types, this is going to break horribly. * `ratarg`. If you pass other types, this is going to break horribly.
*/ */
struct cons_pointer multiply_integer_ratio( struct stack_frame *frame, struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer,
struct cons_pointer intarg, struct cons_pointer intarg,
struct cons_pointer ratarg ) { struct cons_pointer ratarg ) {
struct cons_pointer result; struct cons_pointer result;
if ( integerp( intarg ) && ratiop( ratarg ) ) { if ( integerp( intarg ) && ratiop( ratarg ) ) {
struct cons_pointer one = make_integer( 1 ), struct cons_pointer one = make_integer( 1 ),
ratio = make_ratio( frame, intarg, one ); ratio = make_ratio( frame_pointer, intarg, one );
result = multiply_ratio_ratio( frame, ratio, ratarg ); result = multiply_ratio_ratio( frame_pointer, ratio, ratarg );
dec_ref( one ); dec_ref( one );
dec_ref( ratio ); dec_ref( ratio );
} else { } else {
result = result =
lisp_throw( c_string_to_lisp_string throw_exception( c_string_to_lisp_string
( "Shouldn't happen: bad arg to multiply_integer_ratio" ), ( "Shouldn't happen: bad arg to multiply_integer_ratio" ),
frame ); frame_pointer );
} }
return result; return result;
@ -299,11 +298,11 @@ struct cons_pointer multiply_integer_ratio( struct stack_frame *frame,
* the ratios indicated by `arg1` and `arg2`. If you pass non-ratios, * the ratios indicated by `arg1` and `arg2`. If you pass non-ratios,
* this is going to break horribly. * this is going to break horribly.
*/ */
struct cons_pointer subtract_ratio_ratio( struct stack_frame *frame, struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1, struct cons_pointer arg1,
struct cons_pointer arg2 ) { struct cons_pointer arg2 ) {
struct cons_pointer i = inverse( frame, arg2 ), struct cons_pointer i = inverse( frame_pointer, arg2 ),
result = add_ratio_ratio( frame, arg1, i ); result = add_ratio_ratio( frame_pointer, arg1, i );
dec_ref( i ); dec_ref( i );
@ -315,7 +314,7 @@ struct cons_pointer subtract_ratio_ratio( struct stack_frame *frame,
* Construct a ratio frame from these two pointers, expected to be integers * Construct a ratio frame from these two pointers, expected to be integers
* or (later) bignums, in the context of this stack_frame. * or (later) bignums, in the context of this stack_frame.
*/ */
struct cons_pointer make_ratio( struct stack_frame *frame, struct cons_pointer make_ratio( struct cons_pointer frame_pointer,
struct cons_pointer dividend, struct cons_pointer dividend,
struct cons_pointer divisor ) { struct cons_pointer divisor ) {
struct cons_pointer result; struct cons_pointer result;
@ -328,9 +327,9 @@ struct cons_pointer make_ratio( struct stack_frame *frame,
cell->payload.ratio.divisor = divisor; cell->payload.ratio.divisor = divisor;
} else { } else {
result = result =
lisp_throw( c_string_to_lisp_string throw_exception( c_string_to_lisp_string
( "Dividend and divisor of a ratio must be integers" ), ( "Dividend and divisor of a ratio must be integers" ),
frame ); frame_pointer );
} }
#ifdef DEBUG #ifdef DEBUG
dump_object( stderr, result ); dump_object( stderr, result );

18
src/arith/ratio.h
View file

@ -11,36 +11,34 @@
#ifndef __ratio_h #ifndef __ratio_h
#define __ratio_h #define __ratio_h
struct cons_pointer simplify_ratio( struct stack_frame *frame, struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg ); struct cons_pointer arg );
struct cons_pointer add_ratio_ratio( struct stack_frame *frame, struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1, struct cons_pointer arg1,
struct cons_pointer arg2 ); struct cons_pointer arg2 );
struct cons_pointer add_integer_ratio( struct stack_frame *frame, struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer,
struct cons_pointer intarg, struct cons_pointer intarg,
struct cons_pointer ratarg ); struct cons_pointer ratarg );
struct cons_pointer divide_ratio_ratio( struct stack_frame *frame, struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1, struct cons_pointer arg1,
struct cons_pointer arg2 ); struct cons_pointer arg2 );
struct cons_pointer multiply_ratio_ratio( struct struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, struct
stack_frame
*frame, struct
cons_pointer arg1, struct cons_pointer arg1, struct
cons_pointer arg2 ); cons_pointer arg2 );
struct cons_pointer multiply_integer_ratio( struct stack_frame *frame, struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer,
struct cons_pointer intarg, struct cons_pointer intarg,
struct cons_pointer ratarg ); struct cons_pointer ratarg );
struct cons_pointer subtract_ratio_ratio( struct stack_frame *frame, struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1, struct cons_pointer arg1,
struct cons_pointer arg2 ); struct cons_pointer arg2 );
struct cons_pointer make_ratio( struct stack_frame *frame, struct cons_pointer make_ratio( struct cons_pointer frame_pointer,
struct cons_pointer dividend, struct cons_pointer dividend,
struct cons_pointer divisor ); struct cons_pointer divisor );

2
src/init.c
View file

@ -90,6 +90,7 @@ int main( int argc, char *argv[] ) {
bind_function( "eq", &lisp_eq ); bind_function( "eq", &lisp_eq );
bind_function( "equal", &lisp_equal ); bind_function( "equal", &lisp_equal );
bind_function( "eval", &lisp_eval ); bind_function( "eval", &lisp_eval );
bind_function( "exception", &lisp_exception );
bind_function( "multiply", &lisp_multiply ); bind_function( "multiply", &lisp_multiply );
bind_function( "read", &lisp_read ); bind_function( "read", &lisp_read );
bind_function( "oblist", &lisp_oblist ); bind_function( "oblist", &lisp_oblist );
@ -98,6 +99,7 @@ int main( int argc, char *argv[] ) {
bind_function( "reverse", &lisp_reverse ); bind_function( "reverse", &lisp_reverse );
bind_function( "set", &lisp_set ); bind_function( "set", &lisp_set );
bind_function( "subtract", &lisp_subtract ); bind_function( "subtract", &lisp_subtract );
bind_function( "throw", &lisp_exception );
bind_function( "type", &lisp_type ); bind_function( "type", &lisp_type );
bind_function( "+", &lisp_add ); bind_function( "+", &lisp_add );

110
src/memory/consspaceobject.c
View file

@ -63,98 +63,6 @@ void dec_ref( struct cons_pointer pointer ) {
} }
} }
void dump_string_cell( FILE * output, wchar_t *prefix,
struct cons_pointer pointer ) {
struct cons_space_object cell = pointer2cell( pointer );
if ( cell.payload.string.character == 0 ) {
fwprintf( output,
L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n",
prefix,
cell.payload.string.cdr.page, cell.payload.string.cdr.offset,
cell.count );
} else {
fwprintf( output,
L"\t\t%ls cell: character '%lc' (%d) next at page %d offset %d, count %u\n",
prefix,
( wint_t ) cell.payload.string.character,
cell.payload.string.character,
cell.payload.string.cdr.page,
cell.payload.string.cdr.offset, cell.count );
fwprintf( output, L"\t\t value: " );
print( output, pointer );
fwprintf( output, L"\n" );
}
}
/**
* dump the object at this cons_pointer to this output stream.
*/
void dump_object( FILE * output, struct cons_pointer pointer ) {
struct cons_space_object cell = pointer2cell( pointer );
fwprintf( output,
L"\t%c%c%c%c (%d) at page %d, offset %d count %u\n",
cell.tag.bytes[0],
cell.tag.bytes[1],
cell.tag.bytes[2],
cell.tag.bytes[3],
cell.tag.value, pointer.page, pointer.offset, cell.count );
switch ( cell.tag.value ) {
case CONSTV:
fwprintf( output,
L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u\n",
cell.payload.cons.car.page,
cell.payload.cons.car.offset,
cell.payload.cons.cdr.page,
cell.payload.cons.cdr.offset, cell.count );
break;
case EXCEPTIONTV:
fwprintf( output, L"\t\tException cell: " );
print( output, cell.payload.exception.message );
fwprintf( output, L"\n" );
for ( struct stack_frame * frame = cell.payload.exception.frame;
frame != NULL; frame = frame->previous ) {
dump_frame( output, frame );
}
break;
case FREETV:
fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n",
cell.payload.cons.cdr.page,
cell.payload.cons.cdr.offset );
break;
case INTEGERTV:
fwprintf( output,
L"\t\tInteger cell: value %ld, count %u\n",
cell.payload.integer.value, cell.count );
break;
case LAMBDATV:
fwprintf( output, L"\t\tLambda cell; args: " );
print( output, cell.payload.lambda.args );
fwprintf( output, L";\n\t\t\tbody: " );
print( output, cell.payload.lambda.body );
break;
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 );
break;
case READTV:
fwprintf( output, L"\t\tInput stream\n" );
case REALTV:
fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n",
cell.payload.real.value, cell.count );
break;
case STRINGTV:
dump_string_cell( output, L"String", pointer );
break;
case SYMBOLTV:
dump_string_cell( output, L"Symbol", pointer );
break;
}
}
/** /**
* Construct a cons cell from this pair of pointers. * Construct a cons cell from this pair of pointers.
@ -178,20 +86,24 @@ struct cons_pointer make_cons( struct cons_pointer car,
/** /**
* Construct an exception cell. * Construct an exception cell.
* @param message should be a lisp string describing the problem, but actually any cons pointer will do; * @param message should be a lisp string describing the problem, but actually any cons pointer will do;
* @param frame should be the frame in which the exception occurred. * @param frame_pointer should be the pointer to the frame in which the exception occurred.
*/ */
struct cons_pointer make_exception( struct cons_pointer message, struct cons_pointer make_exception( struct cons_pointer message,
struct stack_frame *frame ) { struct cons_pointer frame_pointer ) {
struct cons_pointer result = NIL;
struct cons_pointer pointer = allocate_cell( EXCEPTIONTAG ); struct cons_pointer pointer = allocate_cell( EXCEPTIONTAG );
struct cons_space_object *cell = &pointer2cell( pointer ); struct cons_space_object *cell = &pointer2cell( pointer );
inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */ inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */
inc_ref( message ); inc_ref( message );
inc_ref( frame_pointer);
cell->payload.exception.message = message; cell->payload.exception.message = message;
cell->payload.exception.frame = frame; cell->payload.exception.frame = frame_pointer;
return pointer; result = pointer;
return result;
} }
@ -200,7 +112,8 @@ struct cons_pointer make_exception( struct cons_pointer message,
*/ */
struct cons_pointer struct cons_pointer
make_function( struct cons_pointer src, struct cons_pointer ( *executable ) make_function( struct cons_pointer src, struct cons_pointer ( *executable )
( struct stack_frame *, struct cons_pointer ) ) { ( struct stack_frame *,
struct cons_pointer, struct cons_pointer ) ) {
struct cons_pointer pointer = allocate_cell( FUNCTIONTAG ); struct cons_pointer pointer = allocate_cell( FUNCTIONTAG );
struct cons_space_object *cell = &pointer2cell( pointer ); struct cons_space_object *cell = &pointer2cell( pointer );
@ -298,7 +211,8 @@ struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) {
*/ */
struct cons_pointer struct cons_pointer
make_special( struct cons_pointer src, struct cons_pointer ( *executable ) make_special( struct cons_pointer src, struct cons_pointer ( *executable )
( struct stack_frame * frame, struct cons_pointer env ) ) { ( struct stack_frame * frame,
struct cons_pointer, struct cons_pointer env ) ) {
struct cons_pointer pointer = allocate_cell( SPECIALTAG ); struct cons_pointer pointer = allocate_cell( SPECIALTAG );
struct cons_space_object *cell = &pointer2cell( pointer ); struct cons_space_object *cell = &pointer2cell( pointer );

36
src/memory/consspaceobject.h
View file

@ -278,13 +278,14 @@ struct cons_pointer {
* here to avoid circularity. TODO: refactor. * here to avoid circularity. TODO: refactor.
*/ */
struct stack_frame { struct stack_frame {
struct stack_frame *previous; /* the previous frame */ struct cons_pointer previous; /* the previous frame */
struct cons_pointer arg[args_in_frame]; struct cons_pointer arg[args_in_frame];
/* /*
* first 8 arument bindings * first 8 arument bindings
*/ */
struct cons_pointer more; /* list of any further argument bindings */ struct cons_pointer more; /* list of any further argument bindings */
struct cons_pointer function; /* the function to be called */ struct cons_pointer function; /* the function to be called */
int args;
}; };
/** /**
@ -311,7 +312,7 @@ struct cons_payload {
*/ */
struct exception_payload { struct exception_payload {
struct cons_pointer message; struct cons_pointer message;
struct stack_frame *frame; struct cons_pointer frame;
}; };
/** /**
@ -326,6 +327,7 @@ struct exception_payload {
struct function_payload { struct function_payload {
struct cons_pointer source; struct cons_pointer source;
struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer ( *executable ) ( struct stack_frame *,
struct cons_pointer,
struct cons_pointer ); struct cons_pointer );
}; };
@ -379,13 +381,11 @@ struct real_payload {
* its argument list) and a cons pointer (representing its environment) and a * its argument list) and a cons pointer (representing its environment) and a
* stack frame (representing the previous stack frame) as arguments and returns * stack frame (representing the previous stack frame) as arguments and returns
* a cons pointer (representing its result). * a cons pointer (representing its result).
*
* NOTE that this means that special forms do not appear on the lisp stack,
* which may be confusing. TODO: think about this.
*/ */
struct special_payload { struct special_payload {
struct cons_pointer source; struct cons_pointer source;
struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer ( *executable ) ( struct stack_frame *,
struct cons_pointer,
struct cons_pointer ); struct cons_pointer );
}; };
@ -421,7 +421,8 @@ struct vectorp_payload {
* tag. */ * tag. */
uint32_t value; /* the tag considered as a number */ uint32_t value; /* the tag considered as a number */
} tag; } tag;
uint64_t address; /* the address of the actual vector space struct vector_space_object * address;
/* the address of the actual vector space
* object (TODO: will change when I actually * object (TODO: will change when I actually
* implement vector space) */ * implement vector space) */
}; };
@ -514,20 +515,11 @@ void inc_ref( struct cons_pointer pointer );
*/ */
void dec_ref( struct cons_pointer pointer ); void dec_ref( struct cons_pointer pointer );
/**
* dump the object at this cons_pointer to this output stream.
*/
void dump_object( FILE * output, struct cons_pointer pointer );
struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer make_cons( struct cons_pointer car,
struct cons_pointer cdr ); struct cons_pointer cdr );
/**
* Construct an exception cell.
* @param message should be a lisp string describing the problem, but actually any cons pointer will do;
* @param frame should be the frame in which the exception occurred.
*/
struct cons_pointer make_exception( struct cons_pointer message, struct cons_pointer make_exception( struct cons_pointer message,
struct stack_frame *frame ); struct cons_pointer frame_pointer );
/** /**
* Construct a cell which points to an executable Lisp special form. * Construct a cell which points to an executable Lisp special form.
@ -535,6 +527,7 @@ struct cons_pointer make_exception( struct cons_pointer message,
struct cons_pointer make_function( struct cons_pointer src, struct cons_pointer make_function( struct cons_pointer src,
struct cons_pointer ( *executable ) struct cons_pointer ( *executable )
( struct stack_frame *, ( struct stack_frame *,
struct cons_pointer,
struct cons_pointer ) ); struct cons_pointer ) );
/** /**
@ -550,20 +543,13 @@ struct cons_pointer make_lambda( struct cons_pointer args,
struct cons_pointer make_nlambda( struct cons_pointer args, struct cons_pointer make_nlambda( struct cons_pointer args,
struct cons_pointer body ); struct cons_pointer body );
/**
* Construct a ratio frame from these two pointers, expected to be integers
* or (later) bignums, in the context of this stack_frame.
*/
struct cons_pointer make_ratio( struct stack_frame *frame,
struct cons_pointer dividend,
struct cons_pointer divisor );
/** /**
* Construct a cell which points to an executable Lisp special form. * Construct a cell which points to an executable Lisp special form.
*/ */
struct cons_pointer make_special( struct cons_pointer src, struct cons_pointer make_special( struct cons_pointer src,
struct cons_pointer ( *executable ) struct cons_pointer ( *executable )
( struct stack_frame *, ( struct stack_frame *,
struct cons_pointer,
struct cons_pointer ) ); struct cons_pointer ) );
/** /**

120
src/memory/dump.c Normal file
View file

@ -0,0 +1,120 @@
/*
* dump.c
*
* Dump representations of both cons space and vector space objects.
*
*
* (c) 2018 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdint.h>
#include <stdlib.h>
#include <string.h>
#include <stdio.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include "conspage.h"
#include "consspaceobject.h"
#include "print.h"
#include "stack.h"
#include "vectorspace.h"
void dump_string_cell( FILE * output, wchar_t *prefix,
struct cons_pointer pointer ) {
struct cons_space_object cell = pointer2cell( pointer );
if ( cell.payload.string.character == 0 ) {
fwprintf( output,
L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n",
prefix,
cell.payload.string.cdr.page, cell.payload.string.cdr.offset,
cell.count );
} else {
fwprintf( output,
L"\t\t%ls cell: character '%lc' (%d) next at page %d offset %d, count %u\n",
prefix,
( wint_t ) cell.payload.string.character,
cell.payload.string.character,
cell.payload.string.cdr.page,
cell.payload.string.cdr.offset, cell.count );
fwprintf( output, L"\t\t value: " );
print( output, pointer );
fwprintf( output, L"\n" );
}
}
/**
* dump the object at this cons_pointer to this output stream.
*/
void dump_object( FILE * output, struct cons_pointer pointer ) {
struct cons_space_object cell = pointer2cell( pointer );
fwprintf( output,
L"\t%c%c%c%c (%d) at page %d, offset %d count %u\n",
cell.tag.bytes[0],
cell.tag.bytes[1],
cell.tag.bytes[2],
cell.tag.bytes[3],
cell.tag.value, pointer.page, pointer.offset, cell.count );
switch ( cell.tag.value ) {
case CONSTV:
fwprintf( output,
L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u\n",
cell.payload.cons.car.page,
cell.payload.cons.car.offset,
cell.payload.cons.cdr.page,
cell.payload.cons.cdr.offset, cell.count );
break;
case EXCEPTIONTV:
fwprintf( output, L"\t\tException cell: " );
dump_stack_trace( output, pointer);
break;
case FREETV:
fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n",
cell.payload.cons.cdr.page,
cell.payload.cons.cdr.offset );
break;
case INTEGERTV:
fwprintf( output,
L"\t\tInteger cell: value %ld, count %u\n",
cell.payload.integer.value, cell.count );
break;
case LAMBDATV:
fwprintf( output, L"\t\tLambda cell; args: " );
print( output, cell.payload.lambda.args );
fwprintf( output, L";\n\t\t\tbody: " );
print( output, cell.payload.lambda.body );
break;
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 );
break;
case READTV:
fwprintf( output, L"\t\tInput stream\n" );
case REALTV:
fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n",
cell.payload.real.value, cell.count );
break;
case STRINGTV:
dump_string_cell( output, L"String", pointer );
break;
case SYMBOLTV:
dump_string_cell( output, L"Symbol", pointer );
break;
case VECTORPOINTTV: {
struct vector_space_object * vso = cell.payload.vectorp.address;
fwprintf( output, L"\t\tVector space object of type %4.4s, payload size %d bytes\n",
vso->header.tag, vso->header.size);
}
break;
}
}

29
src/memory/dump.h Normal file
View file

@ -0,0 +1,29 @@
/**
* dump.h
*
* Dump representations of both cons space and vector space objects.
*
* (c) 2018 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdbool.h>
#include <stdint.h>
#include <stdio.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#ifndef __dump_h
#define __dump_h
/**
* dump the object at this cons_pointer to this output stream.
*/
void dump_object( FILE * output, struct cons_pointer pointer );
#endif

163
src/memory/stack.c
View file

@ -11,9 +11,6 @@
* with freelists to a more general 'equal sized object pages', so that * with freelists to a more general 'equal sized object pages', so that
* allocating/freeing stack frames can be more efficient. * allocating/freeing stack frames can be more efficient.
* *
* Stack frames are not yet a first class object; they have no VECP pointer
* in cons space.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc> * (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version. * Licensed under GPL version 2.0, or, at your option, any later version.
*/ */
@ -25,36 +22,57 @@
#include "lispops.h" #include "lispops.h"
#include "print.h" #include "print.h"
#include "stack.h" #include "stack.h"
#include "vectorspace.h"
/** /**
* Make an empty stack frame, and return it. * get the actual stackframe object from this `pointer`, or NULL if
* @param previous the current top-of-stack; * `pointer` is not a stackframe pointer.
* @param env the environment in which evaluation happens.
* @return the new frame.
*/
struct stack_frame *make_empty_frame( struct stack_frame *previous,
struct cons_pointer env ) {
struct stack_frame *result = malloc( sizeof( struct stack_frame ) );
/*
* TODO: later, pop a frame off a free-list of stack frames
*/ */
struct stack_frame * get_stack_frame(struct cons_pointer pointer) {
struct stack_frame * result = NULL;
struct vector_space_object * vso =
pointer2cell(pointer).payload.vectorp.address;
result->previous = previous; if (vectorpointp(pointer) && stackframep(vso))
{
/* result = (struct stack_frame *) &(vso->payload);
* clearing the frame with memset would probably be slightly quicker, but
* this is clear.
*/
result->more = NIL;
result->function = NIL;
for ( int i = 0; i < args_in_frame; i++ ) {
set_reg( result, i, NIL );
} }
return result; return result;
} }
/**
* Make an empty stack frame, and return it.
* @param previous the current top-of-stack;
* @param env the environment in which evaluation happens.
* @return the new frame, or NULL if memory is exhausted.
*/
struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
struct cons_pointer result = make_vso(STACKFRAMETAG, sizeof(struct stack_frame));
if (!nilp(result)) {
struct stack_frame *frame = get_stack_frame(result);
/*
* TODO: later, pop a frame off a free-list of stack frames
*/
frame->previous = previous;
inc_ref(previous);
/*
* clearing the frame with memset would probably be slightly quicker, but
* this is clear.
*/
frame->more = NIL;
frame->function = NIL;
frame->args = 0;
for ( int i = 0; i < args_in_frame; i++ ) {
set_reg( frame, i, NIL );
}
}
return result;
}
/** /**
* Allocate a new stack frame with its previous pointer set to this value, * Allocate a new stack frame with its previous pointer set to this value,
@ -62,15 +80,21 @@ struct stack_frame *make_empty_frame( struct stack_frame *previous,
* @param previous the current top-of-stack; * @param previous the current top-of-stack;
* @args the arguments to load into this frame; * @args the arguments to load into this frame;
* @param env the environment in which evaluation happens. * @param env the environment in which evaluation happens.
* @return the new frame. * @return the new frame, or an exception if one occurred while building it.
*/ */
struct stack_frame *make_stack_frame( struct stack_frame *previous, struct cons_pointer make_stack_frame( struct cons_pointer previous,
struct cons_pointer args, struct cons_pointer args,
struct cons_pointer env, struct cons_pointer env ) {
struct cons_pointer *exception ) { struct cons_pointer result = make_empty_frame( previous );
struct stack_frame *result = make_empty_frame( previous, env );
for ( int i = 0; i < args_in_frame && consp( args ); i++ ) { if (nilp(result))
{
/* i.e. out of memory */
result = make_exception(c_string_to_lisp_string( "Memory exhausted."), previous);
} else {
struct stack_frame * frame = get_stack_frame(result);
for ( frame->args = 0; frame->args < args_in_frame && consp( args ); frame->args++ ) {
/* iterate down the arg list filling in the arg slots in the /* iterate down the arg list filling in the arg slots in the
* frame. When there are no more slots, if there are still args, * frame. When there are no more slots, if there are still args,
* stash them on more */ * stash them on more */
@ -82,29 +106,43 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous,
* processor to be evaled in parallel; but see notes here: * processor to be evaled in parallel; but see notes here:
* https://github.com/simon-brooke/post-scarcity/wiki/parallelism * https://github.com/simon-brooke/post-scarcity/wiki/parallelism
*/ */
struct stack_frame *arg_frame = make_empty_frame( result, env ); struct cons_pointer arg_frame_pointer = make_empty_frame( result);
set_reg( arg_frame, 0, cell.payload.cons.car ); inc_ref(arg_frame_pointer);
struct cons_pointer val = lisp_eval( arg_frame, env ); if(nilp(arg_frame_pointer)) {
if ( exceptionp( val ) ) { result = make_exception(c_string_to_lisp_string( "Memory exhausted."), previous);
exception = &val;
break; break;
} else { } else {
set_reg( result, i, val ); struct stack_frame *arg_frame = get_stack_frame( arg_frame_pointer );
set_reg( arg_frame, 0, cell.payload.cons.car );
struct cons_pointer val = lisp_eval( arg_frame, arg_frame_pointer, env );
if ( exceptionp( val ) ) {
result = val;
break;
} else {
set_reg( frame, frame->args, val );
} }
free_stack_frame( arg_frame ); dec_ref(arg_frame_pointer);
args = cell.payload.cons.cdr; args = cell.payload.cons.cdr;
} }
}
if (!exceptionp(result)) {
if ( consp( args ) ) { if ( consp( args ) ) {
/* if we still have args, eval them and stick the values on `more` */ /* if we still have args, eval them and stick the values on `more` */
struct cons_pointer more = eval_forms( previous, args, env ); struct cons_pointer more = eval_forms( get_stack_frame(previous), previous, args, env );
result->more = more; frame->more = more;
inc_ref( more ); inc_ref( more );
} }
#ifdef DEBUG
dump_frame( stderr, result ); dump_frame( stderr, result );
#endif
}
}
return result; return result;
} }
@ -116,26 +154,40 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous,
* @param env the execution environment; * @param env the execution environment;
* @return a new special frame. * @return a new special frame.
*/ */
struct stack_frame *make_special_frame( struct stack_frame *previous, struct cons_pointer make_special_frame( struct cons_pointer previous,
struct cons_pointer args, struct cons_pointer args,
struct cons_pointer env ) { struct cons_pointer env ) {
struct stack_frame *result = make_empty_frame( previous, env ); struct cons_pointer result = make_empty_frame( previous );
for ( int i = 0; i < args_in_frame && !nilp( args ); i++ ) { if (nilp(result))
{
/* i.e. out of memory */
result = make_exception(c_string_to_lisp_string( "Memory exhausted."), previous);
} else {
struct stack_frame * frame = get_stack_frame(result);
for ( frame->args = 0; frame->args < args_in_frame && !nilp( args ); frame->args++ ) {
/* iterate down the arg list filling in the arg slots in the /* iterate down the arg list filling in the arg slots in the
* frame. When there are no more slots, if there are still args, * frame. When there are no more slots, if there are still args,
* stash them on more */ * stash them on more */
struct cons_space_object cell = pointer2cell( args ); struct cons_space_object cell = pointer2cell( args );
set_reg( result, i, cell.payload.cons.car ); set_reg( frame, frame->args, cell.payload.cons.car );
args = cell.payload.cons.cdr; args = cell.payload.cons.cdr;
} }
if (!exceptionp(result)) {
if ( consp( args ) ) { if ( consp( args ) ) {
result->more = args; frame->more = args;
inc_ref( args ); inc_ref( args );
} }
#ifdef DEBUG
dump_frame( stderr, result );
#endif
}
}
return result; return result;
} }
@ -160,11 +212,13 @@ void free_stack_frame( struct stack_frame *frame ) {
/** /**
* Dump a stackframe to this stream for debugging * Dump a stackframe to this stream for debugging
* @param output the stream * @param output the stream
* @param frame the frame * @param frame_pointer the pointer to the frame
*/ */
void dump_frame( FILE * output, struct stack_frame *frame ) { void dump_frame( FILE * output, struct cons_pointer frame_pointer ) {
fputws( L"Dumping stack frame\n", output ); struct stack_frame *frame = get_stack_frame(frame_pointer);
for ( int arg = 0; arg < args_in_frame; arg++ ) {
if (frame != NULL) {
for ( int arg = 0; arg < frame->args; arg++ ) {
struct cons_space_object cell = pointer2cell( frame->arg[arg] ); struct cons_space_object cell = pointer2cell( frame->arg[arg] );
fwprintf( output, L"Arg %d:\t%c%c%c%c\tcount: %10u\tvalue: ", arg, fwprintf( output, L"Arg %d:\t%c%c%c%c\tcount: %10u\tvalue: ", arg,
@ -179,7 +233,20 @@ void dump_frame( FILE * output, struct stack_frame *frame ) {
print( output, frame->more ); print( output, frame->more );
fputws( L"\n", output ); fputws( L"\n", output );
} }
}
void dump_stack_trace(FILE * output, struct cons_pointer pointer) {
if (exceptionp(pointer)) {
print( output, pointer2cell(pointer).payload.exception.message );
fwprintf( output, L"\n" );
dump_stack_trace(output, pointer2cell(pointer).payload.exception.frame);
} else {
while (vectorpointp(pointer) && stackframep(pointer_to_vso(pointer))) {
dump_frame( output, pointer);
pointer = get_stack_frame(pointer)->previous;
}
}
}
/** /**
* Fetch a pointer to the value of the local variable at this index. * Fetch a pointer to the value of the local variable at this index.

46
src/memory/stack.h
View file

@ -24,46 +24,40 @@
#ifndef __stack_h #ifndef __stack_h
#define __stack_h #define __stack_h
/**
* macros for the tag of a stack frame.
*/
#define STACKFRAMETAG "STAK"
#define STACKFRAMETV 1262572627
/**
* is this vector-space object a stack frame?
*/
#define stackframep(vso)(vso->header.tag.value == STACKFRAMETV)
/** /**
* set a register in a stack frame. Alwaye use this macro to do so, * set a register in a stack frame. Alwaye use this macro to do so,
• because that way we can be sure the inc_ref happens! • because that way we can be sure the inc_ref happens!
*/ */
#define set_reg(frame,register,value)frame->arg[register]=value; inc_ref(value) #define set_reg(frame,register,value)frame->arg[register]=value; inc_ref(value)
struct stack_frame * get_stack_frame(struct cons_pointer pointer);
/** struct cons_pointer make_empty_frame( struct cons_pointer previous );
* Make an empty stack frame, and return it.
* @param previous the current top-of-stack; struct cons_pointer make_stack_frame( struct cons_pointer previous,
* @param env the environment in which evaluation happens. struct cons_pointer args,
* @return the new frame.
*/
struct stack_frame *make_empty_frame( struct stack_frame *previous,
struct cons_pointer env ); struct cons_pointer env );
struct stack_frame *make_stack_frame( struct stack_frame *previous,
struct cons_pointer args,
struct cons_pointer env,
struct cons_pointer *exception );
void free_stack_frame( struct stack_frame *frame ); void free_stack_frame( struct stack_frame *frame );
/** void dump_frame( FILE * output, struct cons_pointer pointer );
* Dump a stackframe to this stream for debugging
* @param output the stream void dump_stack_trace(FILE * output, struct cons_pointer frame_pointer);
* @param frame the frame
*/
void dump_frame( FILE * output, struct stack_frame *frame );
struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int n ); struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int n );
/** struct cons_pointer make_special_frame( struct cons_pointer previous,
* A 'special' frame is exactly like a normal stack frame except that the
* arguments are unevaluated.
* @param previous the previous stack frame;
* @param args a list of the arguments to be stored in this stack frame;
* @param env the execution environment;
* @return a new special frame.
*/
struct stack_frame *make_special_frame( struct stack_frame *previous,
struct cons_pointer args, struct cons_pointer args,
struct cons_pointer env ); struct cons_pointer env );

26
src/memory/vectorspace.c
View file

@ -8,6 +8,7 @@
* Licensed under GPL version 2.0, or, at your option, any later version. * Licensed under GPL version 2.0, or, at your option, any later version.
*/ */
#include <math.h>
#include <stdint.h> #include <stdint.h>
#include <stdlib.h> #include <stdlib.h>
#include <string.h> #include <string.h>
@ -29,7 +30,7 @@
* NOTE that `tag` should be the vector-space tag of the particular type of * NOTE that `tag` should be the vector-space tag of the particular type of
* vector-space object, NOT `VECTORPOINTTAG`. * vector-space object, NOT `VECTORPOINTTAG`.
*/ */
struct cons_pointer make_vec_pointer( char *tag, uint64_t address ) { struct cons_pointer make_vec_pointer( char * tag, struct vector_space_object * address ) {
struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG ); struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG );
struct cons_space_object cell = pointer2cell( pointer ); struct cons_space_object cell = pointer2cell( pointer );
@ -44,26 +45,33 @@ struct cons_pointer make_vec_pointer( char *tag, uint64_t address ) {
* and return a `cons_pointer` which points to an object whigh points to it. * and return a `cons_pointer` which points to an object whigh points to it.
* NOTE that `tag` should be the vector-space tag of the particular type of * NOTE that `tag` should be the vector-space tag of the particular type of
* vector-space object, NOT `VECTORPOINTTAG`. * vector-space object, NOT `VECTORPOINTTAG`.
* Returns NIL if the vector could not be allocated due to memory exhaustion.
*/ */
struct cons_pointer make_vso( char *tag, int64_t payload_size ) { struct cons_pointer make_vso( char *tag, uint64_t payload_size ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
int64_t total_size = sizeof( struct vector_space_header ) + payload_size; int64_t total_size = sizeof( struct vector_space_header ) + payload_size;
struct vector_space_header *vso = malloc( total_size ); /* Pad size to 64 bit words. This is intended to promote access efficiancy
* on 64 bit machines but may just be voodoo coding */
uint64_t padded = ceil((total_size * 8.0) / 8.0);
struct vector_space_object *vso = malloc( padded );
if ( vso != NULL ) { if ( vso != NULL ) {
strncpy( &vso->tag.bytes[0], tag, TAGLENGTH ); strncpy( &vso->header.tag.bytes[0], tag, TAGLENGTH );
vso->vecp = make_vec_pointer( tag, ( uint64_t ) vso ); vso->header.vecp = make_vec_pointer( tag, vso );
vso->size = payload_size; vso->header.size = payload_size;
#ifdef DEBUG #ifdef DEBUG
fwprintf( stderr, fwprintf( stderr,
L"Allocated vector-space object of type %s, total size %ld, payload size %ld\n", L"Allocated vector-space object of type %4.4s, total size %ld, payload size %ld\n",
tag, total_size, payload_size ); tag, total_size, payload_size );
if (padded != total_size){
fwprintf(stderr, L"\t\tPadded from %d to %d\n",
total_size, padded);
}
#endif #endif
result = vso->vecp; result = vso->header.vecp;
} }
return result; return result;
} }

16
src/memory/vectorspace.h
View file

@ -34,20 +34,16 @@
#define NAMESPACETAG "NMSP" #define NAMESPACETAG "NMSP"
#define NAMESPACETV 0 #define NAMESPACETV 0
/*
* a stack frame.
*/
#define STACKFRAMETAG "STAK"
#define STACKFRAMETV
/* /*
* a vector of cons pointers. * a vector of cons pointers.
*/ */
#define VECTORTAG "VECT" #define VECTORTAG "VECT"
#define VECTORTV 0 #define VECTORTV 0
#define pointer_to_vso(pointer)(vectorpointp(pointer)? pointer2cell(pointer).payload.vectorp.address : 0) #define pointer_to_vso(pointer)((vectorpointp(pointer)? pointer2cell(pointer).payload.vectorp.address : NULL))
#define vso_get_vecp(vso)((vso->header.vecp))
struct cons_pointer make_vso( char *tag, int64_t payload_size ); struct cons_pointer make_vso( char *tag, uint64_t payload_size );
struct vector_space_header { struct vector_space_header {
union { union {
@ -62,8 +58,10 @@ struct vector_space_header {
struct cons_pointer vecp; /* back pointer to the vector pointer struct cons_pointer vecp; /* back pointer to the vector pointer
* which uniquely points to this vso */ * which uniquely points to this vso */
uint64_t size; /* the size of my payload, in bytes */ uint64_t size; /* the size of my payload, in bytes */
char mark; /* mark bit for marking/sweeping the };
* heap (not in this version) */
struct vector_space_object {
struct vector_space_header header;
char payload; /* we'll malloc `size` bytes for payload, char payload; /* we'll malloc `size` bytes for payload,
* `payload` is just the first of these. * `payload` is just the first of these.
* TODO: this is almost certainly not * TODO: this is almost certainly not

229
src/ops/lispops.c
View file

@ -80,6 +80,7 @@ struct cons_pointer c_cdr( struct cons_pointer arg ) {
* @return the result of evaluating the form. * @return the result of evaluating the form.
*/ */
struct cons_pointer eval_form( struct stack_frame *parent, struct cons_pointer eval_form( struct stack_frame *parent,
struct cons_pointer parent_pointer,
struct cons_pointer form, struct cons_pointer form,
struct cons_pointer env ) { struct cons_pointer env ) {
fputws( L"eval_form: ", stderr ); fputws( L"eval_form: ", stderr );
@ -87,15 +88,19 @@ struct cons_pointer eval_form( struct stack_frame *parent,
fputws( L"\n", stderr ); fputws( L"\n", stderr );
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct stack_frame *next = make_empty_frame( parent, env ); struct cons_pointer next_pointer = make_empty_frame( parent_pointer );
inc_ref( next_pointer);
struct stack_frame * next = get_stack_frame(next_pointer);
set_reg( next, 0, form ); set_reg( next, 0, form );
result = lisp_eval( next, env );
result = lisp_eval( next, next_pointer, 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. */
free_stack_frame( next ); dec_ref(next_pointer);
} }
return result; return result;
@ -106,12 +111,13 @@ struct cons_pointer eval_form( struct stack_frame *parent,
* and this `env`, and return a list of their values. If the arg passed as * and this `env`, and return a list of their values. If the arg passed as
* `list` is not in fact a list, return nil. * `list` is not in fact a list, return nil.
*/ */
struct cons_pointer eval_forms( struct stack_frame *frame, struct cons_pointer eval_forms( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer list, struct cons_pointer list,
struct cons_pointer env ) { struct cons_pointer env ) {
/* TODO: refactor. This runs up the C stack. */
return consp( list ) ? return consp( list ) ?
make_cons( eval_form( frame, c_car( list ), env ), make_cons( eval_form( frame, frame_pointer, c_car( list ), env ),
eval_forms( frame, c_cdr( list ), env ) ) : NIL; eval_forms( frame, frame_pointer, c_cdr( list ), env ) ) : NIL;
} }
/** /**
@ -120,7 +126,7 @@ struct cons_pointer eval_forms( struct stack_frame *frame,
* (oblist) * (oblist)
*/ */
struct cons_pointer struct cons_pointer
lisp_oblist( struct stack_frame *frame, struct cons_pointer env ) { lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) {
return oblist; return oblist;
} }
@ -153,7 +159,7 @@ struct cons_pointer compose_body( struct stack_frame *frame ) {
* @param env the environment in which it is to be intepreted. * @param env the environment in which it is to be intepreted.
*/ */
struct cons_pointer struct cons_pointer
lisp_lambda( struct stack_frame *frame, struct cons_pointer env ) { lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) {
return make_lambda( frame->arg[0], compose_body( frame ) ); return make_lambda( frame->arg[0], compose_body( frame ) );
} }
@ -164,7 +170,7 @@ lisp_lambda( struct stack_frame *frame, struct cons_pointer env ) {
* @param env the environment in which it is to be intepreted. * @param env the environment in which it is to be intepreted.
*/ */
struct cons_pointer struct cons_pointer
lisp_nlambda( struct stack_frame *frame, struct cons_pointer env ) { lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) {
return make_nlambda( frame->arg[0], compose_body( frame ) ); return make_nlambda( frame->arg[0], compose_body( frame ) );
} }
@ -182,7 +188,7 @@ void log_binding( struct cons_pointer name, struct cons_pointer val ) {
* Evaluate a lambda or nlambda expression. * Evaluate a lambda or nlambda expression.
*/ */
struct cons_pointer struct cons_pointer
eval_lambda( struct cons_space_object cell, struct stack_frame *frame, eval_lambda( struct cons_space_object cell, struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
fwprintf( stderr, L"eval_lambda called\n" ); fwprintf( stderr, L"eval_lambda called\n" );
@ -206,10 +212,11 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
} else if ( symbolp( names ) ) { } else if ( symbolp( names ) ) {
/* if `names` is a symbol, rather than a list of symbols, /* if `names` is a symbol, rather than a list of symbols,
* then bind a list of the values of args to that symbol. */ * 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 = frame->more;
for ( int i = args_in_frame - 1; i >= 0; i-- ) { for ( int i = args_in_frame - 1; i >= 0; i-- ) {
struct cons_pointer val = eval_form( frame, frame->arg[i], env ); struct cons_pointer val = eval_form( frame, frame_pointer, frame->arg[i], env );
if ( nilp( val ) && nilp( vals ) ) { /* nothing */ if ( nilp( val ) && nilp( vals ) ) { /* nothing */
} else { } else {
@ -223,8 +230,10 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
while ( !nilp( body ) ) { while ( !nilp( body ) ) {
struct cons_pointer sexpr = c_car( body ); struct cons_pointer sexpr = c_car( body );
body = c_cdr( body ); body = c_cdr( body );
#ifdef DEBUG
fputws( L"In lambda: ", stderr ); fputws( L"In lambda: ", stderr );
result = eval_form( frame, sexpr, new_env ); #endif
result = eval_form( frame, frame_pointer, sexpr, new_env );
} }
return result; return result;
@ -239,17 +248,23 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
* @return the result of evaluating the function with its arguments. * @return the result of evaluating the function with its arguments.
*/ */
struct cons_pointer struct cons_pointer
c_apply( struct stack_frame *frame, struct cons_pointer env ) { c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct stack_frame *fn_frame = make_empty_frame( frame, env );
/* construct a child frame and within it evaluate the first argument - the
* argument in the function position. */
struct cons_pointer fn_frame_pointer = make_empty_frame( frame_pointer );
inc_ref( fn_frame_pointer);
struct stack_frame *fn_frame = get_stack_frame(fn_frame_pointer);
set_reg( fn_frame, 0, c_car( frame->arg[0] ) ); set_reg( fn_frame, 0, c_car( frame->arg[0] ) );
struct cons_pointer fn_pointer = lisp_eval( fn_frame, env ); struct cons_pointer fn_pointer = lisp_eval( fn_frame, fn_frame_pointer, 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. */
free_stack_frame( fn_frame ); dec_ref(fn_frame_pointer);
} }
struct cons_space_object fn_cell = pointer2cell( fn_pointer ); struct cons_space_object fn_cell = pointer2cell( fn_pointer );
@ -263,66 +278,65 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
case FUNCTIONTV: case FUNCTIONTV:
{ {
struct cons_pointer exep = NIL; struct cons_pointer exep = NIL;
struct stack_frame *next = struct cons_pointer next_pointer =
make_stack_frame( frame, args, env, &exep ); make_stack_frame( frame_pointer, args, env );
result = ( *fn_cell.payload.special.executable ) ( next, env ); inc_ref(next_pointer);
if ( exceptionp( exep ) ) { if ( exceptionp( next_pointer ) ) {
/* if we're returning an exception, we should NOT free the result = next_pointer;
* stack frame. Corollary is, when we free an exception, we
* should free all the frames it's holding on to. */
result = exep;
} else { } else {
free_stack_frame( next ); struct stack_frame *next = get_stack_frame(next_pointer);
result = ( *fn_cell.payload.function.executable ) ( next, next_pointer, env );
dec_ref(next_pointer);
} }
} }
break; break;
case LAMBDATV: case LAMBDATV:
{ {
struct cons_pointer exep = NIL; struct cons_pointer exep = NIL;
struct stack_frame *next = struct cons_pointer next_pointer =
make_stack_frame( frame, args, env, &exep ); make_stack_frame( frame_pointer, args, env );
#ifdef DEBUG inc_ref(next_pointer);
fputws( L"Stack frame for lambda\n", stderr ); if ( exceptionp( next_pointer ) ) {
dump_frame( stderr, next ); result = next_pointer;
#endif
result = eval_lambda( fn_cell, next, env );
if ( exceptionp( result ) ) {
/* if we're returning an exception, we should NOT free the
* stack frame. Corollary is, when we free an exception, we
* should free all the frames it's holding on to. */
result = exep;
} else { } else {
free_stack_frame( next ); struct stack_frame *next = get_stack_frame(next_pointer);
result = eval_lambda( fn_cell, next, next_pointer, env );
if ( !exceptionp( result ) ) {
dec_ref(next_pointer);
}
} }
} }
break; break;
case NLAMBDATV: case NLAMBDATV:
{ {
struct stack_frame *next = struct cons_pointer next_pointer =
make_special_frame( frame, args, env ); make_special_frame( frame_pointer, args, env );
#ifdef DEBUG inc_ref(next_pointer);
fputws( L"Stack frame for nlambda\n", stderr ); if ( exceptionp( next_pointer ) ) {
dump_frame( stderr, next ); result = next_pointer;
#endif } else {
result = eval_lambda( fn_cell, next, env ); struct stack_frame *next = get_stack_frame(frame_pointer);
result = eval_lambda( fn_cell, next, next_pointer, env );
if ( !exceptionp( result ) ) { if ( !exceptionp( result ) ) {
/* if we're returning an exception, we should NOT free the dec_ref(next_pointer);
* stack frame. Corollary is, when we free an exception, we }
* should free all the frames it's holding on to. */
free_stack_frame( next );
} }
} }
break; break;
case SPECIALTV: case SPECIALTV:
{ {
struct stack_frame *next = struct cons_pointer next_pointer =
make_special_frame( frame, args, env ); make_special_frame( frame_pointer, args, env );
result = ( *fn_cell.payload.special.executable ) ( next, env ); inc_ref(next_pointer);
if ( exceptionp( next_pointer ) ) {
result = next_pointer;
} else {
struct stack_frame *next = get_stack_frame(frame_pointer);
result = ( *fn_cell.payload.special.executable ) ( next, next_pointer, env );
if ( !exceptionp( result ) ) { if ( !exceptionp( result ) ) {
/* if we're returning an exception, we should NOT free the dec_ref(next_pointer);
* stack frame. Corollary is, when we free an exception, we }
* should free all the frames it's holding on to. */
free_stack_frame( next );
} }
} }
break; break;
@ -338,9 +352,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer message = struct cons_pointer message =
c_string_to_lisp_string( buffer ); c_string_to_lisp_string( buffer );
free( buffer ); free( buffer );
result = lisp_throw( message, frame ); result = throw_exception( message, frame_pointer );
} }
} }
dec_ref(fn_frame_pointer);
return result; return result;
} }
@ -378,19 +393,19 @@ struct cons_pointer c_type( struct cons_pointer pointer ) {
* If a special form, passes the cdr of s_expr to the special form as argument. * If a special form, passes the cdr of s_expr to the special form as argument.
*/ */
struct cons_pointer struct cons_pointer
lisp_eval( struct stack_frame *frame, struct cons_pointer env ) { lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) {
struct cons_pointer result = frame->arg[0]; struct cons_pointer result = frame->arg[0];
struct cons_space_object cell = pointer2cell( frame->arg[0] ); struct cons_space_object cell = pointer2cell( frame->arg[0] );
#ifdef DEBUG #ifdef DEBUG
fputws( L"Eval: ", stderr ); fputws( L"Eval: ", stderr );
dump_frame( stderr, frame ); dump_frame( stderr, frame_pointer );
#endif #endif
switch ( cell.tag.value ) { switch ( cell.tag.value ) {
case CONSTV: case CONSTV:
{ {
result = c_apply( frame, env ); result = c_apply( frame, frame_pointer, env );
} }
break; break;
@ -403,7 +418,7 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
make_cons( c_string_to_lisp_string make_cons( c_string_to_lisp_string
( "Attempt to take value of unbound symbol." ), ( "Attempt to take value of unbound symbol." ),
frame->arg[0] ); frame->arg[0] );
result = lisp_throw( message, frame ); result = throw_exception( message, frame_pointer );
} else { } else {
result = c_assoc( canonical, env ); result = c_assoc( canonical, env );
inc_ref( result ); inc_ref( result );
@ -441,15 +456,15 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
* the second argument * the second argument
*/ */
struct cons_pointer struct cons_pointer
lisp_apply( struct stack_frame *frame, struct cons_pointer env ) { lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) {
#ifdef DEBUG #ifdef DEBUG
fputws( L"Apply: ", stderr ); fputws( L"Apply: ", stderr );
dump_frame( stderr, frame ); dump_frame( stderr, frame_pointer );
#endif #endif
set_reg( frame, 0, make_cons( frame->arg[0], frame->arg[1] ) ); set_reg( frame, 0, make_cons( frame->arg[0], frame->arg[1] ) );
set_reg( frame, 1, NIL ); set_reg( frame, 1, NIL );
struct cons_pointer result = c_apply( frame, env ); struct cons_pointer result = c_apply( frame, frame_pointer, env );
#ifdef DEBUG #ifdef DEBUG
fputws( L"Apply returning ", stderr ); fputws( L"Apply returning ", stderr );
@ -469,7 +484,7 @@ lisp_apply( struct stack_frame *frame, struct cons_pointer env ) {
* this isn't at this stage checked) unevaluated. * this isn't at this stage checked) unevaluated.
*/ */
struct cons_pointer struct cons_pointer
lisp_quote( struct stack_frame *frame, struct cons_pointer env ) { lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) {
return frame->arg[0]; return frame->arg[0];
} }
@ -484,7 +499,7 @@ lisp_quote( struct stack_frame *frame, struct cons_pointer env ) {
* the namespace in so doing. `namespace` defaults to the value of `oblist`. * the namespace in so doing. `namespace` defaults to the value of `oblist`.
*/ */
struct cons_pointer struct cons_pointer
lisp_set( struct stack_frame *frame, struct cons_pointer env ) { lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct cons_pointer namespace = struct cons_pointer namespace =
nilp( frame->arg[2] ) ? oblist : frame->arg[2]; nilp( frame->arg[2] ) ? oblist : frame->arg[2];
@ -497,7 +512,7 @@ lisp_set( struct stack_frame *frame, struct cons_pointer env ) {
make_exception( make_cons make_exception( make_cons
( c_string_to_lisp_string ( c_string_to_lisp_string
( "The first argument to `set!` is not a symbol: " ), ( "The first argument to `set!` is not a symbol: " ),
make_cons( frame->arg[0], NIL ) ), frame ); make_cons( frame->arg[0], NIL ) ), frame_pointer );
} }
return result; return result;
@ -514,13 +529,13 @@ lisp_set( struct stack_frame *frame, struct cons_pointer env ) {
* the namespace in so doing. `namespace` defaults to the value of `oblist`. * the namespace in so doing. `namespace` defaults to the value of `oblist`.
*/ */
struct cons_pointer struct cons_pointer
lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ) { lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct cons_pointer namespace = struct cons_pointer namespace =
nilp( frame->arg[2] ) ? oblist : frame->arg[2]; nilp( frame->arg[2] ) ? oblist : frame->arg[2];
if ( symbolp( frame->arg[0] ) ) { if ( symbolp( frame->arg[0] ) ) {
struct cons_pointer val = eval_form( frame, frame->arg[1], env ); struct cons_pointer val = eval_form( frame, frame_pointer, frame->arg[1], env );
deep_bind( frame->arg[0], val ); deep_bind( frame->arg[0], val );
result = val; result = val;
} else { } else {
@ -528,7 +543,7 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ) {
make_exception( make_cons make_exception( make_cons
( c_string_to_lisp_string ( c_string_to_lisp_string
( "The first argument to `set!` is not a symbol: " ), ( "The first argument to `set!` is not a symbol: " ),
make_cons( frame->arg[0], NIL ) ), frame ); make_cons( frame->arg[0], NIL ) ), frame_pointer );
} }
return result; return result;
@ -543,7 +558,7 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ) {
* otherwise returns a new cons cell. * otherwise returns a new cons cell.
*/ */
struct cons_pointer struct cons_pointer
lisp_cons( struct stack_frame *frame, struct cons_pointer env ) { lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) {
struct cons_pointer car = frame->arg[0]; struct cons_pointer car = frame->arg[0];
struct cons_pointer cdr = frame->arg[1]; struct cons_pointer cdr = frame->arg[1];
struct cons_pointer result; struct cons_pointer result;
@ -567,7 +582,7 @@ lisp_cons( struct stack_frame *frame, struct cons_pointer env ) {
* strings, and TODO read streams and other things which can be considered as sequences. * strings, and TODO read streams and other things which can be considered as sequences.
*/ */
struct cons_pointer struct cons_pointer
lisp_car( struct stack_frame *frame, struct cons_pointer env ) { lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
if ( consp( frame->arg[0] ) ) { if ( consp( frame->arg[0] ) ) {
@ -579,7 +594,7 @@ lisp_car( struct stack_frame *frame, struct cons_pointer env ) {
} else { } else {
struct cons_pointer message = struct cons_pointer message =
c_string_to_lisp_string( "Attempt to take CAR of non sequence" ); c_string_to_lisp_string( "Attempt to take CAR of non sequence" );
result = lisp_throw( message, frame ); result = throw_exception( message, frame_pointer );
} }
return result; return result;
@ -591,7 +606,7 @@ lisp_car( struct stack_frame *frame, struct cons_pointer env ) {
* strings, and TODO read streams and other things which can be considered as sequences. * strings, and TODO read streams and other things which can be considered as sequences.
*/ */
struct cons_pointer struct cons_pointer
lisp_cdr( struct stack_frame *frame, struct cons_pointer env ) { lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
if ( consp( frame->arg[0] ) ) { if ( consp( frame->arg[0] ) ) {
@ -603,7 +618,7 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer env ) {
} else { } else {
struct cons_pointer message = struct cons_pointer message =
c_string_to_lisp_string( "Attempt to take CDR of non sequence" ); c_string_to_lisp_string( "Attempt to take CDR of non sequence" );
result = lisp_throw( message, frame ); result = throw_exception( message, frame_pointer );
} }
return result; return result;
@ -614,7 +629,7 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer env ) {
* Returns the value associated with key in store, or NIL if not found. * Returns the value associated with key in store, or NIL if not found.
*/ */
struct cons_pointer struct cons_pointer
lisp_assoc( struct stack_frame *frame, struct cons_pointer env ) { lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) {
return c_assoc( frame->arg[0], frame->arg[1] ); return c_assoc( frame->arg[0], frame->arg[1] );
} }
@ -622,7 +637,7 @@ lisp_assoc( struct stack_frame *frame, struct cons_pointer env ) {
* (eq a b) * (eq a b)
* Returns T if a and b are pointers to the same object, else NIL * Returns T if a and b are pointers to the same object, else NIL
*/ */
struct cons_pointer lisp_eq( struct stack_frame *frame, struct cons_pointer lisp_eq( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
return eq( frame->arg[0], frame->arg[1] ) ? TRUE : NIL; return eq( frame->arg[0], frame->arg[1] ) ? TRUE : NIL;
} }
@ -632,7 +647,7 @@ struct cons_pointer lisp_eq( struct stack_frame *frame,
* Returns T if a and b are pointers to structurally identical objects, else NIL * Returns T if a and b are pointers to structurally identical objects, else NIL
*/ */
struct cons_pointer struct cons_pointer
lisp_equal( struct stack_frame *frame, struct cons_pointer env ) { lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) {
return equal( frame->arg[0], frame->arg[1] ) ? TRUE : NIL; return equal( frame->arg[0], frame->arg[1] ) ? TRUE : NIL;
} }
@ -643,14 +658,14 @@ lisp_equal( struct stack_frame *frame, struct cons_pointer env ) {
* is a read stream, then read from that stream, else stdin. * is a read stream, then read from that stream, else stdin.
*/ */
struct cons_pointer struct cons_pointer
lisp_read( struct stack_frame *frame, struct cons_pointer env ) { lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) {
FILE *input = stdin; FILE *input = stdin;
if ( readp( frame->arg[0] ) ) { if ( readp( frame->arg[0] ) ) {
input = pointer2cell( frame->arg[0] ).payload.stream.stream; input = pointer2cell( frame->arg[0] ).payload.stream.stream;
} }
return read( frame, input ); return read( frame, frame_pointer, input );
} }
@ -683,7 +698,7 @@ struct cons_pointer c_reverse( struct cons_pointer arg ) {
* (reverse sequence) * (reverse sequence)
* Return a sequence like this sequence but with the members in the reverse order. * Return a sequence like this sequence but with the members in the reverse order.
*/ */
struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
return c_reverse( frame->arg[0] ); return c_reverse( frame->arg[0] );
} }
@ -696,7 +711,10 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame,
* is a write stream, then print to that stream, else stdout. * is a write stream, then print to that stream, else stdout.
*/ */
struct cons_pointer struct cons_pointer
lisp_print( struct stack_frame *frame, struct cons_pointer env ) { lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) {
#ifdef DEBUG
fputws(L"Entering print\n", stderr);
#endif
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
FILE *output = stdout; FILE *output = stdout;
@ -706,9 +724,11 @@ lisp_print( struct stack_frame *frame, struct cons_pointer env ) {
result = print( output, frame->arg[0] ); result = print( output, frame->arg[0] );
#ifdef DEBUG
fputws( L"Print returning ", stderr ); fputws( L"Print returning ", stderr );
print( stderr, result ); // print( stderr, result );
fputws( L"\n", stderr ); fputws( L"\n", stderr );
#endif
return result; return result;
} }
@ -721,7 +741,7 @@ lisp_print( struct stack_frame *frame, struct cons_pointer env ) {
* @return As a Lisp string, the tag of the object which is the argument. * @return As a Lisp string, the tag of the object which is the argument.
*/ */
struct cons_pointer struct cons_pointer
lisp_type( struct stack_frame *frame, struct cons_pointer env ) { lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) {
return c_type( frame->arg[0] ); return c_type( frame->arg[0] );
} }
@ -739,16 +759,16 @@ lisp_type( struct stack_frame *frame, struct cons_pointer env ) {
* argument. * argument.
*/ */
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 frame_pointer, struct cons_pointer env ) {
struct cons_pointer remaining = frame->more; struct cons_pointer remaining = frame->more;
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
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++ ) {
result = eval_form( frame, frame->arg[i], env ); result = eval_form( frame, frame_pointer, frame->arg[i], env );
} }
while ( consp( remaining ) ) { while ( consp( remaining ) ) {
result = eval_form( frame, c_car( remaining ), env ); result = eval_form( frame, frame_pointer, c_car( remaining ), env );
remaining = c_cdr( remaining ); remaining = c_cdr( remaining );
} }
@ -766,7 +786,7 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer env ) {
* @return the value of the last form of the first successful clause. * @return the value of the last form of the first successful clause.
*/ */
struct cons_pointer struct cons_pointer
lisp_cond( struct stack_frame *frame, struct cons_pointer env ) { lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
bool done = false; bool done = false;
@ -777,11 +797,11 @@ 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 ); result = eval_form( frame, frame_pointer, c_car( clause_pointer ), env );
if ( !nilp( result ) ) { if ( !nilp( result ) ) {
struct cons_pointer vals = struct cons_pointer vals =
eval_forms( frame, c_cdr( clause_pointer ), env ); eval_forms( frame, frame_pointer,c_cdr( clause_pointer ), env );
while ( consp( vals ) ) { while ( consp( vals ) ) {
result = c_car( vals ); result = c_car( vals );
@ -793,9 +813,9 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) {
} else if ( nilp( clause_pointer ) ) { } else if ( nilp( clause_pointer ) ) {
done = true; done = true;
} else { } else {
result = lisp_throw( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Arguments to `cond` must be lists" ), ( "Arguments to `cond` must be lists" ),
frame ); frame_pointer);
} }
} }
/* TODO: if there are more than 8 clauses we need to continue into the /* TODO: if there are more than 8 clauses we need to continue into the
@ -805,15 +825,17 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) {
} }
/** /**
* TODO: make this do something sensible somehow. * Throw an exception.
* This requires that a frame be a heap-space object with a cons-space * `throw_exception` is a misnomer, because it doesn't obey the calling signature of a
* lisp function; but it is nevertheless to be preferred to make_exception. A
* real `throw_exception`, which does, will be needed.
* object pointing to it. Then this should become a normal lisp function * object pointing to it. Then this should become a normal lisp function
* which expects a normally bound frame and environment, such that * which expects a normally bound frame and environment, such that
* frame->arg[0] is the message, and frame->arg[1] is the cons-space * frame->arg[0] is the message, and frame->arg[1] is the cons-space
* pointer to the frame in which the exception occurred. * pointer to the frame in which the exception occurred.
*/ */
struct cons_pointer struct cons_pointer
lisp_throw( struct cons_pointer message, struct stack_frame *frame ) { throw_exception( struct cons_pointer message, struct cons_pointer frame_pointer ) {
fwprintf( stderr, L"\nERROR: " ); fwprintf( stderr, L"\nERROR: " );
print( stderr, message ); print( stderr, message );
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
@ -823,8 +845,23 @@ lisp_throw( struct cons_pointer message, struct stack_frame *frame ) {
if ( cell.tag.value == EXCEPTIONTV ) { if ( cell.tag.value == EXCEPTIONTV ) {
result = message; result = message;
} else { } else {
result = make_exception( message, frame ); result = make_exception( message, frame_pointer );
} }
return result; return result;
} }
/**
* (exception <message>)
*
* Function. Returns an exception whose message is this `message`, and whose
* stack frame is the parent stack frame when the function is invoked.
* `message` does not have to be a string but should be something intelligible
* which can be read.
* If `message` is itself an exception, returns that instead.
*/
struct cons_pointer
lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) {
struct cons_pointer message = frame->arg[0];
return exceptionp(message) ? message : make_exception(message, frame->previous);
}

57
src/ops/lispops.h
View file

@ -51,6 +51,7 @@ struct cons_pointer c_reverse( struct cons_pointer arg );
* @return the result of evaluating the form. * @return the result of evaluating the form.
*/ */
struct cons_pointer eval_form( struct stack_frame *parent, struct cons_pointer eval_form( struct stack_frame *parent,
struct cons_pointer parent_pointer,
struct cons_pointer form, struct cons_pointer form,
struct cons_pointer env ); struct cons_pointer env );
@ -59,7 +60,7 @@ struct cons_pointer eval_form( struct stack_frame *parent,
* and this `env`, and return a list of their values. If the arg passed as * and this `env`, and return a list of their values. If the arg passed as
* `list` is not in fact a list, return nil. * `list` is not in fact a list, return nil.
*/ */
struct cons_pointer eval_forms( struct stack_frame *frame, struct cons_pointer eval_forms( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer list, struct cons_pointer list,
struct cons_pointer env ); struct cons_pointer env );
@ -67,19 +68,19 @@ struct cons_pointer eval_forms( struct stack_frame *frame,
/* /*
* special forms * special forms
*/ */
struct cons_pointer lisp_eval( struct stack_frame *frame, struct cons_pointer lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_apply( struct stack_frame *frame, struct cons_pointer lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer struct cons_pointer
lisp_oblist( struct stack_frame *frame, struct cons_pointer env ); lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env );
struct cons_pointer struct cons_pointer
lisp_set( struct stack_frame *frame, struct cons_pointer env ); lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env );
struct cons_pointer struct cons_pointer
lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ); lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env );
/** /**
* Construct an interpretable function. * Construct an interpretable function.
@ -88,7 +89,7 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env );
* @param lexpr the lambda expression to be interpreted; * @param lexpr the lambda expression to be interpreted;
* @param env the environment in which it is to be intepreted. * @param env the environment in which it is to be intepreted.
*/ */
struct cons_pointer lisp_lambda( struct stack_frame *frame, struct cons_pointer lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
/** /**
@ -98,31 +99,31 @@ struct cons_pointer lisp_lambda( struct stack_frame *frame,
* @param env the environment in which it is to be intepreted. * @param env the environment in which it is to be intepreted.
*/ */
struct cons_pointer struct cons_pointer
lisp_nlambda( struct stack_frame *frame, struct cons_pointer env ); lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env );
struct cons_pointer lisp_quote( struct stack_frame *frame, struct cons_pointer lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
/* /*
* functions * functions
*/ */
struct cons_pointer lisp_cons( struct stack_frame *frame, struct cons_pointer lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_car( struct stack_frame *frame, struct cons_pointer lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_cdr( struct stack_frame *frame, struct cons_pointer lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_assoc( struct stack_frame *frame, struct cons_pointer lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_eq( struct stack_frame *frame, struct cons_pointer lisp_eq( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_equal( struct stack_frame *frame, struct cons_pointer lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_print( struct stack_frame *frame, struct cons_pointer lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_read( 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 env );
struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
/** /**
* Function: Get the Lisp type of the single argument. * Function: Get the Lisp type of the single argument.
@ -131,7 +132,7 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame,
* @return As a Lisp string, the tag of the object which is the argument. * @return As a Lisp string, the tag of the object which is the argument.
*/ */
struct cons_pointer struct cons_pointer
lisp_type( struct stack_frame *frame, struct cons_pointer env ); lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env );
/** /**
@ -145,7 +146,7 @@ lisp_type( struct stack_frame *frame, struct cons_pointer env );
* argument. * argument.
*/ */
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 frame_pointer, struct cons_pointer env );
/** /**
* Special form: conditional. Each arg is expected to be a list; if the first * Special form: conditional. Each arg is expected to be a list; if the first
@ -157,10 +158,16 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer env );
* @return the value of the last form of the first successful clause. * @return the value of the last form of the first successful clause.
*/ */
struct cons_pointer struct cons_pointer
lisp_cond( struct stack_frame *frame, struct cons_pointer env ); lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env );
/* /**
* neither, at this stage, really * Throw an exception.
* `throw_exception` is a misnomer, because it doesn't obey the calling signature of a
* lisp function; but it is nevertheless to be preferred to make_exception. A
* real `throw_exception`, which does, will be needed.
*/ */
struct cons_pointer lisp_throw( struct cons_pointer message, struct cons_pointer throw_exception( struct cons_pointer message,
struct stack_frame *frame ); struct cons_pointer frame_pointer );
struct cons_pointer
lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env );

8
src/ops/print.c
View file

@ -20,6 +20,7 @@
#include "conspage.h" #include "conspage.h"
#include "consspaceobject.h" #include "consspaceobject.h"
#include "integer.h" #include "integer.h"
#include "stack.h"
#include "print.h" #include "print.h"
/** /**
@ -118,12 +119,7 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
case EXCEPTIONTV: case EXCEPTIONTV:
fwprintf( output, L"\n%sException: ", fwprintf( output, L"\n%sException: ",
print_use_colours ? "\x1B[31m" : "" ); print_use_colours ? "\x1B[31m" : "" );
if ( stringp( cell.payload.exception.message ) ) { dump_stack_trace(output, pointer);
print_string_contents( output,
cell.payload.exception.message );
} else {
print( output, cell.payload.exception.message );
}
break; break;
case FUNCTIONTV: case FUNCTIONTV:
fwprintf( output, L"(Function)" ); fwprintf( output, L"(Function)" );

53
src/ops/read.c
View file

@ -25,6 +25,7 @@
#include "ratio.h" #include "ratio.h"
#include "read.h" #include "read.h"
#include "real.h" #include "real.h"
#include "vectorspace.h"
/* /*
* for the time being things which may be read are: strings numbers - either * for the time being things which may be read are: strings numbers - either
@ -32,9 +33,11 @@
* atoms because I don't yet know what an atom is or how it's stored. * atoms because I don't yet know what an atom is or how it's stored.
*/ */
struct cons_pointer read_number( struct stack_frame *frame, FILE * input, struct cons_pointer read_number( struct stack_frame *frame,
struct cons_pointer frame_pointer, FILE * input,
wint_t initial, bool seen_period ); wint_t initial, bool seen_period );
struct cons_pointer read_list( struct stack_frame *frame, FILE * input, struct cons_pointer read_list( struct stack_frame *frame,
struct cons_pointer frame_pointer, FILE * input,
wint_t initial ); wint_t initial );
struct cons_pointer read_string( FILE * input, wint_t initial ); 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 );
@ -52,7 +55,7 @@ struct cons_pointer c_quote( struct cons_pointer arg ) {
* treating this initial character as the first character of the object * treating this initial character as the first character of the object
* representation. * representation.
*/ */
struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input, struct cons_pointer read_continuation( struct stack_frame *frame, struct cons_pointer frame_pointer, FILE * input,
wint_t initial ) { wint_t initial ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
@ -64,7 +67,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
if ( feof( input ) ) { if ( feof( input ) ) {
result = result =
make_exception( c_string_to_lisp_string make_exception( c_string_to_lisp_string
( "End of file while reading" ), frame ); ( "End of file while reading" ), frame_pointer );
} else { } else {
switch ( c ) { switch ( c ) {
case ';': case ';':
@ -72,16 +75,16 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
/* skip all characters from semi-colon to the end of the line */ /* skip all characters from semi-colon to the end of the line */
break; break;
case EOF: case EOF:
result = lisp_throw( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "End of input while reading" ), frame ); ( "End of input while reading" ), frame_pointer );
break; break;
case '\'': case '\'':
result = result =
c_quote( read_continuation c_quote( read_continuation
( frame, input, fgetwc( input ) ) ); ( frame, frame_pointer, input, fgetwc( input ) ) );
break; break;
case '(': case '(':
result = read_list( frame, input, fgetwc( input ) ); result = read_list( frame, frame_pointer, input, fgetwc( input ) );
break; break;
case '"': case '"':
result = read_string( input, fgetwc( input ) ); result = read_string( input, fgetwc( input ) );
@ -90,7 +93,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
wint_t next = fgetwc( input ); wint_t next = fgetwc( input );
ungetwc( next, input ); ungetwc( next, input );
if ( iswdigit( next ) ) { if ( iswdigit( next ) ) {
result = read_number( frame, input, c, false ); result = read_number( frame, frame_pointer, input, c, false );
} else { } else {
result = read_symbol( input, c ); result = read_symbol( input, c );
} }
@ -101,12 +104,12 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
wint_t next = fgetwc( input ); wint_t next = fgetwc( input );
if ( iswdigit( next ) ) { if ( iswdigit( next ) ) {
ungetwc( next, input ); ungetwc( next, input );
result = read_number( frame, input, c, true ); result = read_number( frame, frame_pointer, input, c, true );
} else if ( iswblank( next ) ) { } else if ( iswblank( next ) ) {
/* dotted pair. TODO: this isn't right, we /* dotted pair. TODO: this isn't right, we
* really need to backtrack up a level. */ * really need to backtrack up a level. */
result = result =
read_continuation( frame, input, fgetwc( input ) ); read_continuation( frame, frame_pointer, input, fgetwc( input ) );
} else { } else {
read_symbol( input, c ); read_symbol( input, c );
} }
@ -114,7 +117,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
break; break;
default: default:
if ( iswdigit( c ) ) { if ( iswdigit( c ) ) {
result = read_number( frame, input, c, false ); result = read_number( frame, frame_pointer, input, c, false );
} else if ( iswprint( c ) ) { } else if ( iswprint( c ) ) {
result = read_symbol( input, c ); result = read_symbol( input, c );
} else { } else {
@ -122,7 +125,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
make_exception( make_cons( c_string_to_lisp_string make_exception( make_cons( c_string_to_lisp_string
( "Unrecognised start of input character" ), ( "Unrecognised start of input character" ),
make_string( c, NIL ) ), make_string( c, NIL ) ),
frame ); frame_pointer );
} }
break; break;
} }
@ -136,7 +139,9 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
* TODO: to be able to read bignums, we need to read the number from the * TODO: to be able to read bignums, we need to read the number from the
* input stream into a Lisp string, and then convert it to a number. * input stream into a Lisp string, and then convert it to a number.
*/ */
struct cons_pointer read_number( struct stack_frame *frame, FILE * input, struct cons_pointer read_number( struct stack_frame *frame,
struct cons_pointer frame_pointer,
FILE * input,
wint_t initial, bool seen_period ) { wint_t initial, bool seen_period ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
int64_t accumulator = 0; int64_t accumulator = 0;
@ -157,7 +162,7 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input,
if ( seen_period || dividend != 0 ) { if ( seen_period || dividend != 0 ) {
return make_exception( c_string_to_lisp_string return make_exception( c_string_to_lisp_string
( "Malformed number: too many periods" ), ( "Malformed number: too many periods" ),
frame ); frame_pointer );
} else { } else {
seen_period = true; seen_period = true;
} }
@ -165,7 +170,7 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input,
if ( seen_period || dividend > 0 ) { if ( seen_period || dividend > 0 ) {
return make_exception( c_string_to_lisp_string return make_exception( c_string_to_lisp_string
( "Malformed number: dividend of rational must be integer" ), ( "Malformed number: dividend of rational must be integer" ),
frame ); frame_pointer );
} else { } else {
dividend = negative ? 0 - accumulator : accumulator; dividend = negative ? 0 - accumulator : accumulator;
@ -200,7 +205,7 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input,
result = make_real( rv ); result = make_real( rv );
} else if ( dividend != 0 ) { } else if ( dividend != 0 ) {
result = result =
make_ratio( frame, make_integer( dividend ), make_ratio( frame_pointer, make_integer( dividend ),
make_integer( accumulator ) ); make_integer( accumulator ) );
} else { } else {
if ( negative ) { if ( negative ) {
@ -216,18 +221,18 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input,
* 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 struct cons_pointer read_list( struct stack_frame *frame,
stack_frame struct cons_pointer frame_pointer,
*frame, FILE * input, wint_t initial ) { FILE * input, wint_t initial ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
if ( initial != ')' ) { if ( initial != ')' ) {
#ifdef DEBUG #ifdef DEBUG
fwprintf( stderr, fwprintf( stderr,
L"read_list starting '%C' (%d)\n", initial, initial ); L"read_list starting '%C' (%d)\n", initial, initial );
#endif #endif
struct cons_pointer car = read_continuation( frame, input, struct cons_pointer car = read_continuation( frame, frame_pointer, input,
initial ); initial );
result = make_cons( car, read_list( frame, input, fgetwc( input ) ) ); result = make_cons( car, read_list( frame, frame_pointer, input, fgetwc( input ) ) );
} }
#ifdef DEBUG #ifdef DEBUG
else { else {
@ -318,6 +323,6 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
*/ */
struct cons_pointer read( struct struct cons_pointer read( struct
stack_frame stack_frame
*frame, FILE * input ) { *frame, struct cons_pointer frame_pointer, FILE * input ) {
return read_continuation( frame, input, fgetwc( input ) ); return read_continuation( frame, frame_pointer, input, fgetwc( input ) );
} }

4
src/ops/read.h
View file

@ -14,6 +14,8 @@
/** /**
* 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,
struct cons_pointer frame_pointer,
FILE * input );
#endif #endif

38
src/repl.c
View file

@ -31,11 +31,19 @@
* Dummy up a Lisp read call with its own stack frame. * Dummy up a Lisp read call with its own stack frame.
*/ */
struct cons_pointer repl_read( struct cons_pointer stream_pointer ) { struct cons_pointer repl_read( struct cons_pointer stream_pointer ) {
struct stack_frame *frame = make_empty_frame( NULL, oblist ); struct cons_pointer result = NIL;
struct cons_pointer frame_pointer = make_empty_frame( NIL );
if (!nilp(frame_pointer)) {
inc_ref(frame_pointer);
struct stack_frame *frame = get_stack_frame(frame_pointer);
if (frame != NULL){
set_reg( frame, 0, stream_pointer ); set_reg( frame, 0, stream_pointer );
struct cons_pointer result = lisp_read( frame, oblist ); struct cons_pointer result = lisp_read( frame, frame_pointer, oblist );
free_stack_frame( frame ); }
dec_ref(frame_pointer);
}
return result; return result;
} }
@ -44,13 +52,18 @@ struct cons_pointer repl_read( struct cons_pointer stream_pointer ) {
* Dummy up a Lisp eval call with its own stack frame. * Dummy up a Lisp eval call with its own stack frame.
*/ */
struct cons_pointer repl_eval( struct cons_pointer input ) { struct cons_pointer repl_eval( struct cons_pointer input ) {
struct stack_frame *frame = make_empty_frame( NULL, oblist ); struct cons_pointer result = NIL;
struct cons_pointer frame_pointer = make_empty_frame( NIL );
if (!nilp(frame_pointer)) {
inc_ref(frame_pointer);
struct stack_frame *frame = get_stack_frame(frame_pointer);
if (frame != NULL){
set_reg( frame, 0, input ); set_reg( frame, 0, input );
struct cons_pointer result = lisp_eval( frame, oblist ); result = lisp_eval( frame, frame_pointer, oblist );
}
if ( !exceptionp( result ) ) { dec_ref(frame_pointer);
free_stack_frame( frame );
} }
return result; return result;
@ -61,12 +74,19 @@ struct cons_pointer repl_eval( struct cons_pointer input ) {
*/ */
struct cons_pointer repl_print( struct cons_pointer stream_pointer, struct cons_pointer repl_print( struct cons_pointer stream_pointer,
struct cons_pointer value ) { struct cons_pointer value ) {
struct stack_frame *frame = make_empty_frame( NULL, oblist ); struct cons_pointer result = NIL;
struct cons_pointer frame_pointer = make_empty_frame( NIL );
if (!nilp(frame_pointer)) {
struct stack_frame *frame = get_stack_frame(frame_pointer);
if (frame != NULL){
set_reg( frame, 0, value ); set_reg( frame, 0, value );
set_reg( frame, 1, stream_pointer ); set_reg( frame, 1, stream_pointer );
struct cons_pointer result = lisp_print( frame, oblist ); result = lisp_print( frame, frame_pointer, oblist );
free_stack_frame( frame ); free_stack_frame( frame );
}
dec_ref(frame_pointer);
}
return result; return result;
} }