From 9937f344dcdf3df5cebc1ae339930ba1f712e449 Mon Sep 17 00:00:00 2001
From: Simon Brooke <simon@journeyman.cc>
Date: Wed, 26 Dec 2018 20:30:14 +0000
Subject: [PATCH 1/6] Major refactoring. Major problems!
On the right path but it doesn't work yet.
---
Makefile | 2 +-
src/arith/peano.c | 121 +++++++++---------
src/arith/peano.h | 8 +-
src/arith/ratio.c | 77 ++++++------
src/arith/ratio.h | 18 ++-
src/init.c | 2 +
src/memory/consspaceobject.c | 120 +++---------------
src/memory/consspaceobject.h | 36 ++----
src/memory/dump.c | 120 ++++++++++++++++++
src/memory/dump.h | 29 +++++
src/memory/stack.c | 169 ++++++++++++++++++--------
src/memory/stack.h | 48 ++++----
src/memory/vectorspace.c | 26 ++--
src/memory/vectorspace.h | 16 ++-
src/ops/lispops.c | 229 ++++++++++++++++++++---------------
src/ops/lispops.h | 57 +++++----
src/ops/print.c | 8 +-
src/ops/read.c | 53 ++++----
src/ops/read.h | 4 +-
src/repl.c | 58 ++++++---
20 files changed, 695 insertions(+), 506 deletions(-)
create mode 100644 src/memory/dump.c
create mode 100644 src/memory/dump.h
diff --git a/Makefile b/Makefile
index 98a6bd3..3fc8148 100644
--- a/Makefile
+++ b/Makefile
@@ -38,7 +38,7 @@ test: $(OBJS) $(TESTS) Makefile
.PHONY: clean
clean:
- $(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ *~
+ $(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ $(SRC_DIRS)/*/*~ *~
repl:
$(TARGET) -p 2> psse.log
diff --git a/src/arith/peano.c b/src/arith/peano.c
index 423bd51..63783f5 100644
--- a/src/arith/peano.c
+++ b/src/arith/peano.c
@@ -8,11 +8,11 @@
*/
#include <ctype.h>
+#include <math.h>
#include <stdbool.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
-#include <math.h>
#include "consspaceobject.h"
#include "conspage.h"
@@ -28,7 +28,7 @@
long double to_long_double( 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 );
@@ -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
* 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 result;
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 );
break;
case RATIOTV:
- result = add_integer_ratio( frame, arg1, arg2 );
+ result = add_integer_ratio( frame_pointer, arg1, arg2 );
break;
case REALTV:
result =
@@ -161,9 +161,9 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1,
to_long_double( arg2 ) );
break;
default:
- result = lisp_throw( c_string_to_lisp_string
+ result = throw_exception( c_string_to_lisp_string
( "Cannot add: not a number" ),
- frame );
+ frame_pointer );
break;
}
break;
@@ -173,10 +173,10 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1,
result = arg2;
break;
case INTEGERTV:
- result = add_integer_ratio( frame, arg2, arg1 );
+ result = add_integer_ratio( frame_pointer, arg2, arg1 );
break;
case RATIOTV:
- result = add_ratio_ratio( frame, arg1, arg2 );
+ result = add_ratio_ratio( frame_pointer, arg1, arg2 );
break;
case REALTV:
result =
@@ -184,9 +184,9 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1,
to_long_double( arg2 ) );
break;
default:
- result = lisp_throw( c_string_to_lisp_string
+ result = throw_exception( c_string_to_lisp_string
( "Cannot add: not a number" ),
- frame );
+ frame_pointer );
break;
}
break;
@@ -197,8 +197,8 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1,
break;
default:
result = exceptionp( arg2 ) ? arg2 :
- lisp_throw( c_string_to_lisp_string
- ( "Cannot add: not a number" ), frame );
+ throw_exception( c_string_to_lisp_string
+ ( "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.
*/
struct cons_pointer lisp_add( struct stack_frame
- *frame, struct
+ *frame, struct cons_pointer frame_pointer, struct
cons_pointer env ) {
struct cons_pointer result = make_integer( 0 );
struct cons_pointer tmp;
@@ -227,7 +227,7 @@ struct cons_pointer lisp_add( struct stack_frame
i < args_in_frame &&
!nilp( frame->arg[i] ) && !exceptionp( result ); i++ ) {
tmp = result;
- result = add_2( frame, result, frame->arg[i] );
+ result = add_2( frame, frame_pointer, result, frame->arg[i] );
if ( !eq( tmp, result ) ) {
dec_ref( tmp );
}
@@ -236,7 +236,7 @@ struct cons_pointer lisp_add( struct stack_frame
struct cons_pointer more = frame->more;
while ( consp( more ) && !exceptionp( 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 ) ) {
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
* 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 arg2 ) {
struct cons_pointer result;
@@ -286,7 +286,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
cell2.payload.integer.value );
break;
case RATIOTV:
- result = multiply_integer_ratio( frame, arg1, arg2 );
+ result = multiply_integer_ratio( frame_pointer, arg1, arg2 );
break;
case REALTV:
result =
@@ -294,9 +294,9 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
to_long_double( arg2 ) );
break;
default:
- result = lisp_throw( c_string_to_lisp_string
+ result = throw_exception( c_string_to_lisp_string
( "Cannot multiply: not a number" ),
- frame );
+ frame_pointer );
break;
}
break;
@@ -306,10 +306,10 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
result = arg2;
break;
case INTEGERTV:
- result = multiply_integer_ratio( frame, arg2, arg1 );
+ result = multiply_integer_ratio( frame_pointer, arg2, arg1 );
break;
case RATIOTV:
- result = multiply_ratio_ratio( frame, arg1, arg2 );
+ result = multiply_ratio_ratio( frame_pointer, arg1, arg2 );
break;
case REALTV:
result =
@@ -317,9 +317,9 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
to_long_double( arg2 ) );
break;
default:
- result = lisp_throw( c_string_to_lisp_string
+ result = throw_exception( c_string_to_lisp_string
( "Cannot multiply: not a number" ),
- frame );
+ frame_pointer );
}
break;
case REALTV:
@@ -328,9 +328,9 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
to_long_double( arg2 ) );
break;
default:
- result = lisp_throw( c_string_to_lisp_string
+ result = throw_exception( c_string_to_lisp_string
( "Cannot multiply: not a number" ),
- frame );
+ frame_pointer );
break;
}
}
@@ -353,7 +353,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
*/
struct cons_pointer lisp_multiply( struct
stack_frame
- *frame, struct
+ *frame, struct cons_pointer frame_pointer, struct
cons_pointer env ) {
struct cons_pointer result = make_integer( 1 );
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] )
&& !exceptionp( result ); i++ ) {
tmp = result;
- result = multiply_2( frame, result, frame->arg[i] );
+ result = multiply_2( frame, frame_pointer, result, frame->arg[i] );
if ( !eq( tmp, result ) ) {
dec_ref( tmp );
@@ -372,7 +372,7 @@ struct cons_pointer lisp_multiply( struct
while ( consp( more )
&& !exceptionp( 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 ) ) {
dec_ref( tmp );
@@ -388,7 +388,7 @@ struct cons_pointer lisp_multiply( struct
* return a cons_pointer indicating a number which is the
* 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 result = NIL;
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
stack_frame
- *frame, struct
+ *frame, struct cons_pointer frame_pointer, struct
cons_pointer env ) {
struct cons_pointer result = NIL;
struct cons_space_object cell0 = pointer2cell( frame->arg[0] );
@@ -451,10 +451,11 @@ struct cons_pointer lisp_subtract( struct
break;
case RATIOTV:{
struct cons_pointer tmp =
- make_ratio( frame, frame->arg[0],
+ make_ratio( frame_pointer, frame->arg[0],
make_integer( 1 ) );
+ inc_ref(tmp);
result =
- subtract_ratio_ratio( frame, tmp, frame->arg[1] );
+ subtract_ratio_ratio( frame_pointer, tmp, frame->arg[1] );
dec_ref( tmp );
}
break;
@@ -464,9 +465,9 @@ struct cons_pointer lisp_subtract( struct
to_long_double( frame->arg[1] ) );
break;
default:
- result = lisp_throw( c_string_to_lisp_string
- ( "Cannot multiply: not a number" ),
- frame );
+ result = throw_exception( c_string_to_lisp_string
+ ( "Cannot subtract: not a number" ),
+ frame_pointer );
break;
}
break;
@@ -477,16 +478,17 @@ struct cons_pointer lisp_subtract( struct
break;
case INTEGERTV:{
struct cons_pointer tmp =
- make_ratio( frame, frame->arg[1],
+ make_ratio( frame_pointer, frame->arg[1],
make_integer( 1 ) );
+ inc_ref(tmp);
result =
- subtract_ratio_ratio( frame, frame->arg[0], tmp );
+ subtract_ratio_ratio( frame_pointer, frame->arg[0], tmp );
dec_ref( tmp );
}
break;
case RATIOTV:
result =
- subtract_ratio_ratio( frame, frame->arg[0],
+ subtract_ratio_ratio( frame_pointer, frame->arg[0],
frame->arg[1] );
break;
case REALTV:
@@ -495,9 +497,9 @@ struct cons_pointer lisp_subtract( struct
to_long_double( frame->arg[1] ) );
break;
default:
- result = lisp_throw( c_string_to_lisp_string
- ( "Cannot multiply: not a number" ),
- frame );
+ result = throw_exception( c_string_to_lisp_string
+ ( "Cannot subtract: not a number" ),
+ frame_pointer );
break;
}
break;
@@ -507,8 +509,8 @@ struct cons_pointer lisp_subtract( struct
to_long_double( frame->arg[1] ) );
break;
default:
- result = lisp_throw( c_string_to_lisp_string
- ( "Cannot multiply: not a number" ), frame );
+ result = throw_exception( c_string_to_lisp_string
+ ( "Cannot subtract: not a number" ), frame_pointer );
break;
}
@@ -525,7 +527,7 @@ struct cons_pointer lisp_subtract( struct
*/
struct cons_pointer lisp_divide( struct
stack_frame
- *frame, struct
+ *frame, struct cons_pointer frame_pointer, struct
cons_pointer env ) {
struct cons_pointer result = NIL;
struct cons_space_object arg0 = pointer2cell( frame->arg[0] );
@@ -542,8 +544,10 @@ struct cons_pointer lisp_divide( struct
break;
case INTEGERTV:{
struct cons_pointer unsimplified =
- make_ratio( frame, frame->arg[0], frame->arg[1] );
- result = simplify_ratio( frame, unsimplified );
+ make_ratio( frame_pointer, frame->arg[0], frame->arg[1] );
+ /* 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 ) ) {
dec_ref( unsimplified );
}
@@ -552,9 +556,9 @@ struct cons_pointer lisp_divide( struct
case RATIOTV:{
struct cons_pointer one = make_integer( 1 );
struct cons_pointer ratio =
- make_ratio( frame, frame->arg[0], one );
+ make_ratio( frame_pointer, frame->arg[0], one );
result =
- divide_ratio_ratio( frame, ratio, frame->arg[1] );
+ divide_ratio_ratio( frame_pointer, ratio, frame->arg[1] );
dec_ref( ratio );
}
break;
@@ -564,9 +568,9 @@ struct cons_pointer lisp_divide( struct
to_long_double( frame->arg[1] ) );
break;
default:
- result = lisp_throw( c_string_to_lisp_string
+ result = throw_exception( c_string_to_lisp_string
( "Cannot divide: not a number" ),
- frame );
+ frame_pointer );
break;
}
break;
@@ -577,16 +581,19 @@ struct cons_pointer lisp_divide( struct
break;
case INTEGERTV:{
struct cons_pointer one = make_integer( 1 );
+ inc_ref( one);
struct cons_pointer ratio =
- make_ratio( frame, frame->arg[1], one );
+ make_ratio( frame_pointer, frame->arg[1], one );
+ inc_ref(ratio);
result =
- divide_ratio_ratio( frame, frame->arg[0], ratio );
+ divide_ratio_ratio( frame_pointer, frame->arg[0], ratio );
dec_ref( ratio );
+ dec_ref(one);
}
break;
case RATIOTV:
result =
- divide_ratio_ratio( frame, frame->arg[0],
+ divide_ratio_ratio( frame_pointer, frame->arg[0],
frame->arg[1] );
break;
case REALTV:
@@ -595,9 +602,9 @@ struct cons_pointer lisp_divide( struct
to_long_double( frame->arg[1] ) );
break;
default:
- result = lisp_throw( c_string_to_lisp_string
+ result = throw_exception( c_string_to_lisp_string
( "Cannot divide: not a number" ),
- frame );
+ frame_pointer );
break;
}
break;
@@ -607,8 +614,8 @@ struct cons_pointer lisp_divide( struct
to_long_double( frame->arg[1] ) );
break;
default:
- result = lisp_throw( c_string_to_lisp_string
- ( "Cannot divide: not a number" ), frame );
+ result = throw_exception( c_string_to_lisp_string
+ ( "Cannot divide: not a number" ), frame_pointer );
break;
}
diff --git a/src/arith/peano.h b/src/arith/peano.h
index 79735c0..46008c2 100644
--- a/src/arith/peano.h
+++ b/src/arith/peano.h
@@ -23,7 +23,7 @@ extern "C" {
* @return a pointer to an integer or real.
*/
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
@@ -32,7 +32,7 @@ extern "C" {
* @return a pointer to an integer or real.
*/
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.
@@ -41,7 +41,7 @@ extern "C" {
* @return a pointer to an integer or real.
*/
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.
@@ -50,7 +50,7 @@ extern "C" {
* @return a pointer to an integer or real.
*/
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
}
diff --git a/src/arith/ratio.c b/src/arith/ratio.c
index 8a5eec7..042aea1 100644
--- a/src/arith/ratio.c
+++ b/src/arith/ratio.c
@@ -13,6 +13,7 @@
#include "conspage.h"
#include "consspaceobject.h"
+#include "dump.h"
#include "equal.h"
#include "integer.h"
#include "lispops.h"
@@ -24,7 +25,7 @@
* declared in peano.c, can't include piano.h here because
* circularity. TODO: refactor.
*/
-struct cons_pointer inverse( struct stack_frame *frame,
+struct cons_pointer inverse( struct cons_pointer frame_pointer,
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,
* 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 result = arg;
@@ -70,15 +71,15 @@ struct cons_pointer simplify_ratio( struct stack_frame *frame,
result = make_integer( ddrv / gcd );
} else {
result =
- make_ratio( frame, make_integer( ddrv / gcd ),
+ make_ratio( frame_pointer, make_integer( ddrv / gcd ),
make_integer( drrv / gcd ) );
}
}
} else {
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" ),
- arg ), frame );
+ arg ), frame_pointer );
}
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,
* 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 arg2 ) {
struct cons_pointer r, result;
@@ -123,7 +124,7 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame,
#endif
if ( dr1v == dr2v ) {
- r = make_ratio( frame,
+ r = make_ratio( frame_pointer,
make_integer( dd1v + dd2v ),
cell1.payload.ratio.divisor );
} else {
@@ -131,10 +132,10 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame,
dr1vm = make_integer( dr1v * m1 ),
dd2vm = make_integer( dd2v * m2 ),
dr2vm = make_integer( dr2v * m2 ),
- r1 = make_ratio( frame, dd1vm, dr1vm ),
- r2 = make_ratio( frame, dd2vm, dr2vm );
+ r1 = make_ratio( frame_pointer, dd1vm, dr1vm ),
+ 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
* 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 );
}
- result = simplify_ratio( frame, r );
+ result = simplify_ratio( frame_pointer, r );
if ( !eq( r, result ) ) {
dec_ref( r );
}
} else {
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" ),
make_cons( arg1,
make_cons( arg2, NIL ) ) ),
- frame );
+ frame_pointer );
}
#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
* `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 ratarg ) {
struct cons_pointer result;
if ( integerp( intarg ) && ratiop( ratarg ) ) {
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( ratio );
} else {
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" ),
make_cons( intarg,
make_cons( ratarg, NIL ) ) ),
- frame );
+ frame_pointer );
}
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
* 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 arg2 ) {
- struct cons_pointer i = make_ratio( frame,
+ struct cons_pointer i = make_ratio( frame_pointer,
pointer2cell( arg2 ).payload.ratio.
divisor,
pointer2cell( arg2 ).payload.ratio.
dividend ), result =
- multiply_ratio_ratio( frame, arg1, i );
+ multiply_ratio_ratio( frame_pointer, arg1, 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,
* this is going to break horribly.
*/
-struct cons_pointer multiply_ratio_ratio( struct
- stack_frame
- *frame, struct
+struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, struct
cons_pointer arg1, struct
cons_pointer arg2 ) {
struct cons_pointer result;
@@ -249,18 +248,18 @@ struct cons_pointer multiply_ratio_ratio( struct
ddrv = dd1v * dd2v, drrv = dr1v * dr2v;
struct cons_pointer unsimplified =
- make_ratio( frame, make_integer( ddrv ),
+ make_ratio( frame_pointer, make_integer( ddrv ),
make_integer( drrv ) );
- result = simplify_ratio( frame, unsimplified );
+ result = simplify_ratio( frame_pointer, unsimplified );
if ( !eq( unsimplified, result ) ) {
dec_ref( unsimplified );
}
} else {
result =
- lisp_throw( c_string_to_lisp_string
+ throw_exception( c_string_to_lisp_string
( "Shouldn't happen: bad arg to multiply_ratio_ratio" ),
- frame );
+ frame_pointer );
}
return result;
@@ -271,23 +270,23 @@ struct cons_pointer multiply_ratio_ratio( struct
* the intger indicated by `intarg` and the ratio indicated by
* `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 ratarg ) {
struct cons_pointer result;
if ( integerp( intarg ) && ratiop( ratarg ) ) {
struct cons_pointer one = make_integer( 1 ),
- ratio = make_ratio( frame, intarg, one );
- result = multiply_ratio_ratio( frame, ratio, ratarg );
+ ratio = make_ratio( frame_pointer, intarg, one );
+ result = multiply_ratio_ratio( frame_pointer, ratio, ratarg );
dec_ref( one );
dec_ref( ratio );
} else {
result =
- lisp_throw( c_string_to_lisp_string
+ throw_exception( c_string_to_lisp_string
( "Shouldn't happen: bad arg to multiply_integer_ratio" ),
- frame );
+ frame_pointer );
}
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,
* 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 arg2 ) {
- struct cons_pointer i = inverse( frame, arg2 ),
- result = add_ratio_ratio( frame, arg1, i );
+ struct cons_pointer i = inverse( frame_pointer, arg2 ),
+ result = add_ratio_ratio( frame_pointer, arg1, 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
* 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 divisor ) {
struct cons_pointer result;
@@ -328,9 +327,9 @@ struct cons_pointer make_ratio( struct stack_frame *frame,
cell->payload.ratio.divisor = divisor;
} else {
result =
- lisp_throw( c_string_to_lisp_string
+ throw_exception( c_string_to_lisp_string
( "Dividend and divisor of a ratio must be integers" ),
- frame );
+ frame_pointer );
}
#ifdef DEBUG
dump_object( stderr, result );
diff --git a/src/arith/ratio.h b/src/arith/ratio.h
index c4e5548..feb8925 100644
--- a/src/arith/ratio.h
+++ b/src/arith/ratio.h
@@ -11,36 +11,34 @@
#ifndef __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 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 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 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 arg2 );
-struct cons_pointer multiply_ratio_ratio( struct
- stack_frame
- *frame, struct
+struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, struct
cons_pointer arg1, struct
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 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 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 divisor );
diff --git a/src/init.c b/src/init.c
index 9716365..48516f6 100644
--- a/src/init.c
+++ b/src/init.c
@@ -90,6 +90,7 @@ int main( int argc, char *argv[] ) {
bind_function( "eq", &lisp_eq );
bind_function( "equal", &lisp_equal );
bind_function( "eval", &lisp_eval );
+ bind_function( "exception", &lisp_exception );
bind_function( "multiply", &lisp_multiply );
bind_function( "read", &lisp_read );
bind_function( "oblist", &lisp_oblist );
@@ -98,6 +99,7 @@ int main( int argc, char *argv[] ) {
bind_function( "reverse", &lisp_reverse );
bind_function( "set", &lisp_set );
bind_function( "subtract", &lisp_subtract );
+ bind_function( "throw", &lisp_exception );
bind_function( "type", &lisp_type );
bind_function( "+", &lisp_add );
diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c
index 39f464a..75a5257 100644
--- a/src/memory/consspaceobject.c
+++ b/src/memory/consspaceobject.c
@@ -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.
@@ -178,20 +86,24 @@ struct cons_pointer make_cons( struct cons_pointer car,
/**
* 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.
+ * @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 stack_frame *frame ) {
- struct cons_pointer pointer = allocate_cell( EXCEPTIONTAG );
- struct cons_space_object *cell = &pointer2cell( pointer );
+ struct cons_pointer frame_pointer ) {
+ struct cons_pointer result = NIL;
+ struct cons_pointer pointer = allocate_cell( EXCEPTIONTAG );
+ struct cons_space_object *cell = &pointer2cell( pointer );
- inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */
+ inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */
- inc_ref( message );
- cell->payload.exception.message = message;
- cell->payload.exception.frame = frame;
+ inc_ref( message );
+ inc_ref( frame_pointer);
+ cell->payload.exception.message = message;
+ 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
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_space_object *cell = &pointer2cell( pointer );
@@ -298,7 +211,8 @@ struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) {
*/
struct cons_pointer
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_space_object *cell = &pointer2cell( pointer );
diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h
index 43bdfe0..b31a0bf 100644
--- a/src/memory/consspaceobject.h
+++ b/src/memory/consspaceobject.h
@@ -278,13 +278,14 @@ struct cons_pointer {
* here to avoid circularity. TODO: refactor.
*/
struct stack_frame {
- struct stack_frame *previous; /* the previous frame */
+ struct cons_pointer previous; /* the previous frame */
struct cons_pointer arg[args_in_frame];
/*
* first 8 arument bindings
*/
struct cons_pointer more; /* list of any further argument bindings */
struct cons_pointer function; /* the function to be called */
+ int args;
};
/**
@@ -311,7 +312,7 @@ struct cons_payload {
*/
struct exception_payload {
struct cons_pointer message;
- struct stack_frame *frame;
+ struct cons_pointer frame;
};
/**
@@ -326,6 +327,7 @@ struct exception_payload {
struct function_payload {
struct cons_pointer source;
struct cons_pointer ( *executable ) ( struct stack_frame *,
+ 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
* stack frame (representing the previous stack frame) as arguments and returns
* 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 cons_pointer source;
struct cons_pointer ( *executable ) ( struct stack_frame *,
+ struct cons_pointer,
struct cons_pointer );
};
@@ -421,7 +421,8 @@ struct vectorp_payload {
* tag. */
uint32_t value; /* the tag considered as a number */
} 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
* implement vector space) */
};
@@ -514,20 +515,11 @@ void inc_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 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 stack_frame *frame );
+ struct cons_pointer frame_pointer );
/**
* 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 ( *executable )
( struct stack_frame *,
+ 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 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.
*/
struct cons_pointer make_special( struct cons_pointer src,
struct cons_pointer ( *executable )
( struct stack_frame *,
+ struct cons_pointer,
struct cons_pointer ) );
/**
diff --git a/src/memory/dump.c b/src/memory/dump.c
new file mode 100644
index 0000000..5306801
--- /dev/null
+++ b/src/memory/dump.c
@@ -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;
+ }
+}
diff --git a/src/memory/dump.h b/src/memory/dump.h
new file mode 100644
index 0000000..e49f453
--- /dev/null
+++ b/src/memory/dump.h
@@ -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
diff --git a/src/memory/stack.c b/src/memory/stack.c
index 1bb8b1b..8fe268e 100644
--- a/src/memory/stack.c
+++ b/src/memory/stack.c
@@ -11,9 +11,6 @@
* with freelists to a more general 'equal sized object pages', so that
* 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>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
@@ -25,87 +22,128 @@
#include "lispops.h"
#include "print.h"
#include "stack.h"
+#include "vectorspace.h"
+
+/**
+ * get the actual stackframe object from this `pointer`, or NULL if
+ * `pointer` is not a stackframe pointer.
+ */
+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;
+
+ if (vectorpointp(pointer) && stackframep(vso))
+ {
+ result = (struct stack_frame *) &(vso->payload);
+ }
+
+ 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.
+ * @return the new frame, or NULL if memory is exhausted.
*/
-struct stack_frame *make_empty_frame( struct stack_frame *previous,
- struct cons_pointer env ) {
- struct stack_frame *result = malloc( sizeof( struct stack_frame ) );
+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
*/
- result->previous = previous;
+ frame->previous = previous;
+ inc_ref(previous);
/*
* clearing the frame with memset would probably be slightly quicker, but
* this is clear.
*/
- result->more = NIL;
- result->function = NIL;
+ frame->more = NIL;
+ frame->function = NIL;
+ frame->args = 0;
for ( int i = 0; i < args_in_frame; i++ ) {
- set_reg( result, i, NIL );
+ set_reg( frame, i, NIL );
}
+ }
return result;
}
-
/**
* Allocate a new stack frame with its previous pointer set to this value,
* its arguments set up from these args, evaluated in this env.
* @param previous the current top-of-stack;
* @args the arguments to load into this frame;
* @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 args,
- struct cons_pointer env,
- struct cons_pointer *exception ) {
- struct stack_frame *result = make_empty_frame( previous, env );
+struct cons_pointer make_stack_frame( struct cons_pointer previous,
+ struct cons_pointer args,
+ struct cons_pointer env ) {
+ struct cons_pointer result = make_empty_frame( previous );
- for ( int i = 0; i < args_in_frame && consp( args ); i++ ) {
- /* iterate down the arg list filling in the arg slots in the
+ 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
* frame. When there are no more slots, if there are still args,
* stash them on more */
- struct cons_space_object cell = pointer2cell( args );
+ struct cons_space_object cell = pointer2cell( args );
- /*
+ /*
* TODO: if we were running on real massively parallel hardware,
* each arg except the first should be handed off to another
* processor to be evaled in parallel; but see notes here:
* 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);
+ inc_ref(arg_frame_pointer);
+
+ if(nilp(arg_frame_pointer)) {
+ result = make_exception(c_string_to_lisp_string( "Memory exhausted."), previous);
+ break;
+ } else {
+ 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, env );
+ struct cons_pointer val = lisp_eval( arg_frame, arg_frame_pointer, env );
if ( exceptionp( val ) ) {
- exception = &val;
- break;
+ result = val;
+ break;
} else {
- set_reg( result, i, val );
+ set_reg( frame, frame->args, val );
}
- free_stack_frame( arg_frame );
+ dec_ref(arg_frame_pointer);
args = cell.payload.cons.cdr;
+ }
}
- if ( consp( args ) ) {
+ if (!exceptionp(result)) {
+ if ( consp( args ) ) {
/* if we still have args, eval them and stick the values on `more` */
- struct cons_pointer more = eval_forms( previous, args, env );
- result->more = more;
+ struct cons_pointer more = eval_forms( get_stack_frame(previous), previous, args, env );
+ frame->more = more;
inc_ref( more );
- }
+ }
- dump_frame( stderr, result );
- return result;
+#ifdef DEBUG
+ dump_frame( stderr, result );
+#endif
+ }
+ }
+
+ return result;
}
/**
@@ -116,25 +154,39 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous,
* @param env the execution environment;
* @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 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
* frame. When there are no more slots, if there are still args,
* stash them on more */
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;
}
- if ( consp( args ) ) {
- result->more = args;
+ if (!exceptionp(result)) {
+ if ( consp( args ) ) {
+ frame->more = args;
inc_ref( args );
+ }
+
+#ifdef DEBUG
+ dump_frame( stderr, result );
+#endif
}
+ }
return result;
}
@@ -160,26 +212,41 @@ void free_stack_frame( struct stack_frame *frame ) {
/**
* Dump a stackframe to this stream for debugging
* @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 ) {
- fputws( L"Dumping stack frame\n", output );
- for ( int arg = 0; arg < args_in_frame; arg++ ) {
- struct cons_space_object cell = pointer2cell( frame->arg[arg] );
+void dump_frame( FILE * output, struct cons_pointer frame_pointer ) {
+ struct stack_frame *frame = get_stack_frame(frame_pointer);
- fwprintf( output, L"Arg %d:\t%c%c%c%c\tcount: %10u\tvalue: ", arg,
- cell.tag.bytes[0],
- cell.tag.bytes[1], cell.tag.bytes[2], cell.tag.bytes[3],
- cell.count );
+ if (frame != NULL) {
+ for ( int arg = 0; arg < frame->args; arg++ ) {
+ struct cons_space_object cell = pointer2cell( frame->arg[arg] );
- print( output, frame->arg[arg] );
- fputws( L"\n", output );
+ fwprintf( output, L"Arg %d:\t%c%c%c%c\tcount: %10u\tvalue: ", arg,
+ cell.tag.bytes[0],
+ cell.tag.bytes[1], cell.tag.bytes[2], cell.tag.bytes[3],
+ cell.count );
+
+ print( output, frame->arg[arg] );
+ fputws( L"\n", output );
}
fputws( L"More: \t", output );
print( output, frame->more );
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.
diff --git a/src/memory/stack.h b/src/memory/stack.h
index d708b39..df76849 100644
--- a/src/memory/stack.h
+++ b/src/memory/stack.h
@@ -24,46 +24,40 @@
#ifndef __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,
• because that way we can be sure the inc_ref happens!
*/
#define set_reg(frame,register,value)frame->arg[register]=value; inc_ref(value)
+struct stack_frame * get_stack_frame(struct cons_pointer pointer);
-/**
- * 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.
- */
-struct stack_frame *make_empty_frame( struct stack_frame *previous,
- struct cons_pointer env );
+struct cons_pointer make_empty_frame( struct cons_pointer previous );
+
+struct cons_pointer make_stack_frame( struct cons_pointer previous,
+ struct cons_pointer args,
+ 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 );
-/**
- * Dump a stackframe to this stream for debugging
- * @param output the stream
- * @param frame the frame
- */
-void dump_frame( FILE * output, struct stack_frame *frame );
+void dump_frame( FILE * output, struct cons_pointer pointer );
+
+void dump_stack_trace(FILE * output, struct cons_pointer frame_pointer);
struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int n );
-/**
- * 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 make_special_frame( struct cons_pointer previous,
struct cons_pointer args,
struct cons_pointer env );
diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c
index 4b18b96..c0b6f8d 100644
--- a/src/memory/vectorspace.c
+++ b/src/memory/vectorspace.c
@@ -8,6 +8,7 @@
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
+#include <math.h>
#include <stdint.h>
#include <stdlib.h>
#include <string.h>
@@ -29,7 +30,7 @@
* NOTE that `tag` should be the vector-space tag of the particular type of
* 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_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.
* NOTE that `tag` should be the vector-space tag of the particular type of
* 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;
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 ) {
- strncpy( &vso->tag.bytes[0], tag, TAGLENGTH );
- vso->vecp = make_vec_pointer( tag, ( uint64_t ) vso );
- vso->size = payload_size;
+ strncpy( &vso->header.tag.bytes[0], tag, TAGLENGTH );
+ vso->header.vecp = make_vec_pointer( tag, vso );
+ vso->header.size = payload_size;
#ifdef DEBUG
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 );
+ if (padded != total_size){
+ fwprintf(stderr, L"\t\tPadded from %d to %d\n",
+ total_size, padded);
+ }
#endif
- result = vso->vecp;
+ result = vso->header.vecp;
}
-
return result;
}
diff --git a/src/memory/vectorspace.h b/src/memory/vectorspace.h
index 07a0b91..83fa74c 100644
--- a/src/memory/vectorspace.h
+++ b/src/memory/vectorspace.h
@@ -34,20 +34,16 @@
#define NAMESPACETAG "NMSP"
#define NAMESPACETV 0
-/*
- * a stack frame.
- */
-#define STACKFRAMETAG "STAK"
-#define STACKFRAMETV
/*
* a vector of cons pointers.
*/
#define VECTORTAG "VECT"
#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 {
union {
@@ -62,8 +58,10 @@ struct vector_space_header {
struct cons_pointer vecp; /* back pointer to the vector pointer
* which uniquely points to this vso */
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,
* `payload` is just the first of these.
* TODO: this is almost certainly not
diff --git a/src/ops/lispops.c b/src/ops/lispops.c
index 9b12faa..825222f 100644
--- a/src/ops/lispops.c
+++ b/src/ops/lispops.c
@@ -80,6 +80,7 @@ struct cons_pointer c_cdr( struct cons_pointer arg ) {
* @return the result of evaluating the form.
*/
struct cons_pointer eval_form( struct stack_frame *parent,
+ struct cons_pointer parent_pointer,
struct cons_pointer form,
struct cons_pointer env ) {
fputws( L"eval_form: ", stderr );
@@ -87,15 +88,19 @@ struct cons_pointer eval_form( struct stack_frame *parent,
fputws( L"\n", stderr );
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 );
- result = lisp_eval( next, env );
+
+ result = lisp_eval( next, next_pointer, 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. */
- free_stack_frame( next );
+ dec_ref(next_pointer);
}
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
* `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 env ) {
+ /* TODO: refactor. This runs up the C stack. */
return consp( list ) ?
- make_cons( eval_form( frame, c_car( list ), env ),
- eval_forms( frame, c_cdr( list ), env ) ) : NIL;
+ make_cons( eval_form( frame, frame_pointer, c_car( list ), env ),
+ eval_forms( frame, frame_pointer, c_cdr( list ), env ) ) : NIL;
}
/**
@@ -120,7 +126,7 @@ struct cons_pointer eval_forms( struct stack_frame *frame,
* (oblist)
*/
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;
}
@@ -153,7 +159,7 @@ struct cons_pointer compose_body( struct stack_frame *frame ) {
* @param env the environment in which it is to be intepreted.
*/
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 ) );
}
@@ -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.
*/
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 ) );
}
@@ -182,7 +188,7 @@ void log_binding( struct cons_pointer name, struct cons_pointer val ) {
* Evaluate a lambda or nlambda expression.
*/
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 result = NIL;
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 ) ) {
/* if `names` is a symbol, rather than a list of symbols,
* then bind a list of the values of args to that symbol. */
+ /* TODO: eval all the things in frame->more */
struct cons_pointer vals = frame->more;
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 */
} else {
@@ -223,8 +230,10 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
while ( !nilp( body ) ) {
struct cons_pointer sexpr = c_car( body );
body = c_cdr( body );
+#ifdef DEBUG
fputws( L"In lambda: ", stderr );
- result = eval_form( frame, sexpr, new_env );
+#endif
+ result = eval_form( frame, frame_pointer, sexpr, new_env );
}
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.
*/
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 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] ) );
- 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 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. */
- free_stack_frame( fn_frame );
+ dec_ref(fn_frame_pointer);
}
struct cons_space_object fn_cell = pointer2cell( fn_pointer );
@@ -263,67 +278,66 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
case FUNCTIONTV:
{
struct cons_pointer exep = NIL;
- struct stack_frame *next =
- make_stack_frame( frame, args, env, &exep );
- result = ( *fn_cell.payload.special.executable ) ( next, env );
- if ( exceptionp( exep ) ) {
- /* 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;
+ struct cons_pointer next_pointer =
+ make_stack_frame( frame_pointer, args, env );
+ inc_ref(next_pointer);
+ if ( exceptionp( next_pointer ) ) {
+ result = next_pointer;
} 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;
case LAMBDATV:
{
struct cons_pointer exep = NIL;
- struct stack_frame *next =
- make_stack_frame( frame, args, env, &exep );
-#ifdef DEBUG
- fputws( L"Stack frame for lambda\n", stderr );
- dump_frame( stderr, next );
-#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;
+ struct cons_pointer next_pointer =
+ make_stack_frame( frame_pointer, args, env );
+ inc_ref(next_pointer);
+ if ( exceptionp( next_pointer ) ) {
+ result = next_pointer;
} 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;
case NLAMBDATV:
{
- struct stack_frame *next =
- make_special_frame( frame, args, env );
-#ifdef DEBUG
- fputws( L"Stack frame for nlambda\n", stderr );
- dump_frame( stderr, next );
-#endif
- result = eval_lambda( fn_cell, next, env );
+ struct cons_pointer next_pointer =
+ make_special_frame( frame_pointer, args, env );
+ inc_ref(next_pointer);
+ if ( exceptionp( next_pointer ) ) {
+ result = next_pointer;
+ } else {
+ struct stack_frame *next = get_stack_frame(frame_pointer);
+ result = eval_lambda( fn_cell, next, next_pointer, 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. */
- free_stack_frame( next );
+ dec_ref(next_pointer);
}
+ }
}
break;
case SPECIALTV:
{
- struct stack_frame *next =
- make_special_frame( frame, args, env );
- result = ( *fn_cell.payload.special.executable ) ( next, env );
+ struct cons_pointer next_pointer =
+ make_special_frame( frame_pointer, args, 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 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. */
- free_stack_frame( next );
+ dec_ref(next_pointer);
}
+ }
}
break;
default:
@@ -338,9 +352,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer message =
c_string_to_lisp_string( buffer );
free( buffer );
- result = lisp_throw( message, frame );
+ result = throw_exception( message, frame_pointer );
}
}
+ dec_ref(fn_frame_pointer);
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.
*/
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_space_object cell = pointer2cell( frame->arg[0] );
#ifdef DEBUG
fputws( L"Eval: ", stderr );
- dump_frame( stderr, frame );
+ dump_frame( stderr, frame_pointer );
#endif
switch ( cell.tag.value ) {
case CONSTV:
{
- result = c_apply( frame, env );
+ result = c_apply( frame, frame_pointer, env );
}
break;
@@ -403,7 +418,7 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
make_cons( c_string_to_lisp_string
( "Attempt to take value of unbound symbol." ),
frame->arg[0] );
- result = lisp_throw( message, frame );
+ result = throw_exception( message, frame_pointer );
} else {
result = c_assoc( canonical, env );
inc_ref( result );
@@ -441,15 +456,15 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
* the second argument
*/
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
fputws( L"Apply: ", stderr );
- dump_frame( stderr, frame );
+ dump_frame( stderr, frame_pointer );
#endif
set_reg( frame, 0, make_cons( frame->arg[0], frame->arg[1] ) );
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
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.
*/
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];
}
@@ -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`.
*/
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 namespace =
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
( c_string_to_lisp_string
( "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;
@@ -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`.
*/
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 namespace =
nilp( frame->arg[2] ) ? oblist : frame->arg[2];
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 );
result = val;
} else {
@@ -528,7 +543,7 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ) {
make_exception( make_cons
( c_string_to_lisp_string
( "The first argument to `set!` is not a symbol: " ),
- make_cons( frame->arg[0], NIL ) ), frame );
+ make_cons( frame->arg[0], NIL ) ), frame_pointer );
}
return result;
@@ -543,7 +558,7 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ) {
* otherwise returns a new cons cell.
*/
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 cdr = frame->arg[1];
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.
*/
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;
if ( consp( frame->arg[0] ) ) {
@@ -579,7 +594,7 @@ lisp_car( struct stack_frame *frame, struct cons_pointer env ) {
} else {
struct cons_pointer message =
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;
@@ -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.
*/
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;
if ( consp( frame->arg[0] ) ) {
@@ -603,7 +618,7 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer env ) {
} else {
struct cons_pointer message =
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;
@@ -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.
*/
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] );
}
@@ -622,7 +637,7 @@ lisp_assoc( struct stack_frame *frame, struct cons_pointer env ) {
* (eq a b)
* 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 ) {
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
*/
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;
}
@@ -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.
*/
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;
if ( readp( frame->arg[0] ) ) {
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)
* 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 ) {
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.
*/
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;
FILE *output = stdout;
@@ -706,9 +724,11 @@ lisp_print( struct stack_frame *frame, struct cons_pointer env ) {
result = print( output, frame->arg[0] );
+#ifdef DEBUG
fputws( L"Print returning ", stderr );
- print( stderr, result );
+ // print( stderr, result );
fputws( L"\n", stderr );
+#endif
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.
*/
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] );
}
@@ -739,16 +759,16 @@ lisp_type( struct stack_frame *frame, struct cons_pointer env ) {
* argument.
*/
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 result = NIL;
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 ) ) {
- result = eval_form( frame, c_car( remaining ), env );
+ result = eval_form( frame, frame_pointer, c_car( remaining ), env );
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.
*/
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;
bool done = false;
@@ -777,11 +797,11 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) {
if ( consp( clause_pointer ) ) {
struct cons_space_object cell = pointer2cell( clause_pointer );
- result = eval_form( frame, c_car( clause_pointer ), env );
+ result = eval_form( frame, frame_pointer, c_car( clause_pointer ), env );
if ( !nilp( result ) ) {
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 ) ) {
result = c_car( vals );
@@ -793,9 +813,9 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) {
} else if ( nilp( clause_pointer ) ) {
done = true;
} else {
- result = lisp_throw( c_string_to_lisp_string
+ result = throw_exception( c_string_to_lisp_string
( "Arguments to `cond` must be lists" ),
- frame );
+ frame_pointer);
}
}
/* 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.
- * This requires that a frame be a heap-space object with a cons-space
+ * 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.
* object pointing to it. Then this should become a normal lisp function
* which expects a normally bound frame and environment, such that
* frame->arg[0] is the message, and frame->arg[1] is the cons-space
* pointer to the frame in which the exception occurred.
*/
struct cons_pointer
-lisp_throw( struct cons_pointer message, struct stack_frame *frame ) {
+throw_exception( struct cons_pointer message, struct cons_pointer frame_pointer ) {
fwprintf( stderr, L"\nERROR: " );
print( stderr, message );
struct cons_pointer result = NIL;
@@ -823,8 +845,23 @@ lisp_throw( struct cons_pointer message, struct stack_frame *frame ) {
if ( cell.tag.value == EXCEPTIONTV ) {
result = message;
} else {
- result = make_exception( message, frame );
+ result = make_exception( message, frame_pointer );
}
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);
+}
diff --git a/src/ops/lispops.h b/src/ops/lispops.h
index 961cf2e..059255d 100644
--- a/src/ops/lispops.h
+++ b/src/ops/lispops.h
@@ -51,6 +51,7 @@ struct cons_pointer c_reverse( struct cons_pointer arg );
* @return the result of evaluating the form.
*/
struct cons_pointer eval_form( struct stack_frame *parent,
+ struct cons_pointer parent_pointer,
struct cons_pointer form,
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
* `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 env );
@@ -67,19 +68,19 @@ struct cons_pointer eval_forms( struct stack_frame *frame,
/*
* 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 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
-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
-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
-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.
@@ -88,7 +89,7 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env );
* @param lexpr the lambda expression to be interpreted;
* @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 );
/**
@@ -98,31 +99,31 @@ struct cons_pointer lisp_lambda( struct stack_frame *frame,
* @param env the environment in which it is to be intepreted.
*/
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 );
/*
* 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 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 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 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 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 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 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 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 lisp_reverse( struct stack_frame *frame,
+struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
/**
* Function: Get the Lisp type of the single argument.
@@ -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.
*/
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.
*/
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
@@ -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.
*/
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 stack_frame *frame );
+struct cons_pointer throw_exception( struct cons_pointer message,
+ struct cons_pointer frame_pointer );
+
+struct cons_pointer
+lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env );
diff --git a/src/ops/print.c b/src/ops/print.c
index 4ec5a15..7efd59f 100644
--- a/src/ops/print.c
+++ b/src/ops/print.c
@@ -20,6 +20,7 @@
#include "conspage.h"
#include "consspaceobject.h"
#include "integer.h"
+#include "stack.h"
#include "print.h"
/**
@@ -118,12 +119,7 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
case EXCEPTIONTV:
fwprintf( output, L"\n%sException: ",
print_use_colours ? "\x1B[31m" : "" );
- if ( stringp( cell.payload.exception.message ) ) {
- print_string_contents( output,
- cell.payload.exception.message );
- } else {
- print( output, cell.payload.exception.message );
- }
+ dump_stack_trace(output, pointer);
break;
case FUNCTIONTV:
fwprintf( output, L"(Function)" );
diff --git a/src/ops/read.c b/src/ops/read.c
index bd063b2..1a09700 100644
--- a/src/ops/read.c
+++ b/src/ops/read.c
@@ -25,6 +25,7 @@
#include "ratio.h"
#include "read.h"
#include "real.h"
+#include "vectorspace.h"
/*
* 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.
*/
-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 );
-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 );
struct cons_pointer read_string( 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
* 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 ) {
struct cons_pointer result = NIL;
@@ -64,7 +67,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
if ( feof( input ) ) {
result =
make_exception( c_string_to_lisp_string
- ( "End of file while reading" ), frame );
+ ( "End of file while reading" ), frame_pointer );
} else {
switch ( c ) {
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 */
break;
case EOF:
- result = lisp_throw( c_string_to_lisp_string
- ( "End of input while reading" ), frame );
+ result = throw_exception( c_string_to_lisp_string
+ ( "End of input while reading" ), frame_pointer );
break;
case '\'':
result =
c_quote( read_continuation
- ( frame, input, fgetwc( input ) ) );
+ ( frame, frame_pointer, input, fgetwc( input ) ) );
break;
case '(':
- result = read_list( frame, input, fgetwc( input ) );
+ result = read_list( frame, frame_pointer, input, fgetwc( input ) );
break;
case '"':
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 );
ungetwc( next, input );
if ( iswdigit( next ) ) {
- result = read_number( frame, input, c, false );
+ result = read_number( frame, frame_pointer, input, c, false );
} else {
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 );
if ( iswdigit( next ) ) {
ungetwc( next, input );
- result = read_number( frame, input, c, true );
+ result = read_number( frame, frame_pointer, input, c, true );
} else if ( iswblank( next ) ) {
/* dotted pair. TODO: this isn't right, we
* really need to backtrack up a level. */
result =
- read_continuation( frame, input, fgetwc( input ) );
+ read_continuation( frame, frame_pointer, input, fgetwc( input ) );
} else {
read_symbol( input, c );
}
@@ -114,7 +117,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
break;
default:
if ( iswdigit( c ) ) {
- result = read_number( frame, input, c, false );
+ result = read_number( frame, frame_pointer, input, c, false );
} else if ( iswprint( c ) ) {
result = read_symbol( input, c );
} 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
( "Unrecognised start of input character" ),
make_string( c, NIL ) ),
- frame );
+ frame_pointer );
}
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
* 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 ) {
struct cons_pointer result = NIL;
int64_t accumulator = 0;
@@ -157,7 +162,7 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input,
if ( seen_period || dividend != 0 ) {
return make_exception( c_string_to_lisp_string
( "Malformed number: too many periods" ),
- frame );
+ frame_pointer );
} else {
seen_period = true;
}
@@ -165,7 +170,7 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input,
if ( seen_period || dividend > 0 ) {
return make_exception( c_string_to_lisp_string
( "Malformed number: dividend of rational must be integer" ),
- frame );
+ frame_pointer );
} else {
dividend = negative ? 0 - accumulator : accumulator;
@@ -200,7 +205,7 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input,
result = make_real( rv );
} else if ( dividend != 0 ) {
result =
- make_ratio( frame, make_integer( dividend ),
+ make_ratio( frame_pointer, make_integer( dividend ),
make_integer( accumulator ) );
} else {
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
* left parenthesis.
*/
-struct cons_pointer read_list( struct
- stack_frame
- *frame, FILE * input, wint_t initial ) {
+struct cons_pointer read_list( struct stack_frame *frame,
+ struct cons_pointer frame_pointer,
+ FILE * input, wint_t initial ) {
struct cons_pointer result = NIL;
if ( initial != ')' ) {
#ifdef DEBUG
fwprintf( stderr,
L"read_list starting '%C' (%d)\n", initial, initial );
#endif
- struct cons_pointer car = read_continuation( frame, input,
+ struct cons_pointer car = read_continuation( frame, frame_pointer, input,
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
else {
@@ -318,6 +323,6 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
*/
struct cons_pointer read( struct
stack_frame
- *frame, FILE * input ) {
- return read_continuation( frame, input, fgetwc( input ) );
+ *frame, struct cons_pointer frame_pointer, FILE * input ) {
+ return read_continuation( frame, frame_pointer, input, fgetwc( input ) );
}
diff --git a/src/ops/read.h b/src/ops/read.h
index af7574b..c144699 100644
--- a/src/ops/read.h
+++ b/src/ops/read.h
@@ -14,6 +14,8 @@
/**
* 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
diff --git a/src/repl.c b/src/repl.c
index f9ca5d5..5dd6567 100644
--- a/src/repl.c
+++ b/src/repl.c
@@ -31,44 +31,64 @@
* Dummy up a Lisp read call with its own stack frame.
*/
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);
- set_reg( frame, 0, stream_pointer );
- struct cons_pointer result = lisp_read( frame, oblist );
- free_stack_frame( frame );
+ if (frame != NULL){
- return result;
+ set_reg( frame, 0, stream_pointer );
+ struct cons_pointer result = lisp_read( frame, frame_pointer, oblist );
+ }
+ dec_ref(frame_pointer);
+ }
+
+ return result;
}
/**
* Dummy up a Lisp eval call with its own stack frame.
*/
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);
- set_reg( frame, 0, input );
- struct cons_pointer result = lisp_eval( frame, oblist );
-
- if ( !exceptionp( result ) ) {
- free_stack_frame( frame );
+ if (frame != NULL){
+ set_reg( frame, 0, input );
+ result = lisp_eval( frame, frame_pointer, oblist );
}
- return result;
+ dec_ref(frame_pointer);
+ }
+
+ return result;
}
/**
* Dummy up a Lisp print call with its own stack frame.
*/
struct cons_pointer repl_print( struct cons_pointer stream_pointer,
- struct cons_pointer value ) {
- struct stack_frame *frame = make_empty_frame( NULL, oblist );
+ struct cons_pointer value ) {
+ 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);
- set_reg( frame, 0, value );
- set_reg( frame, 1, stream_pointer );
- struct cons_pointer result = lisp_print( frame, oblist );
- free_stack_frame( frame );
+ if (frame != NULL){
+ set_reg( frame, 0, value );
+ set_reg( frame, 1, stream_pointer );
+ result = lisp_print( frame, frame_pointer, oblist );
+ free_stack_frame( frame );
+ }
+ dec_ref(frame_pointer);
+ }
- return result;
+ return result;
}
/**
From 3d5c27cb10df058363a2f37789fea170a75451ed Mon Sep 17 00:00:00 2001
From: Simon Brooke <simon@journeyman.cc>
Date: Wed, 26 Dec 2018 21:10:24 +0000
Subject: [PATCH 2/6] Horribly broken, may have to rethink.
---
src/arith/peano.c | 104 +++++++------
src/arith/peano.h | 14 +-
src/arith/ratio.c | 69 ++++-----
src/arith/ratio.h | 10 +-
src/arith/real.c | 1 +
src/memory/consspaceobject.c | 26 ++--
src/memory/consspaceobject.h | 8 +-
src/memory/dump.c | 23 +--
src/memory/stack.c | 282 ++++++++++++++++++++---------------
src/memory/stack.h | 8 +-
src/memory/vectorspace.c | 26 +++-
src/memory/vectorspace.h | 2 +-
src/ops/equal.c | 4 +-
src/ops/lispops.c | 194 ++++++++++++++----------
src/ops/lispops.h | 68 ++++++---
src/ops/print.c | 10 +-
src/ops/read.c | 56 ++++---
src/ops/read.h | 3 +-
src/repl.c | 73 ++++-----
19 files changed, 568 insertions(+), 413 deletions(-)
diff --git a/src/arith/peano.c b/src/arith/peano.c
index 63783f5..763414e 100644
--- a/src/arith/peano.c
+++ b/src/arith/peano.c
@@ -28,7 +28,9 @@
long double to_long_double( 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 frame_pointer, 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 );
@@ -119,7 +121,9 @@ int64_t to_long_int( struct cons_pointer arg ) {
* return a cons_pointer indicating a number which is the sum of
* the numbers indicated by `arg1` and `arg2`.
*/
-struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer frame_pointer, 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 result;
struct cons_space_object cell1 = pointer2cell( arg1 );
@@ -153,7 +157,8 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer frame_
cell2.payload.integer.value );
break;
case RATIOTV:
- result = add_integer_ratio( frame_pointer, arg1, arg2 );
+ result =
+ add_integer_ratio( frame_pointer, arg1, arg2 );
break;
case REALTV:
result =
@@ -162,8 +167,8 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer frame_
break;
default:
result = throw_exception( c_string_to_lisp_string
- ( "Cannot add: not a number" ),
- frame_pointer );
+ ( "Cannot add: not a number" ),
+ frame_pointer );
break;
}
break;
@@ -173,7 +178,8 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer frame_
result = arg2;
break;
case INTEGERTV:
- result = add_integer_ratio( frame_pointer, arg2, arg1 );
+ result =
+ add_integer_ratio( frame_pointer, arg2, arg1 );
break;
case RATIOTV:
result = add_ratio_ratio( frame_pointer, arg1, arg2 );
@@ -185,8 +191,8 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer frame_
break;
default:
result = throw_exception( c_string_to_lisp_string
- ( "Cannot add: not a number" ),
- frame_pointer );
+ ( "Cannot add: not a number" ),
+ frame_pointer );
break;
}
break;
@@ -198,7 +204,8 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer frame_
default:
result = exceptionp( arg2 ) ? arg2 :
throw_exception( c_string_to_lisp_string
- ( "Cannot add: not a number" ), frame_pointer );
+ ( "Cannot add: not a number" ),
+ frame_pointer );
}
}
@@ -252,7 +259,8 @@ struct cons_pointer lisp_add( struct stack_frame
* return a cons_pointer indicating a number which is the product of
* the numbers indicated by `arg1` and `arg2`.
*/
-struct cons_pointer multiply_2( struct stack_frame *frame, struct cons_pointer frame_pointer,
+struct cons_pointer multiply_2( struct stack_frame *frame,
+ struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 ) {
struct cons_pointer result;
@@ -286,7 +294,9 @@ struct cons_pointer multiply_2( struct stack_frame *frame, struct cons_pointer f
cell2.payload.integer.value );
break;
case RATIOTV:
- result = multiply_integer_ratio( frame_pointer, arg1, arg2 );
+ result =
+ multiply_integer_ratio( frame_pointer, arg1,
+ arg2 );
break;
case REALTV:
result =
@@ -295,8 +305,8 @@ struct cons_pointer multiply_2( struct stack_frame *frame, struct cons_pointer f
break;
default:
result = throw_exception( c_string_to_lisp_string
- ( "Cannot multiply: not a number" ),
- frame_pointer );
+ ( "Cannot multiply: not a number" ),
+ frame_pointer );
break;
}
break;
@@ -306,10 +316,13 @@ struct cons_pointer multiply_2( struct stack_frame *frame, struct cons_pointer f
result = arg2;
break;
case INTEGERTV:
- result = multiply_integer_ratio( frame_pointer, arg2, arg1 );
+ result =
+ multiply_integer_ratio( frame_pointer, arg2,
+ arg1 );
break;
case RATIOTV:
- result = multiply_ratio_ratio( frame_pointer, arg1, arg2 );
+ result =
+ multiply_ratio_ratio( frame_pointer, arg1, arg2 );
break;
case REALTV:
result =
@@ -318,8 +331,8 @@ struct cons_pointer multiply_2( struct stack_frame *frame, struct cons_pointer f
break;
default:
result = throw_exception( c_string_to_lisp_string
- ( "Cannot multiply: not a number" ),
- frame_pointer );
+ ( "Cannot multiply: not a number" ),
+ frame_pointer );
}
break;
case REALTV:
@@ -329,8 +342,8 @@ struct cons_pointer multiply_2( struct stack_frame *frame, struct cons_pointer f
break;
default:
result = throw_exception( c_string_to_lisp_string
- ( "Cannot multiply: not a number" ),
- frame_pointer );
+ ( "Cannot multiply: not a number" ),
+ frame_pointer );
break;
}
}
@@ -406,8 +419,8 @@ struct cons_pointer inverse( struct cons_pointer frame,
case RATIOTV:
result = make_ratio( frame,
make_integer( 0 -
- to_long_int( cell.payload.ratio.
- dividend ) ),
+ to_long_int( cell.payload.
+ ratio.dividend ) ),
cell.payload.ratio.divisor );
break;
case REALTV:
@@ -453,9 +466,10 @@ struct cons_pointer lisp_subtract( struct
struct cons_pointer tmp =
make_ratio( frame_pointer, frame->arg[0],
make_integer( 1 ) );
- inc_ref(tmp);
+ inc_ref( tmp );
result =
- subtract_ratio_ratio( frame_pointer, tmp, frame->arg[1] );
+ subtract_ratio_ratio( frame_pointer, tmp,
+ frame->arg[1] );
dec_ref( tmp );
}
break;
@@ -466,8 +480,8 @@ struct cons_pointer lisp_subtract( struct
break;
default:
result = throw_exception( c_string_to_lisp_string
- ( "Cannot subtract: not a number" ),
- frame_pointer );
+ ( "Cannot subtract: not a number" ),
+ frame_pointer );
break;
}
break;
@@ -480,9 +494,10 @@ struct cons_pointer lisp_subtract( struct
struct cons_pointer tmp =
make_ratio( frame_pointer, frame->arg[1],
make_integer( 1 ) );
- inc_ref(tmp);
+ inc_ref( tmp );
result =
- subtract_ratio_ratio( frame_pointer, frame->arg[0], tmp );
+ subtract_ratio_ratio( frame_pointer, frame->arg[0],
+ tmp );
dec_ref( tmp );
}
break;
@@ -498,8 +513,8 @@ struct cons_pointer lisp_subtract( struct
break;
default:
result = throw_exception( c_string_to_lisp_string
- ( "Cannot subtract: not a number" ),
- frame_pointer );
+ ( "Cannot subtract: not a number" ),
+ frame_pointer );
break;
}
break;
@@ -510,7 +525,8 @@ struct cons_pointer lisp_subtract( struct
break;
default:
result = throw_exception( c_string_to_lisp_string
- ( "Cannot subtract: not a number" ), frame_pointer );
+ ( "Cannot subtract: not a number" ),
+ frame_pointer );
break;
}
@@ -527,7 +543,7 @@ struct cons_pointer lisp_subtract( struct
*/
struct cons_pointer lisp_divide( struct
stack_frame
- *frame, struct cons_pointer frame_pointer, struct
+ *frame, struct cons_pointer frame_pointer, struct
cons_pointer env ) {
struct cons_pointer result = NIL;
struct cons_space_object arg0 = pointer2cell( frame->arg[0] );
@@ -544,7 +560,8 @@ struct cons_pointer lisp_divide( struct
break;
case INTEGERTV:{
struct cons_pointer unsimplified =
- make_ratio( frame_pointer, frame->arg[0], frame->arg[1] );
+ make_ratio( frame_pointer, frame->arg[0],
+ frame->arg[1] );
/* 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 );
@@ -558,7 +575,8 @@ struct cons_pointer lisp_divide( struct
struct cons_pointer ratio =
make_ratio( frame_pointer, frame->arg[0], one );
result =
- divide_ratio_ratio( frame_pointer, ratio, frame->arg[1] );
+ divide_ratio_ratio( frame_pointer, ratio,
+ frame->arg[1] );
dec_ref( ratio );
}
break;
@@ -569,8 +587,8 @@ struct cons_pointer lisp_divide( struct
break;
default:
result = throw_exception( c_string_to_lisp_string
- ( "Cannot divide: not a number" ),
- frame_pointer );
+ ( "Cannot divide: not a number" ),
+ frame_pointer );
break;
}
break;
@@ -581,14 +599,15 @@ struct cons_pointer lisp_divide( struct
break;
case INTEGERTV:{
struct cons_pointer one = make_integer( 1 );
- inc_ref( one);
+ inc_ref( one );
struct cons_pointer ratio =
make_ratio( frame_pointer, frame->arg[1], one );
- inc_ref(ratio);
+ inc_ref( ratio );
result =
- divide_ratio_ratio( frame_pointer, frame->arg[0], ratio );
+ divide_ratio_ratio( frame_pointer, frame->arg[0],
+ ratio );
dec_ref( ratio );
- dec_ref(one);
+ dec_ref( one );
}
break;
case RATIOTV:
@@ -603,8 +622,8 @@ struct cons_pointer lisp_divide( struct
break;
default:
result = throw_exception( c_string_to_lisp_string
- ( "Cannot divide: not a number" ),
- frame_pointer );
+ ( "Cannot divide: not a number" ),
+ frame_pointer );
break;
}
break;
@@ -615,7 +634,8 @@ struct cons_pointer lisp_divide( struct
break;
default:
result = throw_exception( c_string_to_lisp_string
- ( "Cannot divide: not a number" ), frame_pointer );
+ ( "Cannot divide: not a number" ),
+ frame_pointer );
break;
}
diff --git a/src/arith/peano.h b/src/arith/peano.h
index 46008c2..f1c21b4 100644
--- a/src/arith/peano.h
+++ b/src/arith/peano.h
@@ -23,7 +23,8 @@ extern "C" {
* @return a pointer to an integer or real.
*/
struct cons_pointer
- lisp_add( struct stack_frame *frame, struct cons_pointer frame_pointer, 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
@@ -32,7 +33,9 @@ extern "C" {
* @return a pointer to an integer or real.
*/
struct cons_pointer
- lisp_multiply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env );
+ lisp_multiply( struct stack_frame *frame,
+ struct cons_pointer frame_pointer,
+ struct cons_pointer env );
/**
* Subtract one number from another.
@@ -41,7 +44,9 @@ extern "C" {
* @return a pointer to an integer or real.
*/
struct cons_pointer
- lisp_subtract( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env );
+ lisp_subtract( struct stack_frame *frame,
+ struct cons_pointer frame_pointer,
+ struct cons_pointer env );
/**
* Divide one number by another.
@@ -50,7 +55,8 @@ extern "C" {
* @return a pointer to an integer or real.
*/
struct cons_pointer
- lisp_divide( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env );
+ lisp_divide( struct stack_frame *frame, struct cons_pointer frame_pointer,
+ struct cons_pointer env );
#ifdef __cplusplus
}
diff --git a/src/arith/ratio.c b/src/arith/ratio.c
index 042aea1..afea5b0 100644
--- a/src/arith/ratio.c
+++ b/src/arith/ratio.c
@@ -61,10 +61,10 @@ struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer,
if ( ratiop( arg ) ) {
int64_t ddrv =
- pointer2cell( pointer2cell( arg ).payload.ratio.dividend ).payload.
- integer.value, drrv =
- pointer2cell( pointer2cell( arg ).payload.ratio.divisor ).payload.
- integer.value, gcd = greatest_common_divisor( ddrv, drrv );
+ pointer2cell( pointer2cell( arg ).payload.ratio.dividend ).
+ payload.integer.value, drrv =
+ pointer2cell( pointer2cell( arg ).payload.ratio.divisor ).
+ payload.integer.value, gcd = greatest_common_divisor( ddrv, drrv );
if ( gcd > 1 ) {
if ( drrv / gcd == 1 ) {
@@ -78,8 +78,8 @@ struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer,
} else {
result =
throw_exception( make_cons( c_string_to_lisp_string
- ( "Shouldn't happen: bad arg to simplify_ratio" ),
- arg ), frame_pointer );
+ ( "Shouldn't happen: bad arg to simplify_ratio" ),
+ arg ), frame_pointer );
}
return result;
@@ -124,7 +124,7 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
#endif
if ( dr1v == dr2v ) {
- r = make_ratio( frame_pointer,
+ r = make_ratio( frame_pointer,
make_integer( dd1v + dd2v ),
cell1.payload.ratio.divisor );
} else {
@@ -132,8 +132,8 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
dr1vm = make_integer( dr1v * m1 ),
dd2vm = make_integer( dd2v * m2 ),
dr2vm = make_integer( dr2v * m2 ),
- r1 = make_ratio( frame_pointer, dd1vm, dr1vm ),
- r2 = make_ratio( frame_pointer, dd2vm, dr2vm );
+ r1 = make_ratio( frame_pointer, dd1vm, dr1vm ),
+ r2 = make_ratio( frame_pointer, dd2vm, dr2vm );
r = add_ratio_ratio( frame_pointer, r1, r2 );
@@ -144,17 +144,17 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
dec_ref( r2 );
}
- result = simplify_ratio( frame_pointer, r );
+ result = simplify_ratio( frame_pointer, r );
if ( !eq( r, result ) ) {
dec_ref( r );
}
} else {
result =
throw_exception( make_cons( c_string_to_lisp_string
- ( "Shouldn't happen: bad arg to add_ratio_ratio" ),
- make_cons( arg1,
- make_cons( arg2, NIL ) ) ),
- frame_pointer );
+ ( "Shouldn't happen: bad arg to add_ratio_ratio" ),
+ make_cons( arg1,
+ make_cons( arg2, NIL ) ) ),
+ frame_pointer );
}
#ifdef DEBUG
@@ -181,17 +181,18 @@ struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer,
struct cons_pointer one = make_integer( 1 ),
ratio = make_ratio( frame_pointer, intarg, one );
- result = add_ratio_ratio( frame_pointer, ratio, ratarg );
+ result = add_ratio_ratio( frame_pointer, ratio, ratarg );
dec_ref( one );
dec_ref( ratio );
} else {
result =
throw_exception( make_cons( c_string_to_lisp_string
- ( "Shouldn't happen: bad arg to add_integer_ratio" ),
- make_cons( intarg,
- make_cons( ratarg, NIL ) ) ),
- frame_pointer );
+ ( "Shouldn't happen: bad arg to add_integer_ratio" ),
+ make_cons( intarg,
+ make_cons( ratarg,
+ NIL ) ) ),
+ frame_pointer );
}
return result;
@@ -205,12 +206,12 @@ struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer,
struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 ) {
- struct cons_pointer i = make_ratio( frame_pointer,
- pointer2cell( arg2 ).payload.ratio.
- divisor,
- pointer2cell( arg2 ).payload.ratio.
- dividend ), result =
- multiply_ratio_ratio( frame_pointer, arg1, i );
+ struct cons_pointer i = make_ratio( frame_pointer,
+ pointer2cell( arg2 ).payload.
+ ratio.divisor,
+ pointer2cell( arg2 ).payload.
+ ratio.dividend ), result =
+ multiply_ratio_ratio( frame_pointer, arg1, i );
dec_ref( i );
@@ -248,7 +249,7 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str
ddrv = dd1v * dd2v, drrv = dr1v * dr2v;
struct cons_pointer unsimplified =
- make_ratio( frame_pointer, make_integer( ddrv ),
+ make_ratio( frame_pointer, make_integer( ddrv ),
make_integer( drrv ) );
result = simplify_ratio( frame_pointer, unsimplified );
@@ -258,8 +259,8 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str
} else {
result =
throw_exception( c_string_to_lisp_string
- ( "Shouldn't happen: bad arg to multiply_ratio_ratio" ),
- frame_pointer );
+ ( "Shouldn't happen: bad arg to multiply_ratio_ratio" ),
+ frame_pointer );
}
return result;
@@ -278,15 +279,15 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer,
if ( integerp( intarg ) && ratiop( ratarg ) ) {
struct cons_pointer one = make_integer( 1 ),
ratio = make_ratio( frame_pointer, intarg, one );
- result = multiply_ratio_ratio( frame_pointer, ratio, ratarg );
+ result = multiply_ratio_ratio( frame_pointer, ratio, ratarg );
dec_ref( one );
dec_ref( ratio );
} else {
result =
throw_exception( c_string_to_lisp_string
- ( "Shouldn't happen: bad arg to multiply_integer_ratio" ),
- frame_pointer );
+ ( "Shouldn't happen: bad arg to multiply_integer_ratio" ),
+ frame_pointer );
}
return result;
@@ -302,7 +303,7 @@ struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 ) {
struct cons_pointer i = inverse( frame_pointer, arg2 ),
- result = add_ratio_ratio( frame_pointer, arg1, i );
+ result = add_ratio_ratio( frame_pointer, arg1, i );
dec_ref( i );
@@ -328,8 +329,8 @@ struct cons_pointer make_ratio( struct cons_pointer frame_pointer,
} else {
result =
throw_exception( c_string_to_lisp_string
- ( "Dividend and divisor of a ratio must be integers" ),
- frame_pointer );
+ ( "Dividend and divisor of a ratio must be integers" ),
+ frame_pointer );
}
#ifdef DEBUG
dump_object( stderr, result );
diff --git a/src/arith/ratio.h b/src/arith/ratio.h
index feb8925..5a3b0d6 100644
--- a/src/arith/ratio.h
+++ b/src/arith/ratio.h
@@ -14,15 +14,15 @@
struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg );
-struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
+struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 );
-struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer,
+struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer,
struct cons_pointer intarg,
struct cons_pointer ratarg );
-struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer,
+struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 );
@@ -30,11 +30,11 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str
cons_pointer arg1, struct
cons_pointer arg2 );
-struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer,
+struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer,
struct cons_pointer intarg,
struct cons_pointer ratarg );
-struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer,
+struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 );
diff --git a/src/arith/real.c b/src/arith/real.c
index a499b6a..d3786dd 100644
--- a/src/arith/real.c
+++ b/src/arith/real.c
@@ -9,6 +9,7 @@
#include "conspage.h"
#include "consspaceobject.h"
+#include "dump.h"
#include "read.h"
/**
diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c
index 75a5257..acca2a8 100644
--- a/src/memory/consspaceobject.c
+++ b/src/memory/consspaceobject.c
@@ -89,21 +89,21 @@ struct cons_pointer make_cons( struct cons_pointer car,
* @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 frame_pointer ) {
- struct cons_pointer result = NIL;
- struct cons_pointer pointer = allocate_cell( EXCEPTIONTAG );
- struct cons_space_object *cell = &pointer2cell( pointer );
+ struct cons_pointer frame_pointer ) {
+ struct cons_pointer result = NIL;
+ struct cons_pointer pointer = allocate_cell( EXCEPTIONTAG );
+ struct cons_space_object *cell = &pointer2cell( pointer );
- inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */
+ inc_ref( 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( frame_pointer);
- cell->payload.exception.message = message;
- cell->payload.exception.frame = frame_pointer;
+ inc_ref( message );
+ inc_ref( frame_pointer );
+ cell->payload.exception.message = message;
+ cell->payload.exception.frame = frame_pointer;
- result = pointer;
+ result = pointer;
- return result;
+ return result;
}
@@ -113,7 +113,7 @@ struct cons_pointer make_exception( struct cons_pointer message,
struct cons_pointer
make_function( struct cons_pointer src, struct cons_pointer ( *executable )
( struct stack_frame *,
- struct cons_pointer, struct cons_pointer ) ) {
+ struct cons_pointer, struct cons_pointer ) ) {
struct cons_pointer pointer = allocate_cell( FUNCTIONTAG );
struct cons_space_object *cell = &pointer2cell( pointer );
@@ -212,7 +212,7 @@ struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) {
struct cons_pointer
make_special( struct cons_pointer src, struct cons_pointer ( *executable )
( struct stack_frame * frame,
- struct cons_pointer, struct cons_pointer env ) ) {
+ struct cons_pointer, struct cons_pointer env ) ) {
struct cons_pointer pointer = allocate_cell( SPECIALTAG );
struct cons_space_object *cell = &pointer2cell( pointer );
diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h
index b31a0bf..44b6a79 100644
--- a/src/memory/consspaceobject.h
+++ b/src/memory/consspaceobject.h
@@ -421,10 +421,10 @@ struct vectorp_payload {
* tag. */
uint32_t value; /* the tag considered as a number */
} tag;
- struct vector_space_object * address;
- /* the address of the actual vector space
- * object (TODO: will change when I actually
- * implement vector space) */
+ struct vector_space_object *address;
+ /* the address of the actual vector space
+ * object (TODO: will change when I actually
+ * implement vector space) */
};
/**
diff --git a/src/memory/dump.c b/src/memory/dump.c
index 5306801..5aaedfb 100644
--- a/src/memory/dump.c
+++ b/src/memory/dump.c
@@ -72,7 +72,7 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
break;
case EXCEPTIONTV:
fwprintf( output, L"\t\tException cell: " );
- dump_stack_trace( output, pointer);
+ dump_stack_trace( output, pointer );
break;
case FREETV:
fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n",
@@ -93,10 +93,10 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
case RATIOTV:
fwprintf( output,
L"\t\tRational cell: value %ld/%ld, count %u\n",
- pointer2cell( cell.payload.ratio.dividend ).payload.
- integer.value,
- pointer2cell( cell.payload.ratio.divisor ).payload.
- integer.value, cell.count );
+ pointer2cell( cell.payload.ratio.dividend ).
+ payload.integer.value,
+ pointer2cell( cell.payload.ratio.divisor ).
+ payload.integer.value, cell.count );
break;
case READTV:
fwprintf( output, L"\t\tInput stream\n" );
@@ -110,11 +110,12 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
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;
+ 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;
}
}
diff --git a/src/memory/stack.c b/src/memory/stack.c
index 8fe268e..9f0f6f8 100644
--- a/src/memory/stack.c
+++ b/src/memory/stack.c
@@ -28,17 +28,26 @@
* get the actual stackframe object from this `pointer`, or NULL if
* `pointer` is not a stackframe pointer.
*/
-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;
+struct stack_frame *get_stack_frame( struct cons_pointer pointer ) {
+ struct stack_frame *result = NULL;
+ fputws
+ ( L"get_stack_frame: about to get a pointer to the vector space object\n",
+ stderr );
+ struct vector_space_object *vso =
+ pointer2cell( pointer ).payload.vectorp.address;
+ fputws( L"get_stack_frame: got a pointer, about to test it\n", stderr );
- if (vectorpointp(pointer) && stackframep(vso))
- {
- result = (struct stack_frame *) &(vso->payload);
- }
+ if ( vectorpointp( pointer ) ) { // && stackframep(vso)){
+ fputws( L"get_stack_frame: pointer is good, about to set the result\n",
+ stderr );
- return result;
+ result = ( struct stack_frame * ) &( vso->payload );
+ fputws( L"get_stack_frame: all good, returning\n", stderr );
+ } else {
+ fputws( L"get_stack_frame: fail, returning NULL\n", stderr );
+ }
+
+ return result;
}
/**
@@ -48,28 +57,38 @@ struct stack_frame * get_stack_frame(struct cons_pointer pointer) {
* @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
- */
+ fputws( L"Entering make_empty_frame\n", stderr );
+ struct cons_pointer result =
+ make_vso( STACKFRAMETAG, sizeof( struct stack_frame ) );
+ if ( !nilp( result ) ) {
+ fputws( L"make_empty_frame: about to call get_stack_frame\n", stderr );
+ 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);
+ fwprintf( stderr,
+ L"make_empty_frame: about to set previous to %4.4s\n",
+ pointer2cell( previous ).tag );
+ frame->previous = previous;
+ fputws( L"make_empty_frame: about to call inc_ref\n", stderr );
+ 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;
+ /*
+ * 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 );
+ fputws( L"make_empty_frame: about to initialise arg registers\n",
+ stderr );
+ for ( int i = 0; i < args_in_frame; i++ ) {
+ set_reg( frame, i, NIL );
+ }
}
- }
+ fputws( L"Leaving make_empty_frame\n", stderr );
return result;
}
@@ -83,67 +102,76 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
* @return the new frame, or an exception if one occurred while building it.
*/
struct cons_pointer make_stack_frame( struct cons_pointer previous,
- struct cons_pointer args,
- struct cons_pointer env ) {
- struct cons_pointer result = make_empty_frame( previous );
+ struct cons_pointer args,
+ struct cons_pointer env ) {
+ fputws( L"Entering make_stack_frame\n", stderr );
+ struct cons_pointer result = make_empty_frame( previous );
- 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);
+ 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
- * frame. When there are no more slots, if there are still args,
- * stash them on more */
- struct cons_space_object cell = pointer2cell( args );
+ 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
+ * frame. When there are no more slots, if there are still args,
+ * stash them on more */
+ struct cons_space_object cell = pointer2cell( args );
- /*
- * TODO: if we were running on real massively parallel hardware,
- * each arg except the first should be handed off to another
- * processor to be evaled in parallel; but see notes here:
- * https://github.com/simon-brooke/post-scarcity/wiki/parallelism
- */
- struct cons_pointer arg_frame_pointer = make_empty_frame( result);
- inc_ref(arg_frame_pointer);
+ /*
+ * TODO: if we were running on real massively parallel hardware,
+ * each arg except the first should be handed off to another
+ * processor to be evaled in parallel; but see notes here:
+ * https://github.com/simon-brooke/post-scarcity/wiki/parallelism
+ */
+ struct cons_pointer arg_frame_pointer = make_empty_frame( result );
+ inc_ref( arg_frame_pointer );
- if(nilp(arg_frame_pointer)) {
- result = make_exception(c_string_to_lisp_string( "Memory exhausted."), previous);
- break;
- } else {
- struct stack_frame *arg_frame = get_stack_frame( arg_frame_pointer );
- set_reg( arg_frame, 0, cell.payload.cons.car );
+ if ( nilp( arg_frame_pointer ) ) {
+ result =
+ make_exception( c_string_to_lisp_string
+ ( "Memory exhausted." ), previous );
+ break;
+ } else {
+ 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 );
+ 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 );
+ }
+
+ dec_ref( arg_frame_pointer );
+
+ args = cell.payload.cons.cdr;
+ }
}
-
- dec_ref(arg_frame_pointer);
-
- args = cell.payload.cons.cdr;
- }
- }
- if (!exceptionp(result)) {
- if ( consp( args ) ) {
- /* if we still have args, eval them and stick the values on `more` */
- struct cons_pointer more = eval_forms( get_stack_frame(previous), previous, args, env );
- frame->more = more;
- inc_ref( more );
- }
-
+ if ( !exceptionp( result ) ) {
+ if ( consp( args ) ) {
+ /* if we still have args, eval them and stick the values on `more` */
+ struct cons_pointer more =
+ eval_forms( get_stack_frame( previous ), previous, args,
+ env );
+ frame->more = more;
+ inc_ref( more );
+ }
#ifdef DEBUG
- dump_frame( stderr, result );
+ dump_frame( stderr, result );
#endif
+ }
}
- }
+ fputws( L"Leaving make_stack_frame\n", stderr );
- return result;
+ return result;
}
/**
@@ -157,36 +185,40 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
struct cons_pointer make_special_frame( struct cons_pointer previous,
struct cons_pointer args,
struct cons_pointer env ) {
- struct cons_pointer result = make_empty_frame( previous );
+ fputws( L"Entering make_special_frame\n", stderr );
- 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);
+ struct cons_pointer result = make_empty_frame( previous );
- 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
- * frame. When there are no more slots, if there are still args,
- * stash them on more */
- struct cons_space_object cell = pointer2cell( args );
+ 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 );
- set_reg( frame, frame->args, cell.payload.cons.car );
+ 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
+ * frame. When there are no more slots, if there are still args,
+ * stash them on more */
+ struct cons_space_object cell = pointer2cell( args );
- args = cell.payload.cons.cdr;
- }
- if (!exceptionp(result)) {
- if ( consp( args ) ) {
- frame->more = args;
- inc_ref( args );
- }
+ set_reg( frame, frame->args, cell.payload.cons.car );
+ args = cell.payload.cons.cdr;
+ }
+ if ( !exceptionp( result ) ) {
+ if ( consp( args ) ) {
+ frame->more = args;
+ inc_ref( args );
+ }
#ifdef DEBUG
- dump_frame( stderr, result );
+ dump_frame( stderr, result );
#endif
+ }
}
- }
+ fputws( L"Leaving make_special_frame\n", stderr );
return result;
}
@@ -215,37 +247,39 @@ void free_stack_frame( struct stack_frame *frame ) {
* @param frame_pointer the pointer to the frame
*/
void dump_frame( FILE * output, struct cons_pointer frame_pointer ) {
- struct stack_frame *frame = get_stack_frame(frame_pointer);
+ struct stack_frame *frame = get_stack_frame( frame_pointer );
- if (frame != NULL) {
- for ( int arg = 0; arg < frame->args; arg++ ) {
- struct cons_space_object cell = pointer2cell( frame->arg[arg] );
+ if ( frame != NULL ) {
+ for ( int arg = 0; arg < frame->args; arg++ ) {
+ struct cons_space_object cell = pointer2cell( frame->arg[arg] );
- fwprintf( output, L"Arg %d:\t%c%c%c%c\tcount: %10u\tvalue: ", arg,
- cell.tag.bytes[0],
- cell.tag.bytes[1], cell.tag.bytes[2], cell.tag.bytes[3],
- cell.count );
+ fwprintf( output, L"Arg %d:\t%c%c%c%c\tcount: %10u\tvalue: ", arg,
+ cell.tag.bytes[0],
+ cell.tag.bytes[1], cell.tag.bytes[2], cell.tag.bytes[3],
+ cell.count );
- print( output, frame->arg[arg] );
- fputws( L"\n", output );
+ print( output, frame->arg[arg] );
+ fputws( L"\n", output );
+ }
+ fputws( L"More: \t", output );
+ print( output, frame->more );
+ fputws( L"\n", output );
}
- fputws( L"More: \t", output );
- print( output, frame->more );
- 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;
+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;
+ }
}
- }
}
/**
diff --git a/src/memory/stack.h b/src/memory/stack.h
index df76849..20acd73 100644
--- a/src/memory/stack.h
+++ b/src/memory/stack.h
@@ -41,19 +41,19 @@
*/
#define set_reg(frame,register,value)frame->arg[register]=value; inc_ref(value)
-struct stack_frame * get_stack_frame(struct cons_pointer pointer);
+struct stack_frame *get_stack_frame( struct cons_pointer pointer );
struct cons_pointer make_empty_frame( struct cons_pointer previous );
struct cons_pointer make_stack_frame( struct cons_pointer previous,
- struct cons_pointer args,
- struct cons_pointer env );
+ struct cons_pointer args,
+ struct cons_pointer env );
void free_stack_frame( struct stack_frame *frame );
void dump_frame( FILE * output, struct cons_pointer pointer );
-void dump_stack_trace(FILE * output, struct cons_pointer frame_pointer);
+void dump_stack_trace( FILE * output, struct cons_pointer frame_pointer );
struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int n );
diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c
index c0b6f8d..db39b48 100644
--- a/src/memory/vectorspace.c
+++ b/src/memory/vectorspace.c
@@ -30,12 +30,19 @@
* NOTE that `tag` should be the vector-space tag of the particular type of
* vector-space object, NOT `VECTORPOINTTAG`.
*/
-struct cons_pointer make_vec_pointer( char * tag, struct vector_space_object * address ) {
+struct cons_pointer make_vec_pointer( char *tag,
+ struct vector_space_object *address ) {
+ fputws( L"Entered make_vec_pointer\n", stderr );
struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG );
struct cons_space_object cell = pointer2cell( pointer );
-
+ fwprintf( stderr,
+ L"make_vec_pointer: allocated cell, about to write tag '%s'\n",
+ tag );
strncpy( &cell.payload.vectorp.tag.bytes[0], tag, 4 );
+ fputws( L"make_vec_pointer: tag written, about to set pointer address\n",
+ stderr );
cell.payload.vectorp.address = address;
+ fputws( L"make_vec_pointer: all good, returning\n", stderr );
return pointer;
}
@@ -48,15 +55,18 @@ struct cons_pointer make_vec_pointer( char * tag, struct vector_space_object * a
* Returns NIL if the vector could not be allocated due to memory exhaustion.
*/
struct cons_pointer make_vso( char *tag, uint64_t payload_size ) {
+ fputws( L"Entered make_vso\n", stderr );
struct cons_pointer result = NIL;
int64_t total_size = sizeof( struct vector_space_header ) + payload_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);
+ uint64_t padded = ceil( ( total_size * 8.0 ) / 8.0 );
+ fputws( L"make_vso: about to malloc\n", stderr );
struct vector_space_object *vso = malloc( padded );
if ( vso != NULL ) {
+ fwprintf( stderr, L"make_vso: about to write tag '%s'\n", tag );
strncpy( &vso->header.tag.bytes[0], tag, TAGLENGTH );
vso->header.vecp = make_vec_pointer( tag, vso );
vso->header.size = payload_size;
@@ -65,13 +75,15 @@ struct cons_pointer make_vso( char *tag, uint64_t payload_size ) {
fwprintf( stderr,
L"Allocated vector-space object of type %4.4s, total size %ld, payload size %ld\n",
tag, total_size, payload_size );
- if (padded != total_size){
- fwprintf(stderr, L"\t\tPadded from %d to %d\n",
- total_size, padded);
- }
+ if ( padded != total_size ) {
+ fwprintf( stderr, L"\t\tPadded from %d to %d\n",
+ total_size, padded );
+ }
#endif
result = vso->header.vecp;
}
+ fputws( L"make_vso: all good, returning\n", stderr );
+
return result;
}
diff --git a/src/memory/vectorspace.h b/src/memory/vectorspace.h
index 83fa74c..caec968 100644
--- a/src/memory/vectorspace.h
+++ b/src/memory/vectorspace.h
@@ -61,7 +61,7 @@ struct vector_space_header {
};
struct vector_space_object {
- struct vector_space_header header;
+ struct vector_space_header header;
char payload; /* we'll malloc `size` bytes for payload,
* `payload` is just the first of these.
* TODO: this is almost certainly not
diff --git a/src/ops/equal.c b/src/ops/equal.c
index ebb085e..0f0597c 100644
--- a/src/ops/equal.c
+++ b/src/ops/equal.c
@@ -80,8 +80,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
&& ( equal( cell_a->payload.string.cdr,
cell_b->payload.string.cdr )
|| ( end_of_string( cell_a->payload.string.cdr )
- && end_of_string( cell_b->payload.string.
- cdr ) ) );
+ && end_of_string( cell_b->payload.
+ string.cdr ) ) );
break;
case INTEGERTV:
result =
diff --git a/src/ops/lispops.c b/src/ops/lispops.c
index 825222f..1e6712d 100644
--- a/src/ops/lispops.c
+++ b/src/ops/lispops.c
@@ -89,9 +89,9 @@ struct cons_pointer eval_form( struct stack_frame *parent,
struct cons_pointer result = NIL;
struct cons_pointer next_pointer = make_empty_frame( parent_pointer );
- inc_ref( next_pointer);
+ inc_ref( next_pointer );
- struct stack_frame * next = get_stack_frame(next_pointer);
+ struct stack_frame *next = get_stack_frame( next_pointer );
set_reg( next, 0, form );
result = lisp_eval( next, next_pointer, env );
@@ -100,7 +100,7 @@ struct cons_pointer eval_form( struct stack_frame *parent,
/* 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. */
- dec_ref(next_pointer);
+ dec_ref( next_pointer );
}
return result;
@@ -111,13 +111,15 @@ struct cons_pointer eval_form( struct stack_frame *parent,
* and this `env`, and return a list of their values. If the arg passed as
* `list` is not in fact a list, return nil.
*/
-struct cons_pointer eval_forms( struct stack_frame *frame, struct cons_pointer frame_pointer,
+struct cons_pointer eval_forms( struct stack_frame *frame,
+ struct cons_pointer frame_pointer,
struct cons_pointer list,
struct cons_pointer env ) {
- /* TODO: refactor. This runs up the C stack. */
+ /* TODO: refactor. This runs up the C stack. */
return consp( list ) ?
make_cons( eval_form( frame, frame_pointer, c_car( list ), env ),
- eval_forms( frame, frame_pointer, c_cdr( list ), env ) ) : NIL;
+ eval_forms( frame, frame_pointer, c_cdr( list ),
+ env ) ) : NIL;
}
/**
@@ -126,7 +128,8 @@ struct cons_pointer eval_forms( struct stack_frame *frame, struct cons_pointer f
* (oblist)
*/
struct cons_pointer
-lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) {
+lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer,
+ struct cons_pointer env ) {
return oblist;
}
@@ -159,7 +162,8 @@ struct cons_pointer compose_body( struct stack_frame *frame ) {
* @param env the environment in which it is to be intepreted.
*/
struct cons_pointer
-lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer, 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 ) );
}
@@ -170,7 +174,8 @@ lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer, struc
* @param env the environment in which it is to be intepreted.
*/
struct cons_pointer
-lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer, 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 ) );
}
@@ -188,8 +193,8 @@ void log_binding( struct cons_pointer name, struct cons_pointer val ) {
* Evaluate a lambda or nlambda expression.
*/
struct cons_pointer
-eval_lambda( struct cons_space_object cell, struct stack_frame *frame, struct cons_pointer frame_pointer,
- struct cons_pointer env ) {
+eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
+ struct cons_pointer frame_pointer, struct cons_pointer env ) {
struct cons_pointer result = NIL;
fwprintf( stderr, L"eval_lambda called\n" );
@@ -216,7 +221,8 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, struct co
struct cons_pointer vals = frame->more;
for ( int i = args_in_frame - 1; i >= 0; i-- ) {
- struct cons_pointer val = eval_form( frame, frame_pointer, frame->arg[i], env );
+ struct cons_pointer val =
+ eval_form( frame, frame_pointer, frame->arg[i], env );
if ( nilp( val ) && nilp( vals ) ) { /* nothing */
} else {
@@ -248,23 +254,25 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, struct co
* @return the result of evaluating the function with its arguments.
*/
struct cons_pointer
-c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) {
+c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
+ struct cons_pointer env ) {
struct cons_pointer result = NIL;
- /* construct a child frame and within it evaluate the first argument - the
- * argument in the function position. */
+ /* 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);
+ 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] ) );
- struct cons_pointer fn_pointer = lisp_eval( fn_frame, fn_frame_pointer, env );
+ struct cons_pointer fn_pointer =
+ lisp_eval( fn_frame, fn_frame_pointer, 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. */
- dec_ref(fn_frame_pointer);
+ dec_ref( fn_frame_pointer );
}
struct cons_space_object fn_cell = pointer2cell( fn_pointer );
@@ -280,14 +288,17 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct co
struct cons_pointer exep = NIL;
struct cons_pointer next_pointer =
make_stack_frame( frame_pointer, args, env );
- inc_ref(next_pointer);
+ inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) {
result = next_pointer;
} else {
- struct stack_frame *next = get_stack_frame(next_pointer);
+ struct stack_frame *next = get_stack_frame( next_pointer );
- result = ( *fn_cell.payload.function.executable ) ( next, next_pointer, env );
- dec_ref(next_pointer);
+ result =
+ ( *fn_cell.payload.function.executable ) ( next,
+ next_pointer,
+ env );
+ dec_ref( next_pointer );
}
}
break;
@@ -296,48 +307,53 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct co
struct cons_pointer exep = NIL;
struct cons_pointer next_pointer =
make_stack_frame( frame_pointer, args, env );
- inc_ref(next_pointer);
- if ( exceptionp( next_pointer ) ) {
+ inc_ref( next_pointer );
+ if ( exceptionp( next_pointer ) ) {
result = next_pointer;
} else {
- 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);
+ 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;
case NLAMBDATV:
{
struct cons_pointer next_pointer =
- make_special_frame( frame_pointer, args, env );
- inc_ref(next_pointer);
- if ( exceptionp( next_pointer ) ) {
+ make_special_frame( frame_pointer, args, env );
+ inc_ref( next_pointer );
+ if ( exceptionp( next_pointer ) ) {
result = next_pointer;
} else {
- struct stack_frame *next = get_stack_frame(frame_pointer);
- result = eval_lambda( fn_cell, next, next_pointer, env );
- if ( !exceptionp( result ) ) {
- dec_ref(next_pointer);
+ struct stack_frame *next =
+ get_stack_frame( frame_pointer );
+ result = eval_lambda( fn_cell, next, next_pointer, env );
+ if ( !exceptionp( result ) ) {
+ dec_ref( next_pointer );
+ }
}
- }
}
break;
case SPECIALTV:
{
struct cons_pointer next_pointer =
- make_special_frame( frame_pointer, args, env );
- inc_ref(next_pointer);
- if ( exceptionp( next_pointer ) ) {
+ make_special_frame( frame_pointer, args, 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 ) ) {
- dec_ref(next_pointer);
+ struct stack_frame *next =
+ get_stack_frame( frame_pointer );
+ result =
+ ( *fn_cell.payload.special.executable ) ( next,
+ next_pointer,
+ env );
+ if ( !exceptionp( result ) ) {
+ dec_ref( next_pointer );
+ }
}
- }
}
break;
default:
@@ -355,7 +371,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct co
result = throw_exception( message, frame_pointer );
}
}
- dec_ref(fn_frame_pointer);
+ dec_ref( fn_frame_pointer );
return result;
}
@@ -393,7 +409,8 @@ 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.
*/
struct cons_pointer
-lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, 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_space_object cell = pointer2cell( frame->arg[0] );
@@ -456,7 +473,8 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
* the second argument
*/
struct cons_pointer
-lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) {
+lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
+ struct cons_pointer env ) {
#ifdef DEBUG
fputws( L"Apply: ", stderr );
dump_frame( stderr, frame_pointer );
@@ -484,7 +502,8 @@ lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
* this isn't at this stage checked) unevaluated.
*/
struct cons_pointer
-lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) {
+lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer,
+ struct cons_pointer env ) {
return frame->arg[0];
}
@@ -499,7 +518,8 @@ lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
* the namespace in so doing. `namespace` defaults to the value of `oblist`.
*/
struct cons_pointer
-lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, 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 namespace =
nilp( frame->arg[2] ) ? oblist : frame->arg[2];
@@ -512,7 +532,8 @@ lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, struct c
make_exception( make_cons
( c_string_to_lisp_string
( "The first argument to `set!` is not a symbol: " ),
- make_cons( frame->arg[0], NIL ) ), frame_pointer );
+ make_cons( frame->arg[0], NIL ) ),
+ frame_pointer );
}
return result;
@@ -529,13 +550,15 @@ lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, struct c
* the namespace in so doing. `namespace` defaults to the value of `oblist`.
*/
struct cons_pointer
-lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, 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 namespace =
nilp( frame->arg[2] ) ? oblist : frame->arg[2];
if ( symbolp( frame->arg[0] ) ) {
- struct cons_pointer val = eval_form( frame, frame_pointer, frame->arg[1], env );
+ struct cons_pointer val =
+ eval_form( frame, frame_pointer, frame->arg[1], env );
deep_bind( frame->arg[0], val );
result = val;
} else {
@@ -543,7 +566,8 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, s
make_exception( make_cons
( c_string_to_lisp_string
( "The first argument to `set!` is not a symbol: " ),
- make_cons( frame->arg[0], NIL ) ), frame_pointer );
+ make_cons( frame->arg[0], NIL ) ),
+ frame_pointer );
}
return result;
@@ -558,7 +582,8 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, s
* otherwise returns a new cons cell.
*/
struct cons_pointer
-lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, 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 cdr = frame->arg[1];
struct cons_pointer result;
@@ -582,7 +607,8 @@ lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
* strings, and TODO read streams and other things which can be considered as sequences.
*/
struct cons_pointer
-lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) {
+lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer,
+ struct cons_pointer env ) {
struct cons_pointer result = NIL;
if ( consp( frame->arg[0] ) ) {
@@ -606,7 +632,8 @@ lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, struct c
* strings, and TODO read streams and other things which can be considered as sequences.
*/
struct cons_pointer
-lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) {
+lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer,
+ struct cons_pointer env ) {
struct cons_pointer result = NIL;
if ( consp( frame->arg[0] ) ) {
@@ -629,7 +656,8 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, struct c
* Returns the value associated with key in store, or NIL if not found.
*/
struct cons_pointer
-lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer, 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] );
}
@@ -637,7 +665,8 @@ lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
* (eq a b)
* 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 frame_pointer,
+struct cons_pointer lisp_eq( struct stack_frame *frame,
+ struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return eq( frame->arg[0], frame->arg[1] ) ? TRUE : NIL;
}
@@ -647,7 +676,8 @@ struct cons_pointer lisp_eq( struct stack_frame *frame, struct cons_pointer fram
* Returns T if a and b are pointers to structurally identical objects, else NIL
*/
struct cons_pointer
-lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, 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;
}
@@ -658,7 +688,8 @@ lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
* is a read stream, then read from that stream, else stdin.
*/
struct cons_pointer
-lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) {
+lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer,
+ struct cons_pointer env ) {
FILE *input = stdin;
if ( readp( frame->arg[0] ) ) {
@@ -698,7 +729,8 @@ struct cons_pointer c_reverse( struct cons_pointer arg ) {
* (reverse sequence)
* 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 frame_pointer,
+struct cons_pointer lisp_reverse( struct stack_frame *frame,
+ struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return c_reverse( frame->arg[0] );
}
@@ -711,9 +743,10 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer
* is a write stream, then print to that stream, else stdout.
*/
struct cons_pointer
-lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, 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);
+ fputws( L"Entering print\n", stderr );
#endif
struct cons_pointer result = NIL;
FILE *output = stdout;
@@ -741,7 +774,8 @@ lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
* @return As a Lisp string, the tag of the object which is the argument.
*/
struct cons_pointer
-lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, 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] );
}
@@ -759,7 +793,8 @@ lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
* argument.
*/
struct cons_pointer
-lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, 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 result = NIL;
@@ -786,7 +821,8 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
* @return the value of the last form of the first successful clause.
*/
struct cons_pointer
-lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) {
+lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer,
+ struct cons_pointer env ) {
struct cons_pointer result = NIL;
bool done = false;
@@ -797,11 +833,14 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
if ( consp( clause_pointer ) ) {
struct cons_space_object cell = pointer2cell( clause_pointer );
- result = eval_form( frame, frame_pointer, c_car( clause_pointer ), env );
+ result =
+ eval_form( frame, frame_pointer, c_car( clause_pointer ),
+ env );
if ( !nilp( result ) ) {
struct cons_pointer vals =
- eval_forms( frame, frame_pointer,c_cdr( clause_pointer ), env );
+ eval_forms( frame, frame_pointer, c_cdr( clause_pointer ),
+ env );
while ( consp( vals ) ) {
result = c_car( vals );
@@ -814,8 +853,8 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
done = true;
} else {
result = throw_exception( c_string_to_lisp_string
- ( "Arguments to `cond` must be lists" ),
- frame_pointer);
+ ( "Arguments to `cond` must be lists" ),
+ frame_pointer );
}
}
/* TODO: if there are more than 8 clauses we need to continue into the
@@ -835,7 +874,8 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
* pointer to the frame in which the exception occurred.
*/
struct cons_pointer
-throw_exception( struct cons_pointer message, struct cons_pointer frame_pointer ) {
+throw_exception( struct cons_pointer message,
+ struct cons_pointer frame_pointer ) {
fwprintf( stderr, L"\nERROR: " );
print( stderr, message );
struct cons_pointer result = NIL;
@@ -861,7 +901,9 @@ throw_exception( struct cons_pointer message, struct cons_pointer frame_pointer
* 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);
+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 );
}
diff --git a/src/ops/lispops.h b/src/ops/lispops.h
index 059255d..a1dee81 100644
--- a/src/ops/lispops.h
+++ b/src/ops/lispops.h
@@ -60,7 +60,8 @@ struct cons_pointer eval_form( struct stack_frame *parent,
* and this `env`, and return a list of their values. If the arg passed as
* `list` is not in fact a list, return nil.
*/
-struct cons_pointer eval_forms( struct stack_frame *frame, struct cons_pointer frame_pointer,
+struct cons_pointer eval_forms( struct stack_frame *frame,
+ struct cons_pointer frame_pointer,
struct cons_pointer list,
struct cons_pointer env );
@@ -68,19 +69,24 @@ struct cons_pointer eval_forms( struct stack_frame *frame, struct cons_pointer f
/*
* special forms
*/
-struct cons_pointer lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
+struct cons_pointer lisp_eval( struct stack_frame *frame,
+ struct cons_pointer frame_pointer,
struct cons_pointer env );
-struct cons_pointer lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
+struct cons_pointer lisp_apply( struct stack_frame *frame,
+ struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer
-lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env );
+lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer,
+ struct cons_pointer env );
struct cons_pointer
-lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env );
+lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer,
+ struct cons_pointer env );
struct cons_pointer
-lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env );
+lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer,
+ struct cons_pointer env );
/**
* Construct an interpretable function.
@@ -89,7 +95,8 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, s
* @param lexpr the lambda expression to be interpreted;
* @param env the environment in which it is to be intepreted.
*/
-struct cons_pointer lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer,
+struct cons_pointer lisp_lambda( struct stack_frame *frame,
+ struct cons_pointer frame_pointer,
struct cons_pointer env );
/**
@@ -99,31 +106,42 @@ struct cons_pointer lisp_lambda( struct stack_frame *frame, struct cons_pointer
* @param env the environment in which it is to be intepreted.
*/
struct cons_pointer
-lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer, 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 frame_pointer,
+struct cons_pointer lisp_quote( struct stack_frame *frame,
+ struct cons_pointer frame_pointer,
struct cons_pointer env );
/*
* functions
*/
-struct cons_pointer lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer,
+struct cons_pointer lisp_cons( struct stack_frame *frame,
+ struct cons_pointer frame_pointer,
struct cons_pointer env );
-struct cons_pointer lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer,
+struct cons_pointer lisp_car( struct stack_frame *frame,
+ struct cons_pointer frame_pointer,
struct cons_pointer env );
-struct cons_pointer lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer,
+struct cons_pointer lisp_cdr( struct stack_frame *frame,
+ struct cons_pointer frame_pointer,
struct cons_pointer env );
-struct cons_pointer lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer,
+struct cons_pointer lisp_assoc( struct stack_frame *frame,
+ struct cons_pointer frame_pointer,
struct cons_pointer env );
-struct cons_pointer lisp_eq( struct stack_frame *frame, struct cons_pointer frame_pointer,
+struct cons_pointer lisp_eq( struct stack_frame *frame,
+ struct cons_pointer frame_pointer,
struct cons_pointer env );
-struct cons_pointer lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer,
+struct cons_pointer lisp_equal( struct stack_frame *frame,
+ struct cons_pointer frame_pointer,
struct cons_pointer env );
-struct cons_pointer lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer,
+struct cons_pointer lisp_print( struct stack_frame *frame,
+ struct cons_pointer frame_pointer,
struct cons_pointer env );
-struct cons_pointer lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer,
+struct cons_pointer lisp_read( struct stack_frame *frame,
+ struct cons_pointer frame_pointer,
struct cons_pointer env );
-struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer frame_pointer,
+struct cons_pointer lisp_reverse( struct stack_frame *frame,
+ struct cons_pointer frame_pointer,
struct cons_pointer env );
/**
* Function: Get the Lisp type of the single argument.
@@ -132,7 +150,8 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer
* @return As a Lisp string, the tag of the object which is the argument.
*/
struct cons_pointer
-lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env );
+lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer,
+ struct cons_pointer env );
/**
@@ -146,7 +165,8 @@ lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
* argument.
*/
struct cons_pointer
-lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, 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
@@ -158,7 +178,8 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
* @return the value of the last form of the first successful clause.
*/
struct cons_pointer
-lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env );
+lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer,
+ struct cons_pointer env );
/**
* Throw an exception.
@@ -167,7 +188,8 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, struct
* real `throw_exception`, which does, will be needed.
*/
struct cons_pointer throw_exception( struct cons_pointer message,
- struct cons_pointer frame_pointer );
+ struct cons_pointer frame_pointer );
struct cons_pointer
-lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env );
+lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer,
+ struct cons_pointer env );
diff --git a/src/ops/print.c b/src/ops/print.c
index 7efd59f..99cd7f3 100644
--- a/src/ops/print.c
+++ b/src/ops/print.c
@@ -119,7 +119,7 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
case EXCEPTIONTV:
fwprintf( output, L"\n%sException: ",
print_use_colours ? "\x1B[31m" : "" );
- dump_stack_trace(output, pointer);
+ dump_stack_trace( output, pointer );
break;
case FUNCTIONTV:
fwprintf( output, L"(Function)" );
@@ -133,8 +133,8 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
case LAMBDATV:
print( output, make_cons( c_string_to_lisp_symbol( "lambda" ),
make_cons( cell.payload.lambda.args,
- cell.payload.
- lambda.body ) ) );
+ cell.payload.lambda.
+ body ) ) );
break;
case NILTV:
fwprintf( output, L"nil" );
@@ -142,8 +142,8 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
case NLAMBDATV:
print( output, make_cons( c_string_to_lisp_symbol( "nlambda" ),
make_cons( cell.payload.lambda.args,
- cell.payload.
- lambda.body ) ) );
+ cell.payload.lambda.
+ body ) ) );
break;
case RATIOTV:
print( output, cell.payload.ratio.dividend );
diff --git a/src/ops/read.c b/src/ops/read.c
index 1a09700..7d21dbe 100644
--- a/src/ops/read.c
+++ b/src/ops/read.c
@@ -34,10 +34,11 @@
*/
struct cons_pointer read_number( struct stack_frame *frame,
- struct cons_pointer frame_pointer, FILE * input,
- wint_t initial, bool seen_period );
+ struct cons_pointer frame_pointer,
+ FILE * input, wint_t initial,
+ bool seen_period );
struct cons_pointer read_list( struct stack_frame *frame,
- struct cons_pointer frame_pointer, FILE * input,
+ struct cons_pointer frame_pointer, 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 );
@@ -55,8 +56,9 @@ struct cons_pointer c_quote( struct cons_pointer arg ) {
* treating this initial character as the first character of the object
* representation.
*/
-struct cons_pointer read_continuation( struct stack_frame *frame, struct cons_pointer frame_pointer, FILE * input,
- wint_t initial ) {
+struct cons_pointer read_continuation( struct stack_frame *frame,
+ struct cons_pointer frame_pointer,
+ FILE * input, wint_t initial ) {
struct cons_pointer result = NIL;
wint_t c;
@@ -76,15 +78,18 @@ struct cons_pointer read_continuation( struct stack_frame *frame, struct cons_po
break;
case EOF:
result = throw_exception( c_string_to_lisp_string
- ( "End of input while reading" ), frame_pointer );
+ ( "End of input while reading" ),
+ frame_pointer );
break;
case '\'':
result =
c_quote( read_continuation
- ( frame, frame_pointer, input, fgetwc( input ) ) );
+ ( frame, frame_pointer, input,
+ fgetwc( input ) ) );
break;
case '(':
- result = read_list( frame, frame_pointer, input, fgetwc( input ) );
+ result =
+ read_list( frame, frame_pointer, input, fgetwc( input ) );
break;
case '"':
result = read_string( input, fgetwc( input ) );
@@ -93,7 +98,9 @@ struct cons_pointer read_continuation( struct stack_frame *frame, struct cons_po
wint_t next = fgetwc( input );
ungetwc( next, input );
if ( iswdigit( next ) ) {
- result = read_number( frame, frame_pointer, input, c, false );
+ result =
+ read_number( frame, frame_pointer, input, c,
+ false );
} else {
result = read_symbol( input, c );
}
@@ -104,12 +111,15 @@ struct cons_pointer read_continuation( struct stack_frame *frame, struct cons_po
wint_t next = fgetwc( input );
if ( iswdigit( next ) ) {
ungetwc( next, input );
- result = read_number( frame, frame_pointer, input, c, true );
+ result =
+ read_number( frame, frame_pointer, input, c,
+ true );
} else if ( iswblank( next ) ) {
/* dotted pair. TODO: this isn't right, we
* really need to backtrack up a level. */
result =
- read_continuation( frame, frame_pointer, input, fgetwc( input ) );
+ read_continuation( frame, frame_pointer, input,
+ fgetwc( input ) );
} else {
read_symbol( input, c );
}
@@ -117,7 +127,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame, struct cons_po
break;
default:
if ( iswdigit( c ) ) {
- result = read_number( frame, frame_pointer, input, c, false );
+ result =
+ read_number( frame, frame_pointer, input, c, false );
} else if ( iswprint( c ) ) {
result = read_symbol( input, c );
} else {
@@ -140,8 +151,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame, struct cons_po
* input stream into a Lisp string, and then convert it to a number.
*/
struct cons_pointer read_number( struct stack_frame *frame,
- struct cons_pointer frame_pointer,
- FILE * input,
+ struct cons_pointer frame_pointer,
+ FILE * input,
wint_t initial, bool seen_period ) {
struct cons_pointer result = NIL;
int64_t accumulator = 0;
@@ -222,17 +233,21 @@ struct cons_pointer read_number( struct stack_frame *frame,
* left parenthesis.
*/
struct cons_pointer read_list( struct stack_frame *frame,
- struct cons_pointer frame_pointer,
- FILE * input, wint_t initial ) {
+ struct cons_pointer frame_pointer,
+ FILE * input, wint_t initial ) {
struct cons_pointer result = NIL;
if ( initial != ')' ) {
#ifdef DEBUG
fwprintf( stderr,
L"read_list starting '%C' (%d)\n", initial, initial );
#endif
- struct cons_pointer car = read_continuation( frame, frame_pointer, input,
- initial );
- result = make_cons( car, read_list( frame, frame_pointer, input, fgetwc( input ) ) );
+ struct cons_pointer car =
+ read_continuation( frame, frame_pointer, input,
+ initial );
+ result =
+ make_cons( car,
+ read_list( frame, frame_pointer, input,
+ fgetwc( input ) ) );
}
#ifdef DEBUG
else {
@@ -323,6 +338,7 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
*/
struct cons_pointer read( struct
stack_frame
- *frame, struct cons_pointer frame_pointer, FILE * input ) {
+ *frame, struct cons_pointer frame_pointer,
+ FILE * input ) {
return read_continuation( frame, frame_pointer, input, fgetwc( input ) );
}
diff --git a/src/ops/read.h b/src/ops/read.h
index c144699..c6dbba3 100644
--- a/src/ops/read.h
+++ b/src/ops/read.h
@@ -15,7 +15,6 @@
* read the next object on this input stream and return a cons_pointer to it.
*/
struct cons_pointer read( struct stack_frame *frame,
- struct cons_pointer frame_pointer,
- FILE * input );
+ struct cons_pointer frame_pointer, FILE * input );
#endif
diff --git a/src/repl.c b/src/repl.c
index 5dd6567..d077ba8 100644
--- a/src/repl.c
+++ b/src/repl.c
@@ -31,64 +31,65 @@
* Dummy up a Lisp read call with its own stack frame.
*/
struct cons_pointer repl_read( struct cons_pointer stream_pointer ) {
- 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);
+ 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){
+ if ( frame != NULL ) {
- set_reg( frame, 0, stream_pointer );
- struct cons_pointer result = lisp_read( frame, frame_pointer, oblist );
+ set_reg( frame, 0, stream_pointer );
+ struct cons_pointer result =
+ lisp_read( frame, frame_pointer, oblist );
+ }
+ dec_ref( frame_pointer );
}
- dec_ref(frame_pointer);
- }
- return result;
+ return result;
}
/**
* Dummy up a Lisp eval call with its own stack frame.
*/
struct cons_pointer repl_eval( struct cons_pointer input ) {
- 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);
+ 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 );
- result = lisp_eval( frame, frame_pointer, oblist );
+ if ( frame != NULL ) {
+ set_reg( frame, 0, input );
+ result = lisp_eval( frame, frame_pointer, oblist );
+ }
+
+ dec_ref( frame_pointer );
}
- dec_ref(frame_pointer);
- }
-
- return result;
+ return result;
}
/**
* Dummy up a Lisp print call with its own stack frame.
*/
struct cons_pointer repl_print( struct cons_pointer stream_pointer,
- struct cons_pointer value ) {
- 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);
+ struct cons_pointer value ) {
+ 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, 1, stream_pointer );
- result = lisp_print( frame, frame_pointer, oblist );
- free_stack_frame( frame );
+ if ( frame != NULL ) {
+ set_reg( frame, 0, value );
+ set_reg( frame, 1, stream_pointer );
+ result = lisp_print( frame, frame_pointer, oblist );
+ free_stack_frame( frame );
+ }
+ dec_ref( frame_pointer );
}
- dec_ref(frame_pointer);
- }
- return result;
+ return result;
}
/**
From 75abfb4050f7c6c74f7d913cc44a6b2f72d79758 Mon Sep 17 00:00:00 2001
From: Simon Brooke <simon@journeyman.cc>
Date: Thu, 27 Dec 2018 21:37:38 +0000
Subject: [PATCH 3/6] Much better debugging, but it still doesn't work
---
Doxyfile | 138 +++++++++++++++++------------------
Makefile | 2 +-
src/arith/integer.c | 5 +-
src/arith/peano.c | 45 +++++-------
src/arith/ratio.c | 7 +-
src/arith/real.c | 6 +-
src/debug.c | 65 +++++++++++++++++
src/debug.h | 28 +++++++
src/init.c | 22 +++++-
src/memory/conspage.c | 3 +-
src/memory/conspage.h | 4 +-
src/memory/consspaceobject.h | 11 +--
src/memory/cursor.c | 9 +++
src/memory/cursor.h | Bin 0 -> 614 bytes
src/memory/dump.c | 17 ++++-
src/memory/stack.c | 63 +++++++++-------
src/memory/stack.h | 4 +-
src/memory/vectorspace.c | 42 ++++++-----
src/memory/vectorspace.h | 2 +-
src/ops/intern.c | 31 +++++---
src/ops/lispops.c | 79 ++++++++++----------
src/ops/read.c | 26 +++----
src/repl.c | 19 ++++-
23 files changed, 395 insertions(+), 233 deletions(-)
create mode 100644 src/debug.c
create mode 100644 src/debug.h
create mode 100644 src/memory/cursor.c
create mode 100644 src/memory/cursor.h
diff --git a/Doxyfile b/Doxyfile
index b94ec20..955cb32 100644
--- a/Doxyfile
+++ b/Doxyfile
@@ -32,13 +32,13 @@ DOXYFILE_ENCODING = UTF-8
# title of most generated pages and in a few other places.
# The default value is: My Project.
-PROJECT_NAME = "\"Post Scarcity\""
+PROJECT_NAME = "Post Scarcity"
# The PROJECT_NUMBER tag can be used to enter a project or revision number. This
# could be handy for archiving the generated documentation or if some version
# control system is used.
-PROJECT_NUMBER =
+PROJECT_NUMBER =
# Using the PROJECT_BRIEF tag one can provide an optional one line description
# for a project that appears at the top of each page and should give viewer a
@@ -51,14 +51,14 @@ PROJECT_BRIEF = "A prototype for a post scarcity programming environmen
# pixels and the maximum width should not exceed 200 pixels. Doxygen will copy
# the logo to the output directory.
-PROJECT_LOGO =
+PROJECT_LOGO =
# The OUTPUT_DIRECTORY tag is used to specify the (relative or absolute) path
# into which the generated documentation will be written. If a relative path is
# entered, it will be relative to the location where doxygen was started. If
# left blank the current directory will be used.
-OUTPUT_DIRECTORY = /home/simon/workspace/post-scarcity/doc
+OUTPUT_DIRECTORY = doc
# If the CREATE_SUBDIRS tag is set to YES then doxygen will create 4096 sub-
# directories (in 2 levels) under the output directory of each output format and
@@ -162,7 +162,7 @@ FULL_PATH_NAMES = YES
# will be relative from the directory where doxygen is started.
# This tag requires that the tag FULL_PATH_NAMES is set to YES.
-STRIP_FROM_PATH =
+STRIP_FROM_PATH =
# The STRIP_FROM_INC_PATH tag can be used to strip a user-defined part of the
# path mentioned in the documentation of a class, which tells the reader which
@@ -171,7 +171,7 @@ STRIP_FROM_PATH =
# specify the list of include paths that are normally passed to the compiler
# using the -I flag.
-STRIP_FROM_INC_PATH =
+STRIP_FROM_INC_PATH =
# If the SHORT_NAMES tag is set to YES, doxygen will generate much shorter (but
# less readable) file names. This can be useful is your file systems doesn't
@@ -238,13 +238,13 @@ TAB_SIZE = 4
# "Side Effects:". You can put \n's in the value part of an alias to insert
# newlines.
-ALIASES =
+ALIASES =
# This tag can be used to specify a number of word-keyword mappings (TCL only).
# A mapping has the form "name=value". For example adding "class=itcl::class"
# will allow you to use the command class in the itcl::class meaning.
-TCL_SUBST =
+TCL_SUBST =
# Set the OPTIMIZE_OUTPUT_FOR_C tag to YES if your project consists of C sources
# only. Doxygen will then generate output that is more tailored for C. For
@@ -291,7 +291,7 @@ OPTIMIZE_OUTPUT_VHDL = NO
# Note that for custom extensions you also need to set FILE_PATTERNS otherwise
# the files are not read by doxygen.
-EXTENSION_MAPPING =
+EXTENSION_MAPPING =
# If the MARKDOWN_SUPPORT tag is enabled then doxygen pre-processes all comments
# according to the Markdown format, which allows for more readable
@@ -648,7 +648,7 @@ GENERATE_DEPRECATEDLIST= YES
# sections, marked by \if <section_label> ... \endif and \cond <section_label>
# ... \endcond blocks.
-ENABLED_SECTIONS =
+ENABLED_SECTIONS =
# The MAX_INITIALIZER_LINES tag determines the maximum number of lines that the
# initial value of a variable or macro / define can have for it to appear in the
@@ -690,7 +690,7 @@ SHOW_NAMESPACES = YES
# by doxygen. Whatever the program writes to standard output is used as the file
# version. For an example see the documentation.
-FILE_VERSION_FILTER =
+FILE_VERSION_FILTER =
# The LAYOUT_FILE tag can be used to specify a layout file which will be parsed
# by doxygen. The layout file controls the global structure of the generated
@@ -703,7 +703,7 @@ FILE_VERSION_FILTER =
# DoxygenLayout.xml, doxygen will parse it automatically even if the LAYOUT_FILE
# tag is left empty.
-LAYOUT_FILE =
+LAYOUT_FILE =
# The CITE_BIB_FILES tag can be used to specify one or more bib files containing
# the reference definitions. This must be a list of .bib files. The .bib
@@ -713,7 +713,7 @@ LAYOUT_FILE =
# LATEX_BIB_STYLE. To use this feature you need bibtex and perl available in the
# search path. See also \cite for info how to create references.
-CITE_BIB_FILES =
+CITE_BIB_FILES =
#---------------------------------------------------------------------------
# Configuration options related to warning and progress messages
@@ -778,7 +778,7 @@ WARN_FORMAT = "$file:$line: $text"
# messages should be written. If left blank the output is written to standard
# error (stderr).
-WARN_LOGFILE =
+WARN_LOGFILE = doxy.log
#---------------------------------------------------------------------------
# Configuration options related to the input files
@@ -790,7 +790,7 @@ WARN_LOGFILE =
# spaces. See also FILE_PATTERNS and EXTENSION_MAPPING
# Note: If this tag is empty the current directory is searched.
-INPUT = /home/simon/workspace/post-scarcity/src
+INPUT = src src/arith src/memory src/ops
# This tag can be used to specify the character encoding of the source files
# that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses
@@ -873,7 +873,7 @@ RECURSIVE = NO
# Note that relative paths are relative to the directory from which doxygen is
# run.
-EXCLUDE =
+EXCLUDE =
# The EXCLUDE_SYMLINKS tag can be used to select whether or not files or
# directories that are symbolic links (a Unix file system feature) are excluded
@@ -889,7 +889,7 @@ EXCLUDE_SYMLINKS = NO
# Note that the wildcards are matched against the file with absolute path, so to
# exclude all test directories for example use the pattern */test/*
-EXCLUDE_PATTERNS =
+EXCLUDE_PATTERNS =
# The EXCLUDE_SYMBOLS tag can be used to specify one or more symbol names
# (namespaces, classes, functions, etc.) that should be excluded from the
@@ -900,13 +900,13 @@ EXCLUDE_PATTERNS =
# Note that the wildcards are matched against the file with absolute path, so to
# exclude all test directories use the pattern */test/*
-EXCLUDE_SYMBOLS =
+EXCLUDE_SYMBOLS =
# The EXAMPLE_PATH tag can be used to specify one or more files or directories
# that contain example code fragments that are included (see the \include
# command).
-EXAMPLE_PATH =
+EXAMPLE_PATH =
# If the value of the EXAMPLE_PATH tag contains directories, you can use the
# EXAMPLE_PATTERNS tag to specify one or more wildcard pattern (like *.cpp and
@@ -926,7 +926,7 @@ EXAMPLE_RECURSIVE = NO
# that contain images that are to be included in the documentation (see the
# \image command).
-IMAGE_PATH =
+IMAGE_PATH =
# The INPUT_FILTER tag can be used to specify a program that doxygen should
# invoke to filter for each input file. Doxygen will invoke the filter program
@@ -947,7 +947,7 @@ IMAGE_PATH =
# need to set EXTENSION_MAPPING for the extension otherwise the files are not
# properly processed by doxygen.
-INPUT_FILTER =
+INPUT_FILTER =
# The FILTER_PATTERNS tag can be used to specify filters on a per file pattern
# basis. Doxygen will compare the file name with each pattern and apply the
@@ -960,7 +960,7 @@ INPUT_FILTER =
# need to set EXTENSION_MAPPING for the extension otherwise the files are not
# properly processed by doxygen.
-FILTER_PATTERNS =
+FILTER_PATTERNS =
# If the FILTER_SOURCE_FILES tag is set to YES, the input filter (if set using
# INPUT_FILTER) will also be used to filter the input files that are used for
@@ -975,14 +975,14 @@ FILTER_SOURCE_FILES = NO
# *.ext= (so without naming a filter).
# This tag requires that the tag FILTER_SOURCE_FILES is set to YES.
-FILTER_SOURCE_PATTERNS =
+FILTER_SOURCE_PATTERNS =
# If the USE_MDFILE_AS_MAINPAGE tag refers to the name of a markdown file that
# is part of the input, its contents will be placed on the main page
# (index.html). This can be useful if you have a project on for instance GitHub
# and want to reuse the introduction page also for the doxygen output.
-USE_MDFILE_AS_MAINPAGE =
+USE_MDFILE_AS_MAINPAGE =
#---------------------------------------------------------------------------
# Configuration options related to source browsing
@@ -1087,7 +1087,7 @@ CLANG_ASSISTED_PARSING = NO
# specified with INPUT and INCLUDE_PATH.
# This tag requires that the tag CLANG_ASSISTED_PARSING is set to YES.
-CLANG_OPTIONS =
+CLANG_OPTIONS =
#---------------------------------------------------------------------------
# Configuration options related to the alphabetical class index
@@ -1113,7 +1113,7 @@ COLS_IN_ALPHA_INDEX = 5
# while generating the index headers.
# This tag requires that the tag ALPHABETICAL_INDEX is set to YES.
-IGNORE_PREFIX =
+IGNORE_PREFIX =
#---------------------------------------------------------------------------
# Configuration options related to the HTML output
@@ -1157,7 +1157,7 @@ HTML_FILE_EXTENSION = .html
# of the possible markers and block names see the documentation.
# This tag requires that the tag GENERATE_HTML is set to YES.
-HTML_HEADER =
+HTML_HEADER =
# The HTML_FOOTER tag can be used to specify a user-defined HTML footer for each
# generated HTML page. If the tag is left blank doxygen will generate a standard
@@ -1167,7 +1167,7 @@ HTML_HEADER =
# that doxygen normally uses.
# This tag requires that the tag GENERATE_HTML is set to YES.
-HTML_FOOTER =
+HTML_FOOTER =
# The HTML_STYLESHEET tag can be used to specify a user-defined cascading style
# sheet that is used by each HTML page. It can be used to fine-tune the look of
@@ -1179,7 +1179,7 @@ HTML_FOOTER =
# obsolete.
# This tag requires that the tag GENERATE_HTML is set to YES.
-HTML_STYLESHEET =
+HTML_STYLESHEET =
# The HTML_EXTRA_STYLESHEET tag can be used to specify additional user-defined
# cascading style sheets that are included after the standard style sheets
@@ -1192,7 +1192,7 @@ HTML_STYLESHEET =
# list). For an example see the documentation.
# This tag requires that the tag GENERATE_HTML is set to YES.
-HTML_EXTRA_STYLESHEET =
+HTML_EXTRA_STYLESHEET =
# The HTML_EXTRA_FILES tag can be used to specify one or more extra images or
# other source files which should be copied to the HTML output directory. Note
@@ -1202,7 +1202,7 @@ HTML_EXTRA_STYLESHEET =
# files will be copied as-is; there are no commands or markers available.
# This tag requires that the tag GENERATE_HTML is set to YES.
-HTML_EXTRA_FILES =
+HTML_EXTRA_FILES =
# The HTML_COLORSTYLE_HUE tag controls the color of the HTML output. Doxygen
# will adjust the colors in the style sheet and background images according to
@@ -1331,7 +1331,7 @@ GENERATE_HTMLHELP = NO
# written to the html output directory.
# This tag requires that the tag GENERATE_HTMLHELP is set to YES.
-CHM_FILE =
+CHM_FILE =
# The HHC_LOCATION tag can be used to specify the location (absolute path
# including file name) of the HTML help compiler (hhc.exe). If non-empty,
@@ -1339,7 +1339,7 @@ CHM_FILE =
# The file has to be specified with full path.
# This tag requires that the tag GENERATE_HTMLHELP is set to YES.
-HHC_LOCATION =
+HHC_LOCATION =
# The GENERATE_CHI flag controls if a separate .chi index file is generated
# (YES) or that it should be included in the master .chm file (NO).
@@ -1352,7 +1352,7 @@ GENERATE_CHI = NO
# and project file content.
# This tag requires that the tag GENERATE_HTMLHELP is set to YES.
-CHM_INDEX_ENCODING =
+CHM_INDEX_ENCODING =
# The BINARY_TOC flag controls whether a binary table of contents is generated
# (YES) or a normal table of contents (NO) in the .chm file. Furthermore it
@@ -1383,7 +1383,7 @@ GENERATE_QHP = NO
# the HTML output folder.
# This tag requires that the tag GENERATE_QHP is set to YES.
-QCH_FILE =
+QCH_FILE =
# The QHP_NAMESPACE tag specifies the namespace to use when generating Qt Help
# Project output. For more information please see Qt Help Project / Namespace
@@ -1408,7 +1408,7 @@ QHP_VIRTUAL_FOLDER = doc
# filters).
# This tag requires that the tag GENERATE_QHP is set to YES.
-QHP_CUST_FILTER_NAME =
+QHP_CUST_FILTER_NAME =
# The QHP_CUST_FILTER_ATTRS tag specifies the list of the attributes of the
# custom filter to add. For more information please see Qt Help Project / Custom
@@ -1416,21 +1416,21 @@ QHP_CUST_FILTER_NAME =
# filters).
# This tag requires that the tag GENERATE_QHP is set to YES.
-QHP_CUST_FILTER_ATTRS =
+QHP_CUST_FILTER_ATTRS =
# The QHP_SECT_FILTER_ATTRS tag specifies the list of the attributes this
# project's filter section matches. Qt Help Project / Filter Attributes (see:
# http://qt-project.org/doc/qt-4.8/qthelpproject.html#filter-attributes).
# This tag requires that the tag GENERATE_QHP is set to YES.
-QHP_SECT_FILTER_ATTRS =
+QHP_SECT_FILTER_ATTRS =
# The QHG_LOCATION tag can be used to specify the location of Qt's
# qhelpgenerator. If non-empty doxygen will try to run qhelpgenerator on the
# generated .qhp file.
# This tag requires that the tag GENERATE_QHP is set to YES.
-QHG_LOCATION =
+QHG_LOCATION =
# If the GENERATE_ECLIPSEHELP tag is set to YES, additional index files will be
# generated, together with the HTML files, they form an Eclipse help plugin. To
@@ -1563,7 +1563,7 @@ MATHJAX_RELPATH = http://cdn.mathjax.org/mathjax/latest
# MATHJAX_EXTENSIONS = TeX/AMSmath TeX/AMSsymbols
# This tag requires that the tag USE_MATHJAX is set to YES.
-MATHJAX_EXTENSIONS =
+MATHJAX_EXTENSIONS =
# The MATHJAX_CODEFILE tag can be used to specify a file with javascript pieces
# of code that will be used on startup of the MathJax code. See the MathJax site
@@ -1571,7 +1571,7 @@ MATHJAX_EXTENSIONS =
# example see the documentation.
# This tag requires that the tag USE_MATHJAX is set to YES.
-MATHJAX_CODEFILE =
+MATHJAX_CODEFILE =
# When the SEARCHENGINE tag is enabled doxygen will generate a search box for
# the HTML output. The underlying search engine uses javascript and DHTML and
@@ -1631,7 +1631,7 @@ EXTERNAL_SEARCH = NO
# Searching" for details.
# This tag requires that the tag SEARCHENGINE is set to YES.
-SEARCHENGINE_URL =
+SEARCHENGINE_URL =
# When SERVER_BASED_SEARCH and EXTERNAL_SEARCH are both enabled the unindexed
# search data is written to a file for indexing by an external tool. With the
@@ -1647,7 +1647,7 @@ SEARCHDATA_FILE = searchdata.xml
# projects and redirect the results back to the right project.
# This tag requires that the tag SEARCHENGINE is set to YES.
-EXTERNAL_SEARCH_ID =
+EXTERNAL_SEARCH_ID =
# The EXTRA_SEARCH_MAPPINGS tag can be used to enable searching through doxygen
# projects other than the one defined by this configuration file, but that are
@@ -1657,7 +1657,7 @@ EXTERNAL_SEARCH_ID =
# EXTRA_SEARCH_MAPPINGS = tagname1=loc1 tagname2=loc2 ...
# This tag requires that the tag SEARCHENGINE is set to YES.
-EXTRA_SEARCH_MAPPINGS =
+EXTRA_SEARCH_MAPPINGS =
#---------------------------------------------------------------------------
# Configuration options related to the LaTeX output
@@ -1721,7 +1721,7 @@ PAPER_TYPE = a4
# If left blank no extra packages will be included.
# This tag requires that the tag GENERATE_LATEX is set to YES.
-EXTRA_PACKAGES =
+EXTRA_PACKAGES =
# The LATEX_HEADER tag can be used to specify a personal LaTeX header for the
# generated LaTeX document. The header should contain everything until the first
@@ -1737,7 +1737,7 @@ EXTRA_PACKAGES =
# to HTML_HEADER.
# This tag requires that the tag GENERATE_LATEX is set to YES.
-LATEX_HEADER =
+LATEX_HEADER =
# The LATEX_FOOTER tag can be used to specify a personal LaTeX footer for the
# generated LaTeX document. The footer should contain everything after the last
@@ -1748,7 +1748,7 @@ LATEX_HEADER =
# Note: Only use a user-defined footer if you know what you are doing!
# This tag requires that the tag GENERATE_LATEX is set to YES.
-LATEX_FOOTER =
+LATEX_FOOTER =
# The LATEX_EXTRA_STYLESHEET tag can be used to specify additional user-defined
# LaTeX style sheets that are included after the standard style sheets created
@@ -1759,7 +1759,7 @@ LATEX_FOOTER =
# list).
# This tag requires that the tag GENERATE_LATEX is set to YES.
-LATEX_EXTRA_STYLESHEET =
+LATEX_EXTRA_STYLESHEET =
# The LATEX_EXTRA_FILES tag can be used to specify one or more extra images or
# other source files which should be copied to the LATEX_OUTPUT output
@@ -1767,7 +1767,7 @@ LATEX_EXTRA_STYLESHEET =
# markers available.
# This tag requires that the tag GENERATE_LATEX is set to YES.
-LATEX_EXTRA_FILES =
+LATEX_EXTRA_FILES =
# If the PDF_HYPERLINKS tag is set to YES, the LaTeX that is generated is
# prepared for conversion to PDF (using ps2pdf or pdflatex). The PDF file will
@@ -1875,14 +1875,14 @@ RTF_HYPERLINKS = NO
# default style sheet that doxygen normally uses.
# This tag requires that the tag GENERATE_RTF is set to YES.
-RTF_STYLESHEET_FILE =
+RTF_STYLESHEET_FILE =
# Set optional variables used in the generation of an RTF document. Syntax is
# similar to doxygen's config file. A template extensions file can be generated
# using doxygen -e rtf extensionFile.
# This tag requires that the tag GENERATE_RTF is set to YES.
-RTF_EXTENSIONS_FILE =
+RTF_EXTENSIONS_FILE =
# If the RTF_SOURCE_CODE tag is set to YES then doxygen will include source code
# with syntax highlighting in the RTF output.
@@ -1927,7 +1927,7 @@ MAN_EXTENSION = .3
# MAN_EXTENSION with the initial . removed.
# This tag requires that the tag GENERATE_MAN is set to YES.
-MAN_SUBDIR =
+MAN_SUBDIR =
# If the MAN_LINKS tag is set to YES and doxygen generates man output, then it
# will generate one additional man file for each entity documented in the real
@@ -2040,7 +2040,7 @@ PERLMOD_PRETTY = YES
# overwrite each other's variables.
# This tag requires that the tag GENERATE_PERLMOD is set to YES.
-PERLMOD_MAKEVAR_PREFIX =
+PERLMOD_MAKEVAR_PREFIX =
#---------------------------------------------------------------------------
# Configuration options related to the preprocessor
@@ -2081,7 +2081,7 @@ SEARCH_INCLUDES = YES
# preprocessor.
# This tag requires that the tag SEARCH_INCLUDES is set to YES.
-INCLUDE_PATH =
+INCLUDE_PATH =
# You can use the INCLUDE_FILE_PATTERNS tag to specify one or more wildcard
# patterns (like *.h and *.hpp) to filter out the header-files in the
@@ -2089,7 +2089,7 @@ INCLUDE_PATH =
# used.
# This tag requires that the tag ENABLE_PREPROCESSING is set to YES.
-INCLUDE_FILE_PATTERNS =
+INCLUDE_FILE_PATTERNS =
# The PREDEFINED tag can be used to specify one or more macro names that are
# defined before the preprocessor is started (similar to the -D option of e.g.
@@ -2099,7 +2099,7 @@ INCLUDE_FILE_PATTERNS =
# recursively expanded use the := operator instead of the = operator.
# This tag requires that the tag ENABLE_PREPROCESSING is set to YES.
-PREDEFINED =
+PREDEFINED =
# If the MACRO_EXPANSION and EXPAND_ONLY_PREDEF tags are set to YES then this
# tag can be used to specify a list of macro names that should be expanded. The
@@ -2108,7 +2108,7 @@ PREDEFINED =
# definition found in the source code.
# This tag requires that the tag ENABLE_PREPROCESSING is set to YES.
-EXPAND_AS_DEFINED =
+EXPAND_AS_DEFINED =
# If the SKIP_FUNCTION_MACROS tag is set to YES then doxygen's preprocessor will
# remove all references to function-like macros that are alone on a line, have
@@ -2137,13 +2137,13 @@ SKIP_FUNCTION_MACROS = YES
# the path). If a tag file is not located in the directory in which doxygen is
# run, you must also specify the path to the tagfile here.
-TAGFILES =
+TAGFILES =
# When a file name is specified after GENERATE_TAGFILE, doxygen will create a
# tag file that is based on the input files it reads. See section "Linking to
# external documentation" for more information about the usage of tag files.
-GENERATE_TAGFILE =
+GENERATE_TAGFILE =
# If the ALLEXTERNALS tag is set to YES, all external class will be listed in
# the class index. If set to NO, only the inherited external classes will be
@@ -2192,14 +2192,14 @@ CLASS_DIAGRAMS = YES
# the mscgen tool resides. If left empty the tool is assumed to be found in the
# default search path.
-MSCGEN_PATH =
+MSCGEN_PATH =
# You can include diagrams made with dia in doxygen documentation. Doxygen will
# then run dia to produce the diagram and insert it in the documentation. The
# DIA_PATH tag allows you to specify the directory where the dia binary resides.
# If left empty dia is assumed to be found in the default search path.
-DIA_PATH =
+DIA_PATH =
# If set to YES the inheritance and collaboration graphs will hide inheritance
# and usage relations if the target is undocumented or is not a class.
@@ -2248,7 +2248,7 @@ DOT_FONTSIZE = 10
# the path where dot can find it using this tag.
# This tag requires that the tag HAVE_DOT is set to YES.
-DOT_FONTPATH =
+DOT_FONTPATH =
# If the CLASS_GRAPH tag is set to YES then doxygen will generate a graph for
# each documented class showing the direct and indirect inheritance relations.
@@ -2394,26 +2394,26 @@ INTERACTIVE_SVG = YES
# found. If left blank, it is assumed the dot tool can be found in the path.
# This tag requires that the tag HAVE_DOT is set to YES.
-DOT_PATH =
+DOT_PATH =
# The DOTFILE_DIRS tag can be used to specify one or more directories that
# contain dot files that are included in the documentation (see the \dotfile
# command).
# This tag requires that the tag HAVE_DOT is set to YES.
-DOTFILE_DIRS =
+DOTFILE_DIRS =
# The MSCFILE_DIRS tag can be used to specify one or more directories that
# contain msc files that are included in the documentation (see the \mscfile
# command).
-MSCFILE_DIRS =
+MSCFILE_DIRS =
# The DIAFILE_DIRS tag can be used to specify one or more directories that
# contain dia files that are included in the documentation (see the \diafile
# command).
-DIAFILE_DIRS =
+DIAFILE_DIRS =
# When using plantuml, the PLANTUML_JAR_PATH tag should be used to specify the
# path where java can find the plantuml.jar file. If left blank, it is assumed
@@ -2421,17 +2421,17 @@ DIAFILE_DIRS =
# generate a warning when it encounters a \startuml command in this case and
# will not generate output for the diagram.
-PLANTUML_JAR_PATH =
+PLANTUML_JAR_PATH =
# When using plantuml, the PLANTUML_CFG_FILE tag can be used to specify a
# configuration file for plantuml.
-PLANTUML_CFG_FILE =
+PLANTUML_CFG_FILE =
# When using plantuml, the specified paths are searched for files specified by
# the !include statement in a plantuml block.
-PLANTUML_INCLUDE_PATH =
+PLANTUML_INCLUDE_PATH =
# The DOT_GRAPH_MAX_NODES tag can be used to set the maximum number of nodes
# that will be shown in the graph. If the number of nodes in a graph becomes
diff --git a/Makefile b/Makefile
index 3fc8148..c368d50 100644
--- a/Makefile
+++ b/Makefile
@@ -23,7 +23,7 @@ LDFLAGS := -lm
$(TARGET): $(OBJS) Makefile
$(CC) $(LDFLAGS) $(OBJS) -DVERSION=$(VERSION) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS)
-doc: $(SRCS) Makefile
+doc: $(SRCS) Makefile Doxyfile
doxygen
format: $(SRCS) $(HDRS) Makefile
diff --git a/src/arith/integer.c b/src/arith/integer.c
index 60ce8c3..5239746 100644
--- a/src/arith/integer.c
+++ b/src/arith/integer.c
@@ -13,6 +13,7 @@
#include "conspage.h"
#include "consspaceobject.h"
+#include "debug.h"
/**
* return the numeric value of this cell, as a C primitive double, not
@@ -40,9 +41,7 @@ struct cons_pointer make_integer( int64_t value ) {
struct cons_space_object *cell = &pointer2cell( result );
cell->payload.integer.value = value;
-#ifdef DEBUG
- dump_object( stderr, result );
-#endif
+ debug_dump_object( result, DEBUG_ARITH );
return result;
}
diff --git a/src/arith/peano.c b/src/arith/peano.c
index 763414e..4cb8abd 100644
--- a/src/arith/peano.c
+++ b/src/arith/peano.c
@@ -16,6 +16,7 @@
#include "consspaceobject.h"
#include "conspage.h"
+#include "debug.h"
#include "equal.h"
#include "integer.h"
#include "intern.h"
@@ -86,8 +87,8 @@ long double to_long_double( struct cons_pointer arg ) {
break;
}
- fputws( L"to_long_double( ", stderr );
- print( stderr, arg );
+ debug_print( L"to_long_double( ", DEBUG_ARITH );
+ debug_print_object( arg, DEBUG_ARITH );
fwprintf( stderr, L") => %lf\n", result );
return result;
@@ -129,13 +130,11 @@ struct cons_pointer add_2( struct stack_frame *frame,
struct cons_space_object cell1 = pointer2cell( arg1 );
struct cons_space_object cell2 = pointer2cell( arg2 );
-#ifdef DEBUG
- fputws( L"add_2( arg1 = ", stderr );
- print( stderr, arg1 );
- fputws( L"; arg2 = ", stderr );
- print( stderr, arg2 );
- fputws( L")\n", stderr );
-#endif
+ debug_print( L"add_2( arg1 = ", DEBUG_ARITH );
+ debug_print_object( arg1, DEBUG_ARITH );
+ debug_print( L"; arg2 = ", DEBUG_ARITH );
+ debug_print_object( arg2, DEBUG_ARITH );
+ debug_print( L"\n", DEBUG_ARITH );
if ( zerop( arg1 ) ) {
result = arg2;
@@ -209,11 +208,9 @@ struct cons_pointer add_2( struct stack_frame *frame,
}
}
-#ifdef DEBUG
- fputws( L"}; => ", stderr );
- print( stderr, arg2 );
- fputws( L"\n", stderr );
-#endif
+ debug_print( L"}; => ", DEBUG_ARITH );
+ debug_print_object( arg2, DEBUG_ARITH );
+ debug_print( L"\n", DEBUG_ARITH );
return result;
}
@@ -267,13 +264,11 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
struct cons_space_object cell1 = pointer2cell( arg1 );
struct cons_space_object cell2 = pointer2cell( arg2 );
-#ifdef DEBUG
- fputws( L"multiply_2( arg1 = ", stderr );
- print( stderr, arg1 );
- fputws( L"; arg2 = ", stderr );
- print( stderr, arg2 );
- fputws( L")\n", stderr );
-#endif
+ debug_print( L"multiply_2( arg1 = ", DEBUG_ARITH );
+ debug_print_object( arg1, DEBUG_ARITH );
+ debug_print( L"; arg2 = ", DEBUG_ARITH );
+ debug_print_object( arg2, DEBUG_ARITH );
+ debug_print( L")", DEBUG_ARITH );
if ( zerop( arg1 ) ) {
result = arg2;
@@ -348,11 +343,9 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
}
}
-#ifdef DEBUG
- fputws( L" => ", stderr );
- print( stderr, arg2 );
- fputws( L"\n", stderr );
-#endif
+ debug_print( L" => ", DEBUG_ARITH );
+ debug_print_object( arg2, DEBUG_ARITH );
+ debug_print( L"\n", DEBUG_ARITH );
return result;
}
diff --git a/src/arith/ratio.c b/src/arith/ratio.c
index afea5b0..f12acbb 100644
--- a/src/arith/ratio.c
+++ b/src/arith/ratio.c
@@ -13,7 +13,7 @@
#include "conspage.h"
#include "consspaceobject.h"
-#include "dump.h"
+#include "debug.h"
#include "equal.h"
#include "integer.h"
#include "lispops.h"
@@ -332,9 +332,8 @@ struct cons_pointer make_ratio( struct cons_pointer frame_pointer,
( "Dividend and divisor of a ratio must be integers" ),
frame_pointer );
}
-#ifdef DEBUG
- dump_object( stderr, result );
-#endif
+ debug_dump_object( result, DEBUG_ARITH );
+
return result;
}
diff --git a/src/arith/real.c b/src/arith/real.c
index d3786dd..84ba899 100644
--- a/src/arith/real.c
+++ b/src/arith/real.c
@@ -9,7 +9,7 @@
#include "conspage.h"
#include "consspaceobject.h"
-#include "dump.h"
+#include "debug.h"
#include "read.h"
/**
@@ -23,9 +23,7 @@ struct cons_pointer make_real( long double value ) {
struct cons_space_object *cell = &pointer2cell( result );
cell->payload.real.value = value;
-#ifdef DEBUG
- dump_object( stderr, result );
-#endif
+ debug_dump_object( result, DEBUG_ARITH );
return result;
}
diff --git a/src/debug.c b/src/debug.c
new file mode 100644
index 0000000..27f7634
--- /dev/null
+++ b/src/debug.c
@@ -0,0 +1,65 @@
+/**
+ * debug.c
+ *
+ * Better debug log messages.
+ *
+ * (c) 2017 Simon Brooke <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#include <ctype.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+/*
+ * wide characters
+ */
+#include <wchar.h>
+#include <wctype.h>
+
+#include "consspaceobject.h"
+#include "debug.h"
+#include "dump.h"
+#include "print.h"
+
+/**
+ * the controlling flags for `debug_print`; set in `init.c`, q.v.
+ */
+int verbosity = 0;
+
+/**
+ * print this debug `message` to stderr, if `verbosity` matches `level`.
+ * `verbosity is a set of flags, see debug_print.h; so you can
+ * turn debugging on for only one part of the system.
+ */
+void debug_print( wchar_t *message, int level ) {
+#ifdef DEBUG
+ if ( level & verbosity ) {
+ fputws( message, stderr );
+ }
+#endif
+}
+
+/**
+ * print the object indicated by this `pointer` to stderr, if `verbosity`
+ * matches `level`.`verbosity is a set of flags, see debug_print.h; so you can
+ * turn debugging on for only one part of the system.
+ */
+void debug_print_object( struct cons_pointer pointer, int level ) {
+#ifdef DEBUG
+ if ( level & verbosity ) {
+ print( stderr, pointer );
+ }
+#endif
+}
+
+/**
+ * Like `dump_object`, q.v., but protected by the verbosity mechanism.
+ */
+void debug_dump_object( struct cons_pointer pointer, int level ) {
+#ifdef DEBUG
+ if ( level & verbosity ) {
+ dump_object( stderr, pointer );
+ }
+#endif
+}
diff --git a/src/debug.h b/src/debug.h
new file mode 100644
index 0000000..9c0448b
--- /dev/null
+++ b/src/debug.h
@@ -0,0 +1,28 @@
+/**
+ * debug.h
+ *
+ * Better debug log messages.
+ *
+ * (c) 2017 Simon Brooke <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#include <ctype.h>
+#include <stdio.h>
+
+#ifndef __debug_print_h
+#define __debug_print_h
+
+#define DEBUG_ALLOC 1
+#define DEBUG_STACK 2
+#define DEBUG_ARITH 4
+#define DEBUG_EVAL 8
+#define DEBUG_LAMBDA 16
+#define DEBUG_BOOTSTRAP 32
+#define DEBUG_IO 64
+
+extern int verbosity;
+void debug_print( wchar_t *message, int level );
+void debug_print_object( struct cons_pointer pointer, int level );
+void debug_dump_object( struct cons_pointer pointer, int level );
+#endif
diff --git a/src/init.c b/src/init.c
index 48516f6..bb722ae 100644
--- a/src/init.c
+++ b/src/init.c
@@ -11,26 +11,32 @@
#include <stdbool.h>
#include <stdio.h>
+#include <stdlib.h>
#include <unistd.h>
#include <wchar.h>
#include "version.h"
#include "conspage.h"
#include "consspaceobject.h"
+#include "debug.h"
#include "intern.h"
#include "lispops.h"
#include "peano.h"
#include "print.h"
#include "repl.h"
+// extern char *optarg; /* defined in unistd.h */
+
void bind_function( char *name, struct cons_pointer ( *executable )
- ( struct stack_frame *, struct cons_pointer ) ) {
+ ( struct stack_frame *,
+ struct cons_pointer, struct cons_pointer ) ) {
deep_bind( c_string_to_lisp_symbol( name ),
make_function( NIL, executable ) );
}
void bind_special( char *name, struct cons_pointer ( *executable )
- ( struct stack_frame * frame, struct cons_pointer env ) ) {
+ ( struct stack_frame *,
+ struct cons_pointer, struct cons_pointer ) ) {
deep_bind( c_string_to_lisp_symbol( name ),
make_special( NIL, executable ) );
}
@@ -46,7 +52,7 @@ int main( int argc, char *argv[] ) {
bool dump_at_end = false;
bool show_prompt = false;
- while ( ( option = getopt( argc, argv, "pdc" ) ) != -1 ) {
+ while ( ( option = getopt( argc, argv, "pdcv:" ) ) != -1 ) {
switch ( option ) {
case 'c':
print_use_colours = true;
@@ -57,6 +63,8 @@ int main( int argc, char *argv[] ) {
case 'p':
show_prompt = true;
break;
+ case 'v':
+ verbosity = atoi( optarg );
default:
fwprintf( stderr, L"Unexpected option %c\n", option );
break;
@@ -68,9 +76,15 @@ int main( int argc, char *argv[] ) {
L"Post scarcity software environment version %s\n\n",
VERSION );
}
-
+#ifdef DEBUG
+ fputws( L"About to initialise cons pages\n", stderr );
+#endif
initialise_cons_pages( );
+#ifdef DEBUG
+ fputws( L"Initialised cons pages, about to bind\n", stderr );
+#endif
+
/*
* privileged variables (keywords)
*/
diff --git a/src/memory/conspage.c b/src/memory/conspage.c
index 13d8373..75bcdc8 100644
--- a/src/memory/conspage.c
+++ b/src/memory/conspage.c
@@ -18,6 +18,7 @@
#include "consspaceobject.h"
#include "conspage.h"
+#include "dump.h"
/**
* Flag indicating whether conspage initialisation has been done.
@@ -168,7 +169,7 @@ void free_cell( struct cons_pointer pointer ) {
fwprintf( stderr, L"About to free vector-space object at %ld\n",
cell->payload.vectorp.address );
#endif
- free( ( void * ) cell->payload.vectorp.address );
+ //free( ( void * ) cell->payload.vectorp.address );
break;
}
diff --git a/src/memory/conspage.h b/src/memory/conspage.h
index 7b8b930..bc1361e 100644
--- a/src/memory/conspage.h
+++ b/src/memory/conspage.h
@@ -19,7 +19,7 @@
* 4294967296.
*
* Note that this means the total number of addressable cons cells is
- * 1.8e19, each of 20 bytes; or 3e20 bytes in total; and there are
+ * 1.8e19, each of 20 bytes; or 3e20 bytes in total; and there are
* up to a maximum of 4e9 of heap space objects, each of potentially
* 4e9 bytes. So we're talking about a potential total of 8e100 bytes
* of addressable memory, which is only slightly more than the
@@ -38,7 +38,7 @@ struct cons_page {
};
/**
- * The (global) pointer to the (global) freelist. Not sure whether this ultimately
+ * The (global) pointer to the (global) freelist. Not sure whether this ultimately
* belongs in this file.
*/
extern struct cons_pointer freelist;
diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h
index 44b6a79..47bbed0 100644
--- a/src/memory/consspaceobject.h
+++ b/src/memory/consspaceobject.h
@@ -133,7 +133,7 @@
* A pointer to an object in vector space.
*/
#define VECTORPOINTTAG "VECP"
-#define VECTORPOINTTV 0
+#define VECTORPOINTTV 1346585942
/**
* An open write stream.
*/
@@ -263,9 +263,10 @@
* An indirect pointer to a cons cell
*/
struct cons_pointer {
- uint32_t page; /* the index of the page on which this cell
- * resides */
- uint32_t offset; /* the index of the cell within the page */
+ /** the index of the page on which this cell resides */
+ uint32_t page;
+ /** the index of the cell within the page */
+ uint32_t offset;
};
/*
@@ -421,7 +422,7 @@ struct vectorp_payload {
* tag. */
uint32_t value; /* the tag considered as a number */
} tag;
- struct vector_space_object *address;
+ void *address;
/* the address of the actual vector space
* object (TODO: will change when I actually
* implement vector space) */
diff --git a/src/memory/cursor.c b/src/memory/cursor.c
new file mode 100644
index 0000000..31a38b2
--- /dev/null
+++ b/src/memory/cursor.c
@@ -0,0 +1,9 @@
+/*
+ * a cursor is a cons-space object which holds:
+ * 1. a pointer to a vector (i.e. a vector-space object which holds an
+ * array of `cons_pointer`);
+ * 2. an integer offset into that array.
+ *
+ * this provides a mechanism for iterating through vectors (actually, in
+ * either direction)
+ */
diff --git a/src/memory/cursor.h b/src/memory/cursor.h
new file mode 100644
index 0000000000000000000000000000000000000000..a50aff600d3015faae07bdd40e47973ce43ee241
GIT binary patch
literal 614
zcmZWm!A=4(6!g4b@d6hmWLeOJpvH)3xR5|Vx$c&3$rei=X}gg9dtX~H7&qC&wDac8
zbb6gm0v!Ne8;d5b2n75txMGGmiP{3k{T?+q1f~=rI<g1G1>j~UxU*@T3WK-&4hC6&
z2rKDl-VEZmfM@H`>kez9MYCr*<@_b^XOatTMG3Vog@Nf}21j8m?S(;_bpcHmn1hBU
z0T12}VcmdYj_7BqH_%Ixw%n4)7V<pC$*ZJISZZ;7l=Nce@i{bbq0}Sv??=N?_Atzb
zLF_U(`C6{#%g^x?{MYiZ^{aZmT!*`B1=``$xk?xTjDB}QII+h1qs!g{YZS7Q9<){^
zYy?EFWeRh0EIpT!OXrm$r$Qn!D0~I^0i~ulC?YK&8o{`MY1EQ41;zSfvM55v=!hi$
sa*HE%h$at}=CRV^DafD?aOEW0@H!VK)|r|+>fyfx^&xaAx5-WN1CG$cHvj+t
literal 0
HcmV?d00001
diff --git a/src/memory/dump.c b/src/memory/dump.c
index 5aaedfb..e0c2bbc 100644
--- a/src/memory/dump.c
+++ b/src/memory/dump.c
@@ -20,6 +20,7 @@
#include "conspage.h"
#include "consspaceobject.h"
+#include "debug.h"
#include "print.h"
#include "stack.h"
#include "vectorspace.h"
@@ -111,11 +112,25 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
dump_string_cell( output, L"Symbol", pointer );
break;
case VECTORPOINTTV:{
+ fwprintf( output,
+ L"\t\tPointer to vector-space object at %p\n",
+ cell.payload.vectorp.address );
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 );
+ &vso->header.tag.bytes, vso->header.size );
+ switch ( vso->header.tag.value ) {
+ case STACKFRAMETV:
+ dump_frame( output, pointer );
+ break;
+ default:
+ fputws( L"(Unknown vector type)\n", output );
+ break;
+ }
}
break;
+ default:
+ fputws( L"(Unknown cons space type)\n", output );
+ break;
}
}
diff --git a/src/memory/stack.c b/src/memory/stack.c
index 9f0f6f8..069b1ed 100644
--- a/src/memory/stack.c
+++ b/src/memory/stack.c
@@ -19,6 +19,8 @@
#include "consspaceobject.h"
#include "conspage.h"
+#include "debug.h"
+#include "dump.h"
#include "lispops.h"
#include "print.h"
#include "stack.h"
@@ -30,21 +32,24 @@
*/
struct stack_frame *get_stack_frame( struct cons_pointer pointer ) {
struct stack_frame *result = NULL;
- fputws
+ debug_print
( L"get_stack_frame: about to get a pointer to the vector space object\n",
- stderr );
+ DEBUG_ALLOC );
struct vector_space_object *vso =
pointer2cell( pointer ).payload.vectorp.address;
- fputws( L"get_stack_frame: got a pointer, about to test it\n", stderr );
+ debug_print( L"get_stack_frame: got a pointer, about to test it\n",
+ DEBUG_ALLOC );
- if ( vectorpointp( pointer ) ) { // && stackframep(vso)){
- fputws( L"get_stack_frame: pointer is good, about to set the result\n",
- stderr );
+ if ( vectorpointp( pointer ) && stackframep( vso ) ) {
+ debug_print
+ ( L"get_stack_frame: pointer is good, about to set the result\n",
+ DEBUG_ALLOC );
result = ( struct stack_frame * ) &( vso->payload );
- fputws( L"get_stack_frame: all good, returning\n", stderr );
+ fwprintf( stderr, L"get_stack_frame: all good, returning %p\n",
+ result );
} else {
- fputws( L"get_stack_frame: fail, returning NULL\n", stderr );
+ debug_print( L"get_stack_frame: fail, returning NULL\n", DEBUG_ALLOC );
}
return result;
@@ -57,11 +62,20 @@ struct stack_frame *get_stack_frame( struct cons_pointer pointer ) {
* @return the new frame, or NULL if memory is exhausted.
*/
struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
- fputws( L"Entering make_empty_frame\n", stderr );
+ debug_print( L"Entering make_empty_frame\n", DEBUG_ALLOC );
struct cons_pointer result =
make_vso( STACKFRAMETAG, sizeof( struct stack_frame ) );
+
+ debug_dump_object( result, DEBUG_ALLOC );
+
+ fwprintf( stderr,
+ L"make_empty_frame: got vector_space_object with size %lu, tag %4.4s\n",
+ pointer_to_vso( result )->header.size,
+ &pointer_to_vso( result )->header.tag.bytes );
+
if ( !nilp( result ) ) {
- fputws( L"make_empty_frame: about to call get_stack_frame\n", stderr );
+ debug_print( L"make_empty_frame: about to call get_stack_frame\n",
+ DEBUG_ALLOC );
struct stack_frame *frame = get_stack_frame( result );
/*
* TODO: later, pop a frame off a free-list of stack frames
@@ -69,9 +83,10 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
fwprintf( stderr,
L"make_empty_frame: about to set previous to %4.4s\n",
- pointer2cell( previous ).tag );
+ &pointer2cell( previous ).tag.bytes );
frame->previous = previous;
- fputws( L"make_empty_frame: about to call inc_ref\n", stderr );
+ debug_print( L"make_empty_frame: about to call inc_ref\n",
+ DEBUG_ALLOC );
inc_ref( previous );
/*
@@ -82,13 +97,13 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
frame->function = NIL;
frame->args = 0;
- fputws( L"make_empty_frame: about to initialise arg registers\n",
- stderr );
+ debug_print( L"make_empty_frame: about to initialise arg registers\n",
+ DEBUG_ALLOC );
for ( int i = 0; i < args_in_frame; i++ ) {
set_reg( frame, i, NIL );
}
}
- fputws( L"Leaving make_empty_frame\n", stderr );
+ debug_print( L"Leaving make_empty_frame\n", DEBUG_ALLOC );
return result;
}
@@ -104,7 +119,7 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
struct cons_pointer make_stack_frame( struct cons_pointer previous,
struct cons_pointer args,
struct cons_pointer env ) {
- fputws( L"Entering make_stack_frame\n", stderr );
+ debug_print( L"Entering make_stack_frame\n", DEBUG_ALLOC );
struct cons_pointer result = make_empty_frame( previous );
if ( nilp( result ) ) {
@@ -164,12 +179,11 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
frame->more = more;
inc_ref( more );
}
-#ifdef DEBUG
- dump_frame( stderr, result );
-#endif
+
+ debug_dump_object( result, DEBUG_ALLOC );
}
}
- fputws( L"Leaving make_stack_frame\n", stderr );
+ debug_print( L"Leaving make_stack_frame\n", DEBUG_ALLOC );
return result;
}
@@ -185,7 +199,7 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
struct cons_pointer make_special_frame( struct cons_pointer previous,
struct cons_pointer args,
struct cons_pointer env ) {
- fputws( L"Entering make_special_frame\n", stderr );
+ debug_print( L"Entering make_special_frame\n", DEBUG_ALLOC );
struct cons_pointer result = make_empty_frame( previous );
@@ -213,12 +227,11 @@ struct cons_pointer make_special_frame( struct cons_pointer previous,
frame->more = args;
inc_ref( args );
}
-#ifdef DEBUG
- dump_frame( stderr, result );
-#endif
+
+ debug_dump_object( result, DEBUG_ALLOC );
}
}
- fputws( L"Leaving make_special_frame\n", stderr );
+ debug_print( L"Leaving make_special_frame\n", DEBUG_ALLOC );
return result;
}
diff --git a/src/memory/stack.h b/src/memory/stack.h
index 20acd73..b56f432 100644
--- a/src/memory/stack.h
+++ b/src/memory/stack.h
@@ -33,13 +33,13 @@
/**
* is this vector-space object a stack frame?
*/
-#define stackframep(vso)(vso->header.tag.value == STACKFRAMETV)
+#define stackframep(vso)(((struct vector_space_object *)vso)->header.tag.value == STACKFRAMETV)
/**
* 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!
*/
-#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 );
diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c
index db39b48..7dbe682 100644
--- a/src/memory/vectorspace.c
+++ b/src/memory/vectorspace.c
@@ -21,6 +21,7 @@
#include "conspage.h"
#include "consspaceobject.h"
+#include "dump.h"
#include "vectorspace.h"
@@ -30,19 +31,18 @@
* NOTE that `tag` should be the vector-space tag of the particular type of
* vector-space object, NOT `VECTORPOINTTAG`.
*/
-struct cons_pointer make_vec_pointer( char *tag,
- struct vector_space_object *address ) {
+struct cons_pointer make_vec_pointer( struct vector_space_object *address ) {
fputws( L"Entered make_vec_pointer\n", stderr );
struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG );
- struct cons_space_object cell = pointer2cell( pointer );
+ struct cons_space_object *cell = &pointer2cell( pointer );
fwprintf( stderr,
- L"make_vec_pointer: allocated cell, about to write tag '%s'\n",
- tag );
- strncpy( &cell.payload.vectorp.tag.bytes[0], tag, 4 );
- fputws( L"make_vec_pointer: tag written, about to set pointer address\n",
- stderr );
- cell.payload.vectorp.address = address;
- fputws( L"make_vec_pointer: all good, returning\n", stderr );
+ L"make_vec_pointer: tag written, about to set pointer address to %p\n",
+ address );
+ cell->payload.vectorp.address = address;
+ fwprintf( stderr, L"make_vec_pointer: all good, returning pointer to %p\n",
+ cell->payload.vectorp.address );
+
+ dump_object( stderr, pointer );
return pointer;
}
@@ -66,24 +66,32 @@ struct cons_pointer make_vso( char *tag, uint64_t payload_size ) {
struct vector_space_object *vso = malloc( padded );
if ( vso != NULL ) {
- fwprintf( stderr, L"make_vso: about to write tag '%s'\n", tag );
+ fwprintf( stderr,
+ L"make_vso: about to write tag '%s' into vso at %p\n", tag,
+ vso );
strncpy( &vso->header.tag.bytes[0], tag, TAGLENGTH );
- vso->header.vecp = make_vec_pointer( tag, vso );
+ result = make_vec_pointer( vso );
+ dump_object( stderr, result );
+ vso->header.vecp = result;
+ // memcpy(vso->header.vecp, result, sizeof(struct cons_pointer));
+
vso->header.size = payload_size;
#ifdef DEBUG
fwprintf( stderr,
- L"Allocated vector-space object of type %4.4s, total size %ld, payload size %ld\n",
- tag, total_size, payload_size );
+ L"Allocated vector-space object of type %4.4s, total size %ld, payload size %ld, at address %p, payload address %p\n",
+ &vso->header.tag.bytes, total_size, vso->header.size, vso,
+ &vso->payload );
if ( padded != total_size ) {
fwprintf( stderr, L"\t\tPadded from %d to %d\n",
total_size, padded );
}
#endif
-
- result = vso->header.vecp;
}
- fputws( L"make_vso: all good, returning\n", stderr );
+#ifdef DEBUG
+ fwprintf( stderr, L"make_vso: all good, returning pointer to %p\n",
+ pointer2cell( result ).payload.vectorp.address );
+#endif
return result;
}
diff --git a/src/memory/vectorspace.h b/src/memory/vectorspace.h
index caec968..1438d37 100644
--- a/src/memory/vectorspace.h
+++ b/src/memory/vectorspace.h
@@ -40,7 +40,7 @@
#define VECTORTAG "VECT"
#define VECTORTV 0
-#define pointer_to_vso(pointer)((vectorpointp(pointer)? pointer2cell(pointer).payload.vectorp.address : NULL))
+#define pointer_to_vso(pointer)((vectorpointp(pointer)? (struct vector_space_object *) pointer2cell(pointer).payload.vectorp.address : (struct vector_space_object *) NULL))
#define vso_get_vecp(vso)((vso->header.vecp))
struct cons_pointer make_vso( char *tag, uint64_t payload_size );
diff --git a/src/ops/intern.c b/src/ops/intern.c
index 100589a..8dea7c8 100644
--- a/src/ops/intern.c
+++ b/src/ops/intern.c
@@ -21,6 +21,7 @@
#include "conspage.h"
#include "consspaceobject.h"
+#include "debug.h"
#include "equal.h"
#include "lispops.h"
#include "print.h"
@@ -56,22 +57,22 @@ internedp( struct cons_pointer key, struct cons_pointer store ) {
struct cons_space_object entry =
pointer2cell( pointer2cell( next ).payload.cons.car );
- fputws( L"Internedp: checking whether `", stderr );
- print( stderr, key );
- fputws( L"` equals `", stderr );
- print( stderr, entry.payload.cons.car );
- fputws( L"`\n", stderr );
+ debug_print( L"Internedp: checking whether `", DEBUG_ALLOC );
+ debug_print_object( key, DEBUG_ALLOC );
+ debug_print( L"` equals `", DEBUG_ALLOC );
+ debug_print_object( entry.payload.cons.car, DEBUG_ALLOC );
+ debug_print( L"`\n", DEBUG_ALLOC );
if ( equal( key, entry.payload.cons.car ) ) {
result = entry.payload.cons.car;
}
}
} else {
- fputws( L"`", stderr );
- print( stderr, key );
- fputws( L"` is a ", stderr );
- print( stderr, c_type( key ) );
- fputws( L", not a SYMB", stderr );
+ debug_print( L"`", DEBUG_ALLOC );
+ debug_print_object( key, DEBUG_ALLOC );
+ debug_print( L"` is a ", DEBUG_ALLOC );
+ debug_print_object( c_type( key ), DEBUG_ALLOC );
+ debug_print( L", not a SYMB", DEBUG_ALLOC );
}
return result;
@@ -120,7 +121,17 @@ bind( struct cons_pointer key, struct cons_pointer value,
*/
struct cons_pointer
deep_bind( struct cons_pointer key, struct cons_pointer value ) {
+ debug_print( L"Entering deep_bind\n", DEBUG_ALLOC );
+ debug_print( L"\tSetting ", DEBUG_ALLOC );
+ debug_print_object( key, DEBUG_ALLOC );
+ debug_print( L" to ", DEBUG_ALLOC );
+ debug_print_object( value, DEBUG_ALLOC );
+ debug_print( L"\n", DEBUG_ALLOC );
+
oblist = bind( key, value, oblist );
+
+ debug_print( L"Leaving deep_bind\n", DEBUG_ALLOC );
+
return oblist;
}
diff --git a/src/ops/lispops.c b/src/ops/lispops.c
index 1e6712d..da3bc82 100644
--- a/src/ops/lispops.c
+++ b/src/ops/lispops.c
@@ -26,6 +26,8 @@
#include "consspaceobject.h"
#include "conspage.h"
+#include "debug.h"
+#include "dump.h"
#include "equal.h"
#include "integer.h"
#include "intern.h"
@@ -83,9 +85,8 @@ struct cons_pointer eval_form( struct stack_frame *parent,
struct cons_pointer parent_pointer,
struct cons_pointer form,
struct cons_pointer env ) {
- fputws( L"eval_form: ", stderr );
- print( stderr, form );
- fputws( L"\n", stderr );
+ debug_print( L"eval_form: ", DEBUG_EVAL );
+ debug_dump_object( form, DEBUG_EVAL );
struct cons_pointer result = NIL;
struct cons_pointer next_pointer = make_empty_frame( parent_pointer );
@@ -148,9 +149,8 @@ struct cons_pointer compose_body( struct stack_frame *frame ) {
}
}
- fputws( L"compose_body returning ", stderr );
- print( stderr, body );
- fputws( L"\n", stderr );
+ debug_print( L"compose_body returning ", DEBUG_LAMBDA );
+ debug_dump_object( body, DEBUG_LAMBDA );
return body;
}
@@ -180,13 +180,10 @@ lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer,
}
void log_binding( struct cons_pointer name, struct cons_pointer val ) {
-#ifdef DEBUG
- fputws( L"\n\tBinding ", stderr );
- print( stderr, name );
- fputws( L" to ", stderr );
- print( stderr, val );
- fputws( L"\"\n", stderr );
-#endif
+ debug_print( L"\n\tBinding ", DEBUG_ALLOC );
+ debug_dump_object( name, DEBUG_ALLOC );
+ debug_print( L" to ", DEBUG_ALLOC );
+ debug_dump_object( val, DEBUG_ALLOC );
}
/**
@@ -236,9 +233,9 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
while ( !nilp( body ) ) {
struct cons_pointer sexpr = c_car( body );
body = c_cdr( body );
-#ifdef DEBUG
- fputws( L"In lambda: ", stderr );
-#endif
+
+ debug_print( L"In lambda: ", DEBUG_LAMBDA );
+
result = eval_form( frame, frame_pointer, sexpr, new_env );
}
@@ -414,8 +411,8 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer result = frame->arg[0];
struct cons_space_object cell = pointer2cell( frame->arg[0] );
+ debug_print( L"Eval: ", DEBUG_EVAL );
#ifdef DEBUG
- fputws( L"Eval: ", stderr );
dump_frame( stderr, frame_pointer );
#endif
@@ -455,11 +452,8 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
break;
}
-#ifdef DEBUG
- fputws( L"Eval returning ", stderr );
- print( stderr, result );
- fputws( L"\n", stderr );
-#endif
+ debug_print( L"Eval returning ", DEBUG_EVAL );
+ debug_dump_object( result, DEBUG_EVAL );
return result;
}
@@ -476,7 +470,7 @@ struct cons_pointer
lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
#ifdef DEBUG
- fputws( L"Apply: ", stderr );
+ debug_print( L"Apply: ", DEBUG_EVAL );
dump_frame( stderr, frame_pointer );
#endif
set_reg( frame, 0, make_cons( frame->arg[0], frame->arg[1] ) );
@@ -484,11 +478,8 @@ lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer result = c_apply( frame, frame_pointer, env );
-#ifdef DEBUG
- fputws( L"Apply returning ", stderr );
- print( stderr, result );
- fputws( L"\n", stderr );
-#endif
+ debug_print( L"Apply returning ", DEBUG_EVAL );
+ debug_dump_object( result, DEBUG_EVAL );
return result;
}
@@ -690,13 +681,20 @@ lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer
lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
+#ifdef DEBUG
+ debug_print( L"entering lisp_read\n", DEBUG_IO );
+#endif
FILE *input = stdin;
if ( readp( frame->arg[0] ) ) {
input = pointer2cell( frame->arg[0] ).payload.stream.stream;
}
- return read( frame, frame_pointer, input );
+ struct cons_pointer result = read( frame, frame_pointer, input );
+ debug_print( L"lisp_read returning\n", DEBUG_IO );
+ debug_dump_object( result, DEBUG_IO );
+
+ return result;
}
@@ -745,23 +743,22 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame,
struct cons_pointer
lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
-#ifdef DEBUG
- fputws( L"Entering print\n", stderr );
-#endif
+ debug_print( L"Entering print\n", DEBUG_IO );
struct cons_pointer result = NIL;
FILE *output = stdout;
if ( writep( frame->arg[1] ) ) {
+ debug_print( L"lisp_print: setting output stream\n", DEBUG_IO );
+ debug_dump_object( frame->arg[1], DEBUG_IO );
output = pointer2cell( frame->arg[1] ).payload.stream.stream;
}
+ debug_print( L"lisp_print: about to print\n", DEBUG_IO );
+ debug_dump_object( frame->arg[0], DEBUG_IO );
result = print( output, frame->arg[0] );
-#ifdef DEBUG
- fputws( L"Print returning ", stderr );
- // print( stderr, result );
- fputws( L"\n", stderr );
-#endif
+ debug_print( L"lisp_print returning\n", DEBUG_IO );
+ debug_dump_object( result, DEBUG_IO );
return result;
}
@@ -828,8 +825,8 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer,
for ( int i = 0; i < args_in_frame && !done; i++ ) {
struct cons_pointer clause_pointer = frame->arg[i];
- fputws( L"Cond clause: ", stderr );
- print( stderr, clause_pointer );
+ debug_print( L"Cond clause: ", DEBUG_EVAL );
+ debug_dump_object( clause_pointer, DEBUG_EVAL );
if ( consp( clause_pointer ) ) {
struct cons_space_object cell = pointer2cell( clause_pointer );
@@ -876,8 +873,8 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer
throw_exception( struct cons_pointer message,
struct cons_pointer frame_pointer ) {
- fwprintf( stderr, L"\nERROR: " );
- print( stderr, message );
+ debug_print( L"\nERROR: ", DEBUG_EVAL );
+ debug_dump_object( message, DEBUG_EVAL );
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( message );
diff --git a/src/ops/read.c b/src/ops/read.c
index 7d21dbe..e3cb480 100644
--- a/src/ops/read.c
+++ b/src/ops/read.c
@@ -18,6 +18,8 @@
#include <wctype.h>
#include "consspaceobject.h"
+#include "debug.h"
+#include "dump.h"
#include "integer.h"
#include "intern.h"
#include "lispops.h"
@@ -59,6 +61,7 @@ struct cons_pointer c_quote( struct cons_pointer arg ) {
struct cons_pointer read_continuation( struct stack_frame *frame,
struct cons_pointer frame_pointer,
FILE * input, wint_t initial ) {
+ debug_print( L"entering read_continuation\n", DEBUG_IO );
struct cons_pointer result = NIL;
wint_t c;
@@ -141,6 +144,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
break;
}
}
+ debug_print( L"read_continuation returning\n", DEBUG_IO );
+ debug_dump_object( result, DEBUG_IO );
return result;
}
@@ -154,6 +159,7 @@ struct cons_pointer read_number( struct stack_frame *frame,
struct cons_pointer frame_pointer,
FILE * input,
wint_t initial, bool seen_period ) {
+ debug_print( L"entering read_number\n", DEBUG_IO );
struct cons_pointer result = NIL;
int64_t accumulator = 0;
int64_t dividend = 0;
@@ -210,9 +216,6 @@ struct cons_pointer read_number( struct stack_frame *frame,
if ( negative ) {
rv = 0 - rv;
}
-#ifdef DEBUG
- fwprintf( stderr, L"read_numer returning %Lf\n", rv );
-#endif
result = make_real( rv );
} else if ( dividend != 0 ) {
result =
@@ -225,6 +228,9 @@ struct cons_pointer read_number( struct stack_frame *frame,
result = make_integer( accumulator );
}
+ debug_print( L"read_number returning\n", DEBUG_IO );
+ debug_dump_object( result, DEBUG_IO );
+
return result;
}
@@ -248,12 +254,9 @@ struct cons_pointer read_list( struct stack_frame *frame,
make_cons( car,
read_list( frame, frame_pointer, input,
fgetwc( input ) ) );
+ } else {
+ debug_print( L"End of list detected\n", DEBUG_IO );
}
-#ifdef DEBUG
- else {
- fwprintf( stderr, L"End of list detected\n" );
- }
-#endif
return result;
}
@@ -324,11 +327,8 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
break;
}
-#ifdef DEBUG
- fputws( L"Read symbol '", stderr );
- print( stderr, result );
- fputws( L"'\n", stderr );
-#endif
+ debug_print( L"read_symbol returning\n", DEBUG_IO );
+ debug_dump_object( result, DEBUG_IO );
return result;
}
diff --git a/src/repl.c b/src/repl.c
index d077ba8..f0dcbfa 100644
--- a/src/repl.c
+++ b/src/repl.c
@@ -13,6 +13,7 @@
#include "conspage.h"
#include "consspaceobject.h"
+#include "dump.h"
#include "intern.h"
#include "lispops.h"
#include "read.h"
@@ -32,19 +33,25 @@
*/
struct cons_pointer repl_read( struct cons_pointer stream_pointer ) {
struct cons_pointer result = NIL;
+ fputws( L"Entered repl_read\n", stderr );
struct cons_pointer frame_pointer = make_empty_frame( NIL );
+ fputws( L"repl_read: got stack_frame pointer\n", stderr );
+ dump_object( stderr, frame_pointer );
if ( !nilp( frame_pointer ) ) {
inc_ref( frame_pointer );
struct stack_frame *frame = get_stack_frame( frame_pointer );
if ( frame != NULL ) {
-
+ fputws( L"repl_read: about to set register\n", stderr );
set_reg( frame, 0, stream_pointer );
+ fputws( L"repl_read: about to read\n", stderr );
struct cons_pointer result =
lisp_read( frame, frame_pointer, oblist );
}
dec_ref( frame_pointer );
}
+ fputws( L"repl_read: returning\n", stderr );
+ dump_object( stderr, result );
return result;
}
@@ -53,6 +60,7 @@ struct cons_pointer repl_read( struct cons_pointer stream_pointer ) {
* Dummy up a Lisp eval call with its own stack frame.
*/
struct cons_pointer repl_eval( struct cons_pointer input ) {
+ fputws( L"Entered repl_eval\n", stderr );
struct cons_pointer result = NIL;
struct cons_pointer frame_pointer = make_empty_frame( NIL );
if ( !nilp( frame_pointer ) ) {
@@ -66,6 +74,8 @@ struct cons_pointer repl_eval( struct cons_pointer input ) {
dec_ref( frame_pointer );
}
+ fputws( L"repl_eval: returning\n", stderr );
+ dump_object( stderr, result );
return result;
}
@@ -75,6 +85,7 @@ struct cons_pointer repl_eval( struct cons_pointer input ) {
*/
struct cons_pointer repl_print( struct cons_pointer stream_pointer,
struct cons_pointer value ) {
+
struct cons_pointer result = NIL;
struct cons_pointer frame_pointer = make_empty_frame( NIL );
if ( !nilp( frame_pointer ) ) {
@@ -102,12 +113,12 @@ struct cons_pointer repl_print( struct cons_pointer stream_pointer,
void
repl( FILE * in_stream, FILE * out_stream, FILE * error_stream,
bool show_prompt ) {
+ fputws( L"Entered repl\n", stderr );
struct cons_pointer input_stream = make_read_stream( in_stream );
- pointer2cell( input_stream ).count = MAXREFERENCE;
+ inc_ref( input_stream );
struct cons_pointer output_stream = make_write_stream( out_stream );
- pointer2cell( output_stream ).count = MAXREFERENCE;
-
+ inc_ref( output_stream );
while ( !feof( pointer2cell( input_stream ).payload.stream.stream ) ) {
if ( show_prompt ) {
fwprintf( out_stream, L"\n:: " );
From e52ccce0ebce25dc02e170db050a51365f171f2a Mon Sep 17 00:00:00 2001
From: Simon Brooke <simon@journeyman.cc>
Date: Fri, 28 Dec 2018 15:50:37 +0000
Subject: [PATCH 4/6] Much progress! Half the unit tests pass.
---
src/arith/peano.c | 26 ++++-----
src/arith/ratio.c | 52 ++++++++----------
src/debug.c | 19 +++++++
src/debug.h | 4 ++
src/init.c | 88 +++++++++++++++---------------
src/memory/conspage.c | 29 ++++------
src/memory/consspaceobject.c | 25 +++++----
src/memory/consspaceobject.h | 4 +-
src/memory/dump.c | 26 +++++----
src/memory/stack.c | 57 ++++++++++---------
src/memory/vectorspace.c | 24 ++++----
src/ops/lispops.c | 45 +++++++--------
src/ops/print.c | 9 ++-
src/ops/read.c | 36 ++++++------
src/repl.c | 62 ++++++++-------------
utils_src/debugflags/debugflags | Bin 0 -> 8520 bytes
utils_src/debugflags/debugflags.c | 43 +++++++++++++++
17 files changed, 296 insertions(+), 253 deletions(-)
create mode 100755 utils_src/debugflags/debugflags
create mode 100644 utils_src/debugflags/debugflags.c
diff --git a/src/arith/peano.c b/src/arith/peano.c
index 4cb8abd..9f5e0fb 100644
--- a/src/arith/peano.c
+++ b/src/arith/peano.c
@@ -89,7 +89,7 @@ long double to_long_double( struct cons_pointer arg ) {
debug_print( L"to_long_double( ", DEBUG_ARITH );
debug_print_object( arg, DEBUG_ARITH );
- fwprintf( stderr, L") => %lf\n", result );
+ debug_printf( DEBUG_ARITH, L") => %lf\n", result );
return result;
}
@@ -166,7 +166,7 @@ struct cons_pointer add_2( struct stack_frame *frame,
break;
default:
result = throw_exception( c_string_to_lisp_string
- ( "Cannot add: not a number" ),
+ ( L"Cannot add: not a number" ),
frame_pointer );
break;
}
@@ -190,7 +190,7 @@ struct cons_pointer add_2( struct stack_frame *frame,
break;
default:
result = throw_exception( c_string_to_lisp_string
- ( "Cannot add: not a number" ),
+ ( L"Cannot add: not a number" ),
frame_pointer );
break;
}
@@ -203,7 +203,7 @@ struct cons_pointer add_2( struct stack_frame *frame,
default:
result = exceptionp( arg2 ) ? arg2 :
throw_exception( c_string_to_lisp_string
- ( "Cannot add: not a number" ),
+ ( L"Cannot add: not a number" ),
frame_pointer );
}
}
@@ -300,7 +300,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
break;
default:
result = throw_exception( c_string_to_lisp_string
- ( "Cannot multiply: not a number" ),
+ ( L"Cannot multiply: not a number" ),
frame_pointer );
break;
}
@@ -326,7 +326,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
break;
default:
result = throw_exception( c_string_to_lisp_string
- ( "Cannot multiply: not a number" ),
+ ( L"Cannot multiply: not a number" ),
frame_pointer );
}
break;
@@ -337,7 +337,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
break;
default:
result = throw_exception( c_string_to_lisp_string
- ( "Cannot multiply: not a number" ),
+ ( L"Cannot multiply: not a number" ),
frame_pointer );
break;
}
@@ -473,7 +473,7 @@ struct cons_pointer lisp_subtract( struct
break;
default:
result = throw_exception( c_string_to_lisp_string
- ( "Cannot subtract: not a number" ),
+ ( L"Cannot subtract: not a number" ),
frame_pointer );
break;
}
@@ -506,7 +506,7 @@ struct cons_pointer lisp_subtract( struct
break;
default:
result = throw_exception( c_string_to_lisp_string
- ( "Cannot subtract: not a number" ),
+ ( L"Cannot subtract: not a number" ),
frame_pointer );
break;
}
@@ -518,7 +518,7 @@ struct cons_pointer lisp_subtract( struct
break;
default:
result = throw_exception( c_string_to_lisp_string
- ( "Cannot subtract: not a number" ),
+ ( L"Cannot subtract: not a number" ),
frame_pointer );
break;
}
@@ -580,7 +580,7 @@ struct cons_pointer lisp_divide( struct
break;
default:
result = throw_exception( c_string_to_lisp_string
- ( "Cannot divide: not a number" ),
+ ( L"Cannot divide: not a number" ),
frame_pointer );
break;
}
@@ -615,7 +615,7 @@ struct cons_pointer lisp_divide( struct
break;
default:
result = throw_exception( c_string_to_lisp_string
- ( "Cannot divide: not a number" ),
+ ( L"Cannot divide: not a number" ),
frame_pointer );
break;
}
@@ -627,7 +627,7 @@ struct cons_pointer lisp_divide( struct
break;
default:
result = throw_exception( c_string_to_lisp_string
- ( "Cannot divide: not a number" ),
+ ( L"Cannot divide: not a number" ),
frame_pointer );
break;
}
diff --git a/src/arith/ratio.c b/src/arith/ratio.c
index f12acbb..ca83335 100644
--- a/src/arith/ratio.c
+++ b/src/arith/ratio.c
@@ -78,7 +78,7 @@ struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer,
} else {
result =
throw_exception( make_cons( c_string_to_lisp_string
- ( "Shouldn't happen: bad arg to simplify_ratio" ),
+ ( L"Shouldn't happen: bad arg to simplify_ratio" ),
arg ), frame_pointer );
}
@@ -97,13 +97,11 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg2 ) {
struct cons_pointer r, result;
-#ifdef DEBUG
- fputws( L"add_ratio_ratio( arg1 = ", stderr );
- print( stderr, arg1 );
- fputws( L"; arg2 = ", stderr );
- print( stderr, arg2 );
- fputws( L")\n", stderr );
-#endif
+ debug_print( L"add_ratio_ratio( arg1 = ", DEBUG_ARITH );
+ debug_print_object( arg1, DEBUG_ARITH );
+ debug_print( L"; arg2 = ", DEBUG_ARITH );
+ debug_print_object( arg2, DEBUG_ARITH );
+ debug_print( L")\n", DEBUG_ARITH );
if ( ratiop( arg1 ) && ratiop( arg2 ) ) {
struct cons_space_object cell1 = pointer2cell( arg1 );
@@ -119,9 +117,7 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
lcm = least_common_multiple( dr1v, dr2v ),
m1 = lcm / dr1v, m2 = lcm / dr2v;
-#ifdef DEBUG
- fwprintf( stderr, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 );
-#endif
+ debug_printf( DEBUG_ARITH, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 );
if ( dr1v == dr2v ) {
r = make_ratio( frame_pointer,
@@ -151,17 +147,15 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
} else {
result =
throw_exception( make_cons( c_string_to_lisp_string
- ( "Shouldn't happen: bad arg to add_ratio_ratio" ),
+ ( L"Shouldn't happen: bad arg to add_ratio_ratio" ),
make_cons( arg1,
make_cons( arg2, NIL ) ) ),
frame_pointer );
}
-#ifdef DEBUG
- fputws( L" => ", stderr );
- print( stderr, result );
- fputws( L"\n", stderr );
-#endif
+ debug_print( L" => ", DEBUG_ARITH );
+ debug_print_object( result, DEBUG_ARITH );
+ debug_print( L"\n", DEBUG_ARITH );
return result;
}
@@ -188,7 +182,7 @@ struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer,
} else {
result =
throw_exception( make_cons( c_string_to_lisp_string
- ( "Shouldn't happen: bad arg to add_integer_ratio" ),
+ ( L"Shouldn't happen: bad arg to add_integer_ratio" ),
make_cons( intarg,
make_cons( ratarg,
NIL ) ) ),
@@ -210,7 +204,8 @@ struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer,
pointer2cell( arg2 ).payload.
ratio.divisor,
pointer2cell( arg2 ).payload.
- ratio.dividend ), result =
+ ratio.dividend ),
+ result =
multiply_ratio_ratio( frame_pointer, arg1, i );
dec_ref( i );
@@ -228,13 +223,12 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str
cons_pointer arg2 ) {
struct cons_pointer result;
-#ifdef DEBUG
- fputws( L"multiply_ratio_ratio( arg1 = ", stderr );
- print( stderr, arg1 );
- fputws( L"; arg2 = ", stderr );
- print( stderr, arg2 );
- fputws( L")\n", stderr );
-#endif
+ debug_print( L"multiply_ratio_ratio( arg1 = ", DEBUG_ARITH );
+ debug_print_object( arg1, DEBUG_ARITH );
+ debug_print( L"; arg2 = ", DEBUG_ARITH );
+ debug_print_object( arg2, DEBUG_ARITH );
+ debug_print( L")\n", DEBUG_ARITH );
+
if ( ratiop( arg1 ) && ratiop( arg2 ) ) {
struct cons_space_object cell1 = pointer2cell( arg1 );
struct cons_space_object cell2 = pointer2cell( arg2 );
@@ -259,7 +253,7 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str
} else {
result =
throw_exception( c_string_to_lisp_string
- ( "Shouldn't happen: bad arg to multiply_ratio_ratio" ),
+ ( L"Shouldn't happen: bad arg to multiply_ratio_ratio" ),
frame_pointer );
}
@@ -286,7 +280,7 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer,
} else {
result =
throw_exception( c_string_to_lisp_string
- ( "Shouldn't happen: bad arg to multiply_integer_ratio" ),
+ ( L"Shouldn't happen: bad arg to multiply_integer_ratio" ),
frame_pointer );
}
@@ -329,7 +323,7 @@ struct cons_pointer make_ratio( struct cons_pointer frame_pointer,
} else {
result =
throw_exception( c_string_to_lisp_string
- ( "Dividend and divisor of a ratio must be integers" ),
+ ( L"Dividend and divisor of a ratio must be integers" ),
frame_pointer );
}
debug_dump_object( result, DEBUG_ARITH );
diff --git a/src/debug.c b/src/debug.c
index 27f7634..657998f 100644
--- a/src/debug.c
+++ b/src/debug.c
@@ -8,6 +8,7 @@
*/
#include <ctype.h>
+#include <stdarg.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
@@ -35,11 +36,27 @@ int verbosity = 0;
void debug_print( wchar_t *message, int level ) {
#ifdef DEBUG
if ( level & verbosity ) {
+ fwide( stderr, 1 );
fputws( message, stderr );
}
#endif
}
+/**
+ * `wprintf` adapted for the debug logging system. Print to stderr only
+ * `verbosity` matches `level`. All other arguments as for `wprintf`.
+ */
+void debug_printf( int level, wchar_t * format, ...) {
+ #ifdef DEBUG
+ if ( level & verbosity ) {
+ fwide( stderr, 1 );
+ va_list(args);
+ va_start(args, format);
+ vfwprintf(stderr, format, args);
+ }
+ #endif
+}
+
/**
* print the object indicated by this `pointer` to stderr, if `verbosity`
* matches `level`.`verbosity is a set of flags, see debug_print.h; so you can
@@ -48,6 +65,7 @@ void debug_print( wchar_t *message, int level ) {
void debug_print_object( struct cons_pointer pointer, int level ) {
#ifdef DEBUG
if ( level & verbosity ) {
+ fwide( stderr, 1 );
print( stderr, pointer );
}
#endif
@@ -59,6 +77,7 @@ void debug_print_object( struct cons_pointer pointer, int level ) {
void debug_dump_object( struct cons_pointer pointer, int level ) {
#ifdef DEBUG
if ( level & verbosity ) {
+ fwide( stderr, 1 );
dump_object( stderr, pointer );
}
#endif
diff --git a/src/debug.h b/src/debug.h
index 9c0448b..10d07c3 100644
--- a/src/debug.h
+++ b/src/debug.h
@@ -20,9 +20,13 @@
#define DEBUG_LAMBDA 16
#define DEBUG_BOOTSTRAP 32
#define DEBUG_IO 64
+#define DEBUG_REPL 128
extern int verbosity;
+
void debug_print( wchar_t *message, int level );
+void debug_printf( int level, wchar_t * format, ...);
void debug_print_object( struct cons_pointer pointer, int level );
void debug_dump_object( struct cons_pointer pointer, int level );
+
#endif
diff --git a/src/init.c b/src/init.c
index bb722ae..d81aa00 100644
--- a/src/init.c
+++ b/src/init.c
@@ -27,14 +27,14 @@
// extern char *optarg; /* defined in unistd.h */
-void bind_function( char *name, struct cons_pointer ( *executable )
+void bind_function( wchar_t *name, struct cons_pointer ( *executable )
( struct stack_frame *,
struct cons_pointer, struct cons_pointer ) ) {
deep_bind( c_string_to_lisp_symbol( name ),
make_function( NIL, executable ) );
}
-void bind_special( char *name, struct cons_pointer ( *executable )
+void bind_special( wchar_t *name, struct cons_pointer ( *executable )
( struct stack_frame *,
struct cons_pointer, struct cons_pointer ) ) {
deep_bind( c_string_to_lisp_symbol( name ),
@@ -52,7 +52,7 @@ int main( int argc, char *argv[] ) {
bool dump_at_end = false;
bool show_prompt = false;
- while ( ( option = getopt( argc, argv, "pdcv:" ) ) != -1 ) {
+ while ( ( option = getopt( argc, argv, "cpdv:" ) ) != -1 ) {
switch ( option ) {
case 'c':
print_use_colours = true;
@@ -65,6 +65,7 @@ int main( int argc, char *argv[] ) {
break;
case 'v':
verbosity = atoi( optarg );
+ break;
default:
fwprintf( stderr, L"Unexpected option %c\n", option );
break;
@@ -76,62 +77,61 @@ int main( int argc, char *argv[] ) {
L"Post scarcity software environment version %s\n\n",
VERSION );
}
-#ifdef DEBUG
- fputws( L"About to initialise cons pages\n", stderr );
-#endif
+
+ debug_print( L"About to initialise cons pages\n", DEBUG_BOOTSTRAP );
+
initialise_cons_pages( );
-#ifdef DEBUG
- fputws( L"Initialised cons pages, about to bind\n", stderr );
-#endif
+ debug_print( L"Initialised cons pages, about to bind\n", DEBUG_BOOTSTRAP );
/*
* privileged variables (keywords)
*/
- deep_bind( c_string_to_lisp_symbol( "nil" ), NIL );
- deep_bind( c_string_to_lisp_symbol( "t" ), TRUE );
+ deep_bind( c_string_to_lisp_symbol( L"nil" ), NIL );
+ deep_bind( c_string_to_lisp_symbol( L"t" ), TRUE );
/*
* primitive function operations
*/
- bind_function( "add", &lisp_add );
- bind_function( "apply", &lisp_apply );
- bind_function( "assoc", &lisp_assoc );
- bind_function( "car", &lisp_car );
- bind_function( "cdr", &lisp_cdr );
- bind_function( "cons", &lisp_cons );
- bind_function( "divide", &lisp_divide );
- bind_function( "eq", &lisp_eq );
- bind_function( "equal", &lisp_equal );
- bind_function( "eval", &lisp_eval );
- bind_function( "exception", &lisp_exception );
- bind_function( "multiply", &lisp_multiply );
- bind_function( "read", &lisp_read );
- bind_function( "oblist", &lisp_oblist );
- bind_function( "print", &lisp_print );
- bind_function( "progn", &lisp_progn );
- bind_function( "reverse", &lisp_reverse );
- bind_function( "set", &lisp_set );
- bind_function( "subtract", &lisp_subtract );
- bind_function( "throw", &lisp_exception );
- bind_function( "type", &lisp_type );
+ bind_function( L"add", &lisp_add );
+ bind_function( L"apply", &lisp_apply );
+ bind_function( L"assoc", &lisp_assoc );
+ bind_function( L"car", &lisp_car );
+ bind_function( L"cdr", &lisp_cdr );
+ bind_function( L"cons", &lisp_cons );
+ bind_function( L"divide", &lisp_divide );
+ bind_function( L"eq", &lisp_eq );
+ bind_function( L"equal", &lisp_equal );
+ bind_function( L"eval", &lisp_eval );
+ bind_function( L"exception", &lisp_exception );
+ bind_function( L"multiply", &lisp_multiply );
+ bind_function( L"read", &lisp_read );
+ bind_function( L"oblist", &lisp_oblist );
+ bind_function( L"print", &lisp_print );
+ bind_function( L"progn", &lisp_progn );
+ bind_function( L"reverse", &lisp_reverse );
+ bind_function( L"set", &lisp_set );
+ bind_function( L"subtract", &lisp_subtract );
+ bind_function( L"throw", &lisp_exception );
+ bind_function( L"type", &lisp_type );
- bind_function( "+", &lisp_add );
- bind_function( "*", &lisp_multiply );
- bind_function( "-", &lisp_subtract );
- bind_function( "/", &lisp_divide );
- bind_function( "=", &lisp_equal );
+ bind_function( L"+", &lisp_add );
+ bind_function( L"*", &lisp_multiply );
+ bind_function( L"-", &lisp_subtract );
+ bind_function( L"/", &lisp_divide );
+ bind_function( L"=", &lisp_equal );
/*
* primitive special forms
*/
- bind_special( "cond", &lisp_cond );
- bind_special( "lambda", &lisp_lambda );
- /* bind_special( "λ", &lisp_lambda ); */
- bind_special( "nlambda", &lisp_nlambda );
- bind_special( "progn", &lisp_progn );
- bind_special( "quote", &lisp_quote );
- bind_special( "set!", &lisp_set_shriek );
+ bind_special( L"cond", &lisp_cond );
+ bind_special( L"lambda", &lisp_lambda );
+ // bind_special( L"λ", &lisp_lambda );
+ bind_special( L"nlambda", &lisp_nlambda );
+ // bind_special( L"nλ", &lisp_nlambda );
+ bind_special( L"progn", &lisp_progn );
+ bind_special( L"quote", &lisp_quote );
+ bind_special( L"set!", &lisp_set_shriek );
repl( stdin, stdout, stderr, show_prompt );
diff --git a/src/memory/conspage.c b/src/memory/conspage.c
index 75bcdc8..cf87028 100644
--- a/src/memory/conspage.c
+++ b/src/memory/conspage.c
@@ -18,6 +18,7 @@
#include "consspaceobject.h"
#include "conspage.h"
+#include "debug.h"
#include "dump.h"
/**
@@ -65,7 +66,7 @@ void make_cons_page( ) {
cell->count = MAXREFERENCE;
cell->payload.free.car = NIL;
cell->payload.free.cdr = NIL;
- fwprintf( stderr, L"Allocated special cell NIL\n" );
+ debug_printf( DEBUG_ALLOC, L"Allocated special cell NIL\n" );
break;
case 1:
/*
@@ -79,7 +80,7 @@ void make_cons_page( ) {
cell->payload.free.cdr = ( struct cons_pointer ) {
0, 1
};
- fwprintf( stderr, L"Allocated special cell T\n" );
+ debug_printf( DEBUG_ALLOC, L"Allocated special cell T\n" );
break;
}
} else {
@@ -96,7 +97,7 @@ void make_cons_page( ) {
initialised_cons_pages++;
} else {
- fwprintf( stderr,
+ debug_printf( DEBUG_ALLOC,
L"FATAL: Failed to allocate memory for cons page %d\n",
initialised_cons_pages );
exit( 1 );
@@ -128,10 +129,8 @@ void dump_pages( FILE * output ) {
void free_cell( struct cons_pointer pointer ) {
struct cons_space_object *cell = &pointer2cell( pointer );
-#ifdef DEBUG
- fwprintf( stderr, L"Freeing cell " );
- dump_object( stderr, pointer );
-#endif
+ debug_printf( DEBUG_ALLOC, L"Freeing cell " );
+ debug_dump_object( pointer, DEBUG_ALLOC );
switch ( cell->tag.value ) {
/* for all the types of cons-space object which point to other
@@ -165,10 +164,8 @@ void free_cell( struct cons_pointer pointer ) {
case VECTORPOINTTV:
/* for vector space pointers, free the actual vector-space
* object. Dangerous! */
-#ifdef DEBUG
- fwprintf( stderr, L"About to free vector-space object at %ld\n",
+ debug_printf( DEBUG_ALLOC, L"About to free vector-space object at %ld\n",
cell->payload.vectorp.address );
-#endif
//free( ( void * ) cell->payload.vectorp.address );
break;
@@ -181,12 +178,12 @@ void free_cell( struct cons_pointer pointer ) {
cell->payload.free.cdr = freelist;
freelist = pointer;
} else {
- fwprintf( stderr,
+ debug_printf( DEBUG_ALLOC,
L"ERROR: Attempt to free cell with %d dangling references at page %d, offset %d\n",
cell->count, pointer.page, pointer.offset );
}
} else {
- fwprintf( stderr,
+ debug_printf( DEBUG_ALLOC,
L"ERROR: Attempt to free cell which is already FREE at page %d, offset %d\n",
pointer.page, pointer.offset );
}
@@ -218,13 +215,11 @@ struct cons_pointer allocate_cell( char *tag ) {
cell->payload.cons.car = NIL;
cell->payload.cons.cdr = NIL;
-#ifdef DEBUG
- fwprintf( stderr,
+ debug_printf( DEBUG_ALLOC,
L"Allocated cell of type '%s' at %d, %d \n", tag,
result.page, result.offset );
-#endif
} else {
- fwprintf( stderr, L"WARNING: Allocating non-free cell!" );
+ debug_printf( DEBUG_ALLOC, L"WARNING: Allocating non-free cell!" );
}
}
@@ -243,7 +238,7 @@ void initialise_cons_pages( ) {
make_cons_page( );
conspageinitihasbeencalled = true;
} else {
- fwprintf( stderr,
+ debug_printf( DEBUG_ALLOC,
L"WARNING: initialise_cons_pages() called a second or subsequent time\n" );
}
}
diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c
index acca2a8..f5cc8b8 100644
--- a/src/memory/consspaceobject.c
+++ b/src/memory/consspaceobject.c
@@ -20,6 +20,7 @@
#include "conspage.h"
#include "consspaceobject.h"
+#include "debug.h"
#include "print.h"
#include "stack.h"
@@ -178,11 +179,13 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) {
cell->payload.string.character = c;
cell->payload.string.cdr.page = tail.page;
/* TODO: There's a problem here. Sometimes the offsets on
- * strings are quite massively off. */
+ * strings are quite massively off. Fix is probably
+ * cell->payload.string.cdr = tsil */
cell->payload.string.cdr.offset = tail.offset;
} else {
- fwprintf( stderr,
- L"Warning: only NIL and %s can be appended to %s\n",
+ // TODO: should throw an exception!
+ debug_printf( DEBUG_ALLOC,
+ L"Warning: only NIL and %s can be prepended to %s\n",
tag, tag );
}
@@ -249,26 +252,26 @@ struct cons_pointer make_write_stream( FILE * output ) {
}
/**
- * Return a lisp string representation of this old skool ASCII string.
+ * Return a lisp string representation of this wide character string.
*/
-struct cons_pointer c_string_to_lisp_string( char *string ) {
+struct cons_pointer c_string_to_lisp_string( wchar_t *string ) {
struct cons_pointer result = NIL;
- for ( int i = strlen( string ); i > 0; i-- ) {
- result = make_string( ( wint_t ) string[i - 1], result );
+ for ( int i = wcslen( string ); i > 0; i-- ) {
+ result = make_string( string[i - 1], result );
}
return result;
}
/**
- * Return a lisp symbol representation of this old skool ASCII string.
+ * Return a lisp symbol representation of this wide character string.
*/
-struct cons_pointer c_string_to_lisp_symbol( char *symbol ) {
+struct cons_pointer c_string_to_lisp_symbol( wchar_t *symbol ) {
struct cons_pointer result = NIL;
- for ( int i = strlen( symbol ); i > 0; i-- ) {
- result = make_symbol( ( wint_t ) symbol[i - 1], result );
+ for ( int i = wcslen( symbol ); i > 0; i-- ) {
+ result = make_symbol( symbol[i - 1], result );
}
return result;
diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h
index 47bbed0..523fdaa 100644
--- a/src/memory/consspaceobject.h
+++ b/src/memory/consspaceobject.h
@@ -582,11 +582,11 @@ struct cons_pointer make_write_stream( FILE * output );
/**
* Return a lisp string representation of this old skool ASCII string.
*/
-struct cons_pointer c_string_to_lisp_string( char *string );
+struct cons_pointer c_string_to_lisp_string( wchar_t *string );
/**
* Return a lisp symbol representation of this old skool ASCII string.
*/
-struct cons_pointer c_string_to_lisp_symbol( char *symbol );
+struct cons_pointer c_string_to_lisp_symbol( wchar_t *symbol );
#endif
diff --git a/src/memory/dump.c b/src/memory/dump.c
index e0c2bbc..3129761 100644
--- a/src/memory/dump.c
+++ b/src/memory/dump.c
@@ -55,11 +55,8 @@ void dump_string_cell( FILE * output, wchar_t *prefix,
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],
+ L"\t%4.4s (%d) at page %d, offset %d count %u\n",
+ cell.tag.bytes,
cell.tag.value, pointer.page, pointer.offset, cell.count );
switch ( cell.tag.value ) {
@@ -91,6 +88,8 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
fwprintf( output, L";\n\t\t\tbody: " );
print( output, cell.payload.lambda.body );
break;
+ case NILTV:
+ break;
case RATIOTV:
fwprintf( output,
L"\t\tRational cell: value %ld/%ld, count %u\n",
@@ -101,6 +100,7 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
break;
case READTV:
fwprintf( output, L"\t\tInput stream\n" );
+ break;
case REALTV:
fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n",
cell.payload.real.value, cell.count );
@@ -111,26 +111,28 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
case SYMBOLTV:
dump_string_cell( output, L"Symbol", pointer );
break;
+ case TRUETV:
+ break;
case VECTORPOINTTV:{
fwprintf( output,
L"\t\tPointer to vector-space object at %p\n",
cell.payload.vectorp.address );
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.bytes, vso->header.size );
+ L"\t\tVector space object of type %4.4s (%d), payload size %d bytes\n",
+ &vso->header.tag.bytes, vso->header.tag.value, vso->header.size );
+ if (stackframep(vso)) {
+ dump_frame(output, pointer);
+ }
switch ( vso->header.tag.value ) {
case STACKFRAMETV:
dump_frame( output, pointer );
break;
- default:
- fputws( L"(Unknown vector type)\n", output );
- break;
}
}
break;
- default:
- fputws( L"(Unknown cons space type)\n", output );
+ case WRITETV:
+ fwprintf( output, L"\t\tOutput stream\n" );
break;
}
}
diff --git a/src/memory/stack.c b/src/memory/stack.c
index 069b1ed..a167244 100644
--- a/src/memory/stack.c
+++ b/src/memory/stack.c
@@ -32,24 +32,15 @@
*/
struct stack_frame *get_stack_frame( struct cons_pointer pointer ) {
struct stack_frame *result = NULL;
- debug_print
- ( L"get_stack_frame: about to get a pointer to the vector space object\n",
- DEBUG_ALLOC );
struct vector_space_object *vso =
pointer2cell( pointer ).payload.vectorp.address;
- debug_print( L"get_stack_frame: got a pointer, about to test it\n",
- DEBUG_ALLOC );
if ( vectorpointp( pointer ) && stackframep( vso ) ) {
- debug_print
- ( L"get_stack_frame: pointer is good, about to set the result\n",
- DEBUG_ALLOC );
-
result = ( struct stack_frame * ) &( vso->payload );
- fwprintf( stderr, L"get_stack_frame: all good, returning %p\n",
+ debug_printf( DEBUG_STACK, L"get_stack_frame: all good, returning %p\n",
result );
} else {
- debug_print( L"get_stack_frame: fail, returning NULL\n", DEBUG_ALLOC );
+ debug_print( L"get_stack_frame: fail, returning NULL\n", DEBUG_STACK );
}
return result;
@@ -62,31 +53,31 @@ struct stack_frame *get_stack_frame( struct cons_pointer pointer ) {
* @return the new frame, or NULL if memory is exhausted.
*/
struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
- debug_print( L"Entering make_empty_frame\n", DEBUG_ALLOC );
+ debug_print( L"Entering make_empty_frame\n", DEBUG_STACK );
struct cons_pointer result =
make_vso( STACKFRAMETAG, sizeof( struct stack_frame ) );
- debug_dump_object( result, DEBUG_ALLOC );
+ debug_dump_object( result, DEBUG_STACK );
- fwprintf( stderr,
+ debug_printf( DEBUG_STACK,
L"make_empty_frame: got vector_space_object with size %lu, tag %4.4s\n",
pointer_to_vso( result )->header.size,
&pointer_to_vso( result )->header.tag.bytes );
if ( !nilp( result ) ) {
debug_print( L"make_empty_frame: about to call get_stack_frame\n",
- DEBUG_ALLOC );
+ DEBUG_STACK );
struct stack_frame *frame = get_stack_frame( result );
/*
* TODO: later, pop a frame off a free-list of stack frames
*/
- fwprintf( stderr,
+ debug_printf( DEBUG_STACK,
L"make_empty_frame: about to set previous to %4.4s\n",
&pointer2cell( previous ).tag.bytes );
frame->previous = previous;
debug_print( L"make_empty_frame: about to call inc_ref\n",
- DEBUG_ALLOC );
+ DEBUG_STACK );
inc_ref( previous );
/*
@@ -98,12 +89,12 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
frame->args = 0;
debug_print( L"make_empty_frame: about to initialise arg registers\n",
- DEBUG_ALLOC );
+ DEBUG_STACK );
for ( int i = 0; i < args_in_frame; i++ ) {
set_reg( frame, i, NIL );
}
}
- debug_print( L"Leaving make_empty_frame\n", DEBUG_ALLOC );
+ debug_print( L"Leaving make_empty_frame\n", DEBUG_STACK );
return result;
}
@@ -119,13 +110,13 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
struct cons_pointer make_stack_frame( struct cons_pointer previous,
struct cons_pointer args,
struct cons_pointer env ) {
- debug_print( L"Entering make_stack_frame\n", DEBUG_ALLOC );
+ debug_print( L"Entering make_stack_frame\n", DEBUG_STACK );
struct cons_pointer result = make_empty_frame( previous );
if ( nilp( result ) ) {
/* i.e. out of memory */
result =
- make_exception( c_string_to_lisp_string( "Memory exhausted." ),
+ make_exception( c_string_to_lisp_string( L"Memory exhausted." ),
previous );
} else {
struct stack_frame *frame = get_stack_frame( result );
@@ -149,11 +140,13 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
if ( nilp( arg_frame_pointer ) ) {
result =
make_exception( c_string_to_lisp_string
- ( "Memory exhausted." ), previous );
+ ( L"Memory exhausted." ), previous );
break;
} else {
struct stack_frame *arg_frame =
get_stack_frame( arg_frame_pointer );
+ debug_print( L"Setting argument 0 of arg_frame to ", DEBUG_STACK);
+ debug_print_object(cell.payload.cons.car, DEBUG_STACK);
set_reg( arg_frame, 0, cell.payload.cons.car );
struct cons_pointer val =
@@ -162,6 +155,8 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
result = val;
break;
} else {
+ debug_printf( DEBUG_STACK, L"Setting argument %d to ", frame->args);
+ debug_print_object(cell.payload.cons.car, DEBUG_STACK);
set_reg( frame, frame->args, val );
}
@@ -180,10 +175,10 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
inc_ref( more );
}
- debug_dump_object( result, DEBUG_ALLOC );
+ debug_dump_object( result, DEBUG_STACK );
}
}
- debug_print( L"Leaving make_stack_frame\n", DEBUG_ALLOC );
+ debug_print( L"Leaving make_stack_frame\n", DEBUG_STACK );
return result;
}
@@ -199,14 +194,14 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
struct cons_pointer make_special_frame( struct cons_pointer previous,
struct cons_pointer args,
struct cons_pointer env ) {
- debug_print( L"Entering make_special_frame\n", DEBUG_ALLOC );
+ debug_print( L"Entering make_special_frame\n", DEBUG_STACK );
struct cons_pointer result = make_empty_frame( previous );
if ( nilp( result ) ) {
/* i.e. out of memory */
result =
- make_exception( c_string_to_lisp_string( "Memory exhausted." ),
+ make_exception( c_string_to_lisp_string( L"Memory exhausted." ),
previous );
} else {
struct stack_frame *frame = get_stack_frame( result );
@@ -228,10 +223,10 @@ struct cons_pointer make_special_frame( struct cons_pointer previous,
inc_ref( args );
}
- debug_dump_object( result, DEBUG_ALLOC );
+ debug_dump_object( result, DEBUG_STACK );
}
}
- debug_print( L"Leaving make_special_frame\n", DEBUG_ALLOC );
+ debug_print( L"Leaving make_special_frame\n", DEBUG_STACK );
return result;
}
@@ -263,6 +258,7 @@ void dump_frame( FILE * output, struct cons_pointer frame_pointer ) {
struct stack_frame *frame = get_stack_frame( frame_pointer );
if ( frame != NULL ) {
+ fwprintf( output, L"Stack frame with %d arguments:\n", frame->args);
for ( int arg = 0; arg < frame->args; arg++ ) {
struct cons_space_object cell = pointer2cell( frame->arg[arg] );
@@ -274,16 +270,19 @@ void dump_frame( FILE * output, struct cons_pointer frame_pointer ) {
print( output, frame->arg[arg] );
fputws( L"\n", output );
}
+ if (!nilp(frame->more))
+ {
fputws( L"More: \t", output );
print( output, frame->more );
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" );
+ fputws( L"\n", output );
dump_stack_trace( output,
pointer2cell( pointer ).payload.exception.frame );
} else {
diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c
index 7dbe682..c30f120 100644
--- a/src/memory/vectorspace.c
+++ b/src/memory/vectorspace.c
@@ -21,7 +21,7 @@
#include "conspage.h"
#include "consspaceobject.h"
-#include "dump.h"
+#include "debug.h"
#include "vectorspace.h"
@@ -32,17 +32,17 @@
* vector-space object, NOT `VECTORPOINTTAG`.
*/
struct cons_pointer make_vec_pointer( struct vector_space_object *address ) {
- fputws( L"Entered make_vec_pointer\n", stderr );
+ debug_print( L"Entered make_vec_pointer\n", DEBUG_ALLOC );
struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG );
struct cons_space_object *cell = &pointer2cell( pointer );
- fwprintf( stderr,
+ debug_printf( DEBUG_ALLOC,
L"make_vec_pointer: tag written, about to set pointer address to %p\n",
address );
cell->payload.vectorp.address = address;
- fwprintf( stderr, L"make_vec_pointer: all good, returning pointer to %p\n",
+ debug_printf( DEBUG_ALLOC, L"make_vec_pointer: all good, returning pointer to %p\n",
cell->payload.vectorp.address );
- dump_object( stderr, pointer );
+ debug_dump_object( pointer, DEBUG_ALLOC );
return pointer;
}
@@ -55,41 +55,41 @@ struct cons_pointer make_vec_pointer( struct vector_space_object *address ) {
* Returns NIL if the vector could not be allocated due to memory exhaustion.
*/
struct cons_pointer make_vso( char *tag, uint64_t payload_size ) {
- fputws( L"Entered make_vso\n", stderr );
+ debug_print( L"Entered make_vso\n", DEBUG_ALLOC );
struct cons_pointer result = NIL;
int64_t total_size = sizeof( struct vector_space_header ) + payload_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 );
- fputws( L"make_vso: about to malloc\n", stderr );
+ debug_print( L"make_vso: about to malloc\n", DEBUG_ALLOC );
struct vector_space_object *vso = malloc( padded );
if ( vso != NULL ) {
- fwprintf( stderr,
+ debug_printf( DEBUG_ALLOC,
L"make_vso: about to write tag '%s' into vso at %p\n", tag,
vso );
strncpy( &vso->header.tag.bytes[0], tag, TAGLENGTH );
result = make_vec_pointer( vso );
- dump_object( stderr, result );
+ debug_dump_object( result, DEBUG_ALLOC );
vso->header.vecp = result;
// memcpy(vso->header.vecp, result, sizeof(struct cons_pointer));
vso->header.size = payload_size;
#ifdef DEBUG
- fwprintf( stderr,
+ debug_printf( DEBUG_ALLOC,
L"Allocated vector-space object of type %4.4s, total size %ld, payload size %ld, at address %p, payload address %p\n",
&vso->header.tag.bytes, total_size, vso->header.size, vso,
&vso->payload );
if ( padded != total_size ) {
- fwprintf( stderr, L"\t\tPadded from %d to %d\n",
+ debug_printf( DEBUG_ALLOC, L"\t\tPadded from %d to %d\n",
total_size, padded );
}
#endif
}
#ifdef DEBUG
- fwprintf( stderr, L"make_vso: all good, returning pointer to %p\n",
+ debug_printf( DEBUG_ALLOC, L"make_vso: all good, returning pointer to %p\n",
pointer2cell( result ).payload.vectorp.address );
#endif
diff --git a/src/ops/lispops.c b/src/ops/lispops.c
index da3bc82..43665e9 100644
--- a/src/ops/lispops.c
+++ b/src/ops/lispops.c
@@ -193,7 +193,7 @@ struct cons_pointer
eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer env ) {
struct cons_pointer result = NIL;
- fwprintf( stderr, L"eval_lambda called\n" );
+ debug_print( L"eval_lambda called\n", DEBUG_EVAL );
struct cons_pointer new_env = env;
struct cons_pointer names = cell.payload.lambda.args;
@@ -355,13 +355,12 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
break;
default:
{
- char *buffer = malloc( 1024 );
- memset( buffer, '\0', 1024 );
- sprintf( buffer,
- "Unexpected cell with tag %d (%c%c%c%c) in function position",
- fn_cell.tag.value, fn_cell.tag.bytes[0],
- fn_cell.tag.bytes[1], fn_cell.tag.bytes[2],
- fn_cell.tag.bytes[3] );
+ int bs = sizeof(wchar_t) * 1024;
+ wchar_t *buffer = malloc( bs );
+ memset( buffer, '\0', bs );
+ swprintf( buffer, bs,
+ L"Unexpected cell with tag %d (%4.4s) in function position",
+ fn_cell.tag.value, &fn_cell.tag.bytes[0] );
struct cons_pointer message =
c_string_to_lisp_string( buffer );
free( buffer );
@@ -380,13 +379,13 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
* @return As a Lisp string, the tag of the object which is at that pointer.
*/
struct cons_pointer c_type( struct cons_pointer pointer ) {
- char *buffer = malloc( TAGLENGTH + 1 );
- memset( buffer, 0, TAGLENGTH + 1 );
+ struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( pointer );
- strncpy( buffer, cell.tag.bytes, TAGLENGTH );
- struct cons_pointer result = c_string_to_lisp_string( buffer );
- free( buffer );
+ for (int i = TAGLENGTH; i >= 0; i--)
+ {
+ result = make_string((wchar_t)cell.tag.bytes[i], result);
+ }
return result;
}
@@ -408,14 +407,12 @@ struct cons_pointer c_type( struct cons_pointer pointer ) {
struct cons_pointer
lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
+ debug_print( L"Eval: ", DEBUG_EVAL );
+ debug_dump_object( frame_pointer, DEBUG_EVAL );
+
struct cons_pointer result = frame->arg[0];
struct cons_space_object cell = pointer2cell( frame->arg[0] );
- debug_print( L"Eval: ", DEBUG_EVAL );
-#ifdef DEBUG
- dump_frame( stderr, frame_pointer );
-#endif
-
switch ( cell.tag.value ) {
case CONSTV:
{
@@ -430,7 +427,7 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
if ( nilp( canonical ) ) {
struct cons_pointer message =
make_cons( c_string_to_lisp_string
- ( "Attempt to take value of unbound symbol." ),
+ ( L"Attempt to take value of unbound symbol." ),
frame->arg[0] );
result = throw_exception( message, frame_pointer );
} else {
@@ -522,7 +519,7 @@ lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer,
result =
make_exception( make_cons
( c_string_to_lisp_string
- ( "The first argument to `set!` is not a symbol: " ),
+ ( L"The first argument to `set` is not a symbol: " ),
make_cons( frame->arg[0], NIL ) ),
frame_pointer );
}
@@ -556,7 +553,7 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer,
result =
make_exception( make_cons
( c_string_to_lisp_string
- ( "The first argument to `set!` is not a symbol: " ),
+ ( L"The first argument to `set!` is not a symbol: " ),
make_cons( frame->arg[0], NIL ) ),
frame_pointer );
}
@@ -610,7 +607,7 @@ lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer,
result = make_string( cell.payload.string.character, NIL );
} else {
struct cons_pointer message =
- c_string_to_lisp_string( "Attempt to take CAR of non sequence" );
+ c_string_to_lisp_string( L"Attempt to take CAR of non sequence" );
result = throw_exception( message, frame_pointer );
}
@@ -635,7 +632,7 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer,
result = cell.payload.string.cdr;
} else {
struct cons_pointer message =
- c_string_to_lisp_string( "Attempt to take CDR of non sequence" );
+ c_string_to_lisp_string( L"Attempt to take CDR of non sequence" );
result = throw_exception( message, frame_pointer );
}
@@ -850,7 +847,7 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer,
done = true;
} else {
result = throw_exception( c_string_to_lisp_string
- ( "Arguments to `cond` must be lists" ),
+ ( L"Arguments to `cond` must be lists" ),
frame_pointer );
}
}
diff --git a/src/ops/print.c b/src/ops/print.c
index 99cd7f3..49adca7 100644
--- a/src/ops/print.c
+++ b/src/ops/print.c
@@ -37,7 +37,7 @@ int print_use_colours = 0;
void print_string_contents( FILE * output, struct cons_pointer pointer ) {
while ( stringp( pointer ) || symbolp( pointer ) ) {
struct cons_space_object *cell = &pointer2cell( pointer );
- wint_t c = cell->payload.string.character;
+ wchar_t c = cell->payload.string.character;
if ( c != '\0' ) {
fputwc( c, output );
@@ -131,7 +131,7 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
fwprintf( output, L"%ld%", cell.payload.integer.value );
break;
case LAMBDATV:
- print( output, make_cons( c_string_to_lisp_symbol( "lambda" ),
+ print( output, make_cons( c_string_to_lisp_symbol( L"lambda" ),
make_cons( cell.payload.lambda.args,
cell.payload.lambda.
body ) ) );
@@ -140,7 +140,7 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
fwprintf( output, L"nil" );
break;
case NLAMBDATV:
- print( output, make_cons( c_string_to_lisp_symbol( "nlambda" ),
+ print( output, make_cons( c_string_to_lisp_symbol( L"nlambda" ),
make_cons( cell.payload.lambda.args,
cell.payload.lambda.
body ) ) );
@@ -190,6 +190,9 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
case TRUETV:
fwprintf( output, L"t" );
break;
+ case WRITETV:
+ fwprintf( output, L"(Output stream)" );
+ break;
default:
fwprintf( stderr,
L"%sError: Unrecognised tag value %d (%c%c%c%c)\n",
diff --git a/src/ops/read.c b/src/ops/read.c
index e3cb480..a9b1ffe 100644
--- a/src/ops/read.c
+++ b/src/ops/read.c
@@ -49,7 +49,7 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial );
* quote reader macro in C (!)
*/
struct cons_pointer c_quote( struct cons_pointer arg ) {
- return make_cons( c_string_to_lisp_symbol( "quote" ),
+ return make_cons( c_string_to_lisp_symbol( L"quote" ),
make_cons( arg, NIL ) );
}
@@ -71,8 +71,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
if ( feof( input ) ) {
result =
- make_exception( c_string_to_lisp_string
- ( "End of file while reading" ), frame_pointer );
+ throw_exception( c_string_to_lisp_string
+ ( L"End of file while reading" ), frame_pointer );
} else {
switch ( c ) {
case ';':
@@ -81,7 +81,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
break;
case EOF:
result = throw_exception( c_string_to_lisp_string
- ( "End of input while reading" ),
+ ( L"End of input while reading" ),
frame_pointer );
break;
case '\'':
@@ -136,8 +136,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
result = read_symbol( input, c );
} else {
result =
- make_exception( make_cons( c_string_to_lisp_string
- ( "Unrecognised start of input character" ),
+ throw_exception( make_cons( c_string_to_lisp_string
+ ( L"Unrecognised start of input character" ),
make_string( c, NIL ) ),
frame_pointer );
}
@@ -170,23 +170,23 @@ struct cons_pointer read_number( struct stack_frame *frame,
if ( negative ) {
initial = fgetwc( input );
}
-#ifdef DEBUG
- fwprintf( stderr, L"read_number starting '%c' (%d)\n", initial, initial );
-#endif
+
+ debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial, initial );
+
for ( c = initial; iswdigit( c )
|| c == btowc( '.' ) || c == btowc( '/' ); c = fgetwc( input ) ) {
if ( c == btowc( '.' ) ) {
if ( seen_period || dividend != 0 ) {
- return make_exception( c_string_to_lisp_string
- ( "Malformed number: too many periods" ),
+ return throw_exception( c_string_to_lisp_string
+ ( L"Malformed number: too many periods" ),
frame_pointer );
} else {
seen_period = true;
}
} else if ( c == btowc( '/' ) ) {
if ( seen_period || dividend > 0 ) {
- return make_exception( c_string_to_lisp_string
- ( "Malformed number: dividend of rational must be integer" ),
+ return throw_exception( c_string_to_lisp_string
+ ( L"Malformed number: dividend of rational must be integer" ),
frame_pointer );
} else {
dividend = negative ? 0 - accumulator : accumulator;
@@ -195,11 +195,11 @@ struct cons_pointer read_number( struct stack_frame *frame,
}
} else {
accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' );
-#ifdef DEBUG
- fwprintf( stderr,
+
+ debug_printf( DEBUG_IO,
L"Added character %c, accumulator now %ld\n",
c, accumulator );
-#endif
+
if ( seen_period ) {
places_of_decimals++;
}
@@ -243,10 +243,8 @@ struct cons_pointer read_list( struct stack_frame *frame,
FILE * input, wint_t initial ) {
struct cons_pointer result = NIL;
if ( initial != ')' ) {
-#ifdef DEBUG
- fwprintf( stderr,
+ debug_printf( DEBUG_IO,
L"read_list starting '%C' (%d)\n", initial, initial );
-#endif
struct cons_pointer car =
read_continuation( frame, frame_pointer, input,
initial );
diff --git a/src/repl.c b/src/repl.c
index f0dcbfa..04cf33c 100644
--- a/src/repl.c
+++ b/src/repl.c
@@ -13,7 +13,7 @@
#include "conspage.h"
#include "consspaceobject.h"
-#include "dump.h"
+#include "debug.h"
#include "intern.h"
#include "lispops.h"
#include "read.h"
@@ -33,25 +33,17 @@
*/
struct cons_pointer repl_read( struct cons_pointer stream_pointer ) {
struct cons_pointer result = NIL;
- fputws( L"Entered repl_read\n", stderr );
- struct cons_pointer frame_pointer = make_empty_frame( NIL );
- fputws( L"repl_read: got stack_frame pointer\n", stderr );
- dump_object( stderr, frame_pointer );
+ debug_print( L"Entered repl_read\n", DEBUG_REPL );
+ struct cons_pointer frame_pointer = make_stack_frame( NIL, make_cons(stream_pointer, NIL), oblist );
+ debug_print( L"repl_read: got stack_frame pointer\n", DEBUG_REPL );
+ debug_dump_object( frame_pointer, DEBUG_REPL );
if ( !nilp( frame_pointer ) ) {
inc_ref( frame_pointer );
- struct stack_frame *frame = get_stack_frame( frame_pointer );
-
- if ( frame != NULL ) {
- fputws( L"repl_read: about to set register\n", stderr );
- set_reg( frame, 0, stream_pointer );
- fputws( L"repl_read: about to read\n", stderr );
- struct cons_pointer result =
- lisp_read( frame, frame_pointer, oblist );
- }
+ result = lisp_read( get_stack_frame( frame_pointer ), frame_pointer, oblist );
dec_ref( frame_pointer );
}
- fputws( L"repl_read: returning\n", stderr );
- dump_object( stderr, result );
+ debug_print( L"repl_read: returning\n", DEBUG_REPL );
+ debug_dump_object( result, DEBUG_REPL );
return result;
}
@@ -60,22 +52,18 @@ struct cons_pointer repl_read( struct cons_pointer stream_pointer ) {
* Dummy up a Lisp eval call with its own stack frame.
*/
struct cons_pointer repl_eval( struct cons_pointer input ) {
- fputws( L"Entered repl_eval\n", stderr );
+ debug_print( L"Entered repl_eval\n", DEBUG_REPL );
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 );
+ struct cons_pointer frame_pointer = make_stack_frame( NIL, make_cons( input, NIL ), oblist);
- if ( frame != NULL ) {
- set_reg( frame, 0, input );
- result = lisp_eval( frame, frame_pointer, oblist );
- }
+ if ( !nilp( frame_pointer ) ) {
+ inc_ref(frame_pointer);
+ result = lisp_eval( get_stack_frame( frame_pointer ), frame_pointer, oblist );
dec_ref( frame_pointer );
}
- fputws( L"repl_eval: returning\n", stderr );
- dump_object( stderr, result );
+ debug_print( L"repl_eval: returning\n", DEBUG_REPL );
+ debug_dump_object( result, DEBUG_REPL );
return result;
}
@@ -85,20 +73,17 @@ struct cons_pointer repl_eval( struct cons_pointer input ) {
*/
struct cons_pointer repl_print( struct cons_pointer stream_pointer,
struct cons_pointer value ) {
-
+ debug_print( L"Entered repl_print\n", DEBUG_REPL );
+ debug_dump_object( value, DEBUG_REPL );
struct cons_pointer result = NIL;
- struct cons_pointer frame_pointer = make_empty_frame( NIL );
+ struct cons_pointer frame_pointer = make_stack_frame( NIL, make_cons( value, NIL ), oblist);
if ( !nilp( frame_pointer ) ) {
- struct stack_frame *frame = get_stack_frame( frame_pointer );
-
- if ( frame != NULL ) {
- set_reg( frame, 0, value );
- set_reg( frame, 1, stream_pointer );
- result = lisp_print( frame, frame_pointer, oblist );
- free_stack_frame( frame );
- }
+ inc_ref(frame_pointer);
+ result = lisp_print( get_stack_frame( frame_pointer ), frame_pointer, oblist );
dec_ref( frame_pointer );
}
+ debug_print( L"repl_print: returning\n", DEBUG_REPL );
+ debug_dump_object( result, DEBUG_REPL );
return result;
}
@@ -113,7 +98,7 @@ struct cons_pointer repl_print( struct cons_pointer stream_pointer,
void
repl( FILE * in_stream, FILE * out_stream, FILE * error_stream,
bool show_prompt ) {
- fputws( L"Entered repl\n", stderr );
+ debug_print( L"Entered repl\n", DEBUG_REPL );
struct cons_pointer input_stream = make_read_stream( in_stream );
inc_ref( input_stream );
@@ -138,4 +123,5 @@ repl( FILE * in_stream, FILE * out_stream, FILE * error_stream,
}
dec_ref( input );
}
+ debug_print( L"Leaving repl\n", DEBUG_REPL );
}
diff --git a/utils_src/debugflags/debugflags b/utils_src/debugflags/debugflags
new file mode 100755
index 0000000000000000000000000000000000000000..49b2a0854c3ae04e0551caba08f8019ff3a2cd8c
GIT binary patch
literal 8520
zcmeHN-)kII6u#56HHm4nc`(FSb^2qa?L(raw8dK3NiuXow#}MsM8$H+{%Etf*@WF0
zZ5|dDqTnzM?33V&{tJcTi%1D1m^>8hLmz_V!G|ali5Nj-k&yK}Gk22NP4vwN;T|}1
z&pF?nGv|JH2JYUw-~aXN?sJSOEsRx;FvdEei$@vzl&P>7dl70tIZtRe_4oC$QHnN-
z(&!%QQJyt)<UFarn{4dj-5+U;G2x>&c1$Ss;M~mKH_7s)IbZAq1_S7kD2jXxXJ3x8
z%DzMSN~V=6?S-22{c+OI*CBcYesDvp$ah=>{Cs>Wo1e`V5o^vz1XF3}f&}o1_dPjK
zU%F%#bA@}NLvy}!BHsgnlOL9b+yFSY3LobR8J;WLo$>s}`FJSu(VUZz-<-oo{433?
z3*~%BOKKqm^XE-LFt1H5%`4uyz1*A^^1L)Rotnw>S+n?$`GPd`e$f4a5dYyiInPi2
zTfPYHr}~0?<cIT7ec|_J|2v2e-yYG2hJ$xlZ5k(h62lujW0XgjUi=Kcv)9Q|8EZw;
zina%BAgby?EQU6QAdQLe&s4^|ckHzPJwA_E0vZ;oKhSVIY`dz+6Ar@0YfdFGde8f<
zQn5duOZ8{w@)`IfFF~n}l_OWa`t#bAN8dcCeDK@x^5>TjQ=tl!oox4%Y>&&1FO-Y0
z1CFW7d5oX(RPkMgg`Rs2N*Im#*y;x8SN3Z`J>zpFGdtZk(1*HmDRhFo2BrKJ)#vkq
z@QE)ek^#wpWI!??8ITM}2L1~MCJg&0V}47u%R9DJGwg}&6@7~y<XAgrt=jx9>-^+Z
zxW>YbudyyN9BbQ|s6AwE86LXQTFKU3N8d8$m(@E<B42Dp-=Qpa896P=NgdJax?byC
zc*D!2ZyV`bTZZ%2s(X<F3pehep=6ee2b_ZQ7z*Hp_s}|J*Vcb@N9y(ZV_IP$d^-rQ
zyO$|U3tof=z3{rS;^?kjUb9!+ZbE6f3X~r1l-C6M3}|f^C@sQ(zT%<J1o{-{4}_{d
zdcs4W3iJukZwZb0XdR7Hej?CSpkESN@zGyAbXB0sKr28o>U9FFW#v2D+HkB54E;1B
zw!R3u<`)%P-`ZS4Pe<PY#j!g})q1oWb=0FhxW*S=R?ukU_2}=ot2%`X+x!{houVb_
z<~pplwrEK`AI)4)rzg$yRJL@zoyD^sW%Ft@^JY66(g!APaxESo9TfI>QX3oz;$y=}
zL)iK|T3ncM?bg7MCY*uM(d2k?OiKuVcvKi;dLqu+qM6{q?cO^36x9d`w=|>lTlX?r
zQu>`rLN=|%J8);jU!_wRLq1$0;`d*#Xb<ltqmlv1fMh^2AQ_MhNCqSWk^#wpWI!??
z8ITP8pBU&m6B(m=yJB?M=N*Rg6wZfnc>Q*fRar6872}iUOpfdx*t0l{Ht)g{qHvtg
zxA5sHp1q$<TV@t#-;;EEA9hO8AM!kHl(0+Fleq%BO1l&-Y_S)YDxE0ezXrVtuO*~Y
zp-m)zbE4bx{XGrZtT-!tIyWSr&iT;p?PK&e`B$5K+5@5OE&4A3Bo_E8PMQza&cn5H
NuXdk=VE6~f`Wu3Prndk9
literal 0
HcmV?d00001
diff --git a/utils_src/debugflags/debugflags.c b/utils_src/debugflags/debugflags.c
new file mode 100644
index 0000000..a9850d1
--- /dev/null
+++ b/utils_src/debugflags/debugflags.c
@@ -0,0 +1,43 @@
+#include <inttypes.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+
+#define DEBUG_ALLOC 1
+#define DEBUG_STACK 2
+#define DEBUG_ARITH 4
+#define DEBUG_EVAL 8
+#define DEBUG_LAMBDA 16
+#define DEBUG_BOOTSTRAP 32
+#define DEBUG_IO 64
+#define DEBUG_REPL 128
+
+int check_level( int v, int level, char * name) {
+ int result = 0;
+ if (v & level) {
+ printf("\t\t%s (%d) matches;\n", name, level);
+ result = 1;
+ }
+
+ return result;
+}
+
+int main( int argc, char *argv[] ) {
+
+ for (int i = 1; i < argc; i++) {
+ int v = atoi(argv[i]);
+
+ printf("Level %d:\n", v);
+ int matches = check_level(v, DEBUG_ALLOC, "DEBUG_ALLOC") +
+ check_level(v, DEBUG_STACK, "DEBUG_STACK") +
+ check_level(v, DEBUG_ARITH, "DEBUG_ARITH") +
+ check_level(v, DEBUG_EVAL, "DEBUG_EVAL") +
+ check_level(v, DEBUG_LAMBDA, "DEBUG_LAMBDA") +
+ check_level(v, DEBUG_BOOTSTRAP, "DEBUG_BOOTSTRAP") +
+ check_level(v, DEBUG_IO, "DEBUG_IO") +
+ check_level(v, DEBUG_REPL, "DEBUG_REPL");
+ printf("\t%d matches\n", matches);
+ }
+}
From 96dad29f91480736011f9f5ff31174f3c5e4d698 Mon Sep 17 00:00:00 2001
From: Simon Brooke <simon@journeyman.cc>
Date: Fri, 28 Dec 2018 21:21:11 +0000
Subject: [PATCH 5/6] Good news: only one test failing. Bad news: it's nlambda.
---
src/debug.c | 15 +++++++++
src/debug.h | 1 +
src/memory/dump.c | 4 ++-
src/memory/stack.c | 76 ++++++++++++++++++----------------------------
src/memory/stack.h | 4 ++-
src/ops/intern.c | 6 ++++
src/ops/lispops.c | 42 +++++++++++--------------
src/repl.c | 22 ++++----------
8 files changed, 80 insertions(+), 90 deletions(-)
diff --git a/src/debug.c b/src/debug.c
index 657998f..b21f4af 100644
--- a/src/debug.c
+++ b/src/debug.c
@@ -42,6 +42,21 @@ void debug_print( wchar_t *message, int level ) {
#endif
}
+/**
+ * print a line feed to stderr, if `verbosity` matches `level`.
+ * `verbosity is a set of flags, see debug_print.h; so you can
+ * turn debugging on for only one part of the system.
+ */
+void debug_println( int level ) {
+#ifdef DEBUG
+ if ( level & verbosity ) {
+ fwide( stderr, 1 );
+ fputws( L"\n", stderr );
+ }
+#endif
+}
+
+
/**
* `wprintf` adapted for the debug logging system. Print to stderr only
* `verbosity` matches `level`. All other arguments as for `wprintf`.
diff --git a/src/debug.h b/src/debug.h
index 10d07c3..22f5591 100644
--- a/src/debug.h
+++ b/src/debug.h
@@ -25,6 +25,7 @@
extern int verbosity;
void debug_print( wchar_t *message, int level );
+void debug_println( int level );
void debug_printf( int level, wchar_t * format, ...);
void debug_print_object( struct cons_pointer pointer, int level );
void debug_dump_object( struct cons_pointer pointer, int level );
diff --git a/src/memory/dump.c b/src/memory/dump.c
index 3129761..e88332a 100644
--- a/src/memory/dump.c
+++ b/src/memory/dump.c
@@ -62,11 +62,13 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
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",
+ L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u :",
cell.payload.cons.car.page,
cell.payload.cons.car.offset,
cell.payload.cons.cdr.page,
cell.payload.cons.cdr.offset, cell.count );
+ print( output, pointer);
+ fputws( L"\n", output);
break;
case EXCEPTIONTV:
fwprintf( output, L"\t\tException cell: " );
diff --git a/src/memory/stack.c b/src/memory/stack.c
index a167244..f91d896 100644
--- a/src/memory/stack.c
+++ b/src/memory/stack.c
@@ -26,6 +26,18 @@
#include "stack.h"
#include "vectorspace.h"
+void set_reg(struct stack_frame * frame, int reg, struct cons_pointer value) {
+ debug_printf(DEBUG_STACK, L"Setting register %d to ", reg);
+ debug_print_object(value, DEBUG_STACK);
+ debug_println(DEBUG_STACK);
+ frame->arg[reg++] = value;
+ inc_ref(value);
+ if (reg > frame->args) {
+ frame->args = reg;
+ }
+}
+
+
/**
* get the actual stackframe object from this `pointer`, or NULL if
* `pointer` is not a stackframe pointer.
@@ -53,32 +65,24 @@ struct stack_frame *get_stack_frame( struct cons_pointer pointer ) {
* @return the new frame, or NULL if memory is exhausted.
*/
struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
- debug_print( L"Entering make_empty_frame\n", DEBUG_STACK );
+ debug_print( L"Entering make_empty_frame\n", DEBUG_ALLOC );
struct cons_pointer result =
make_vso( STACKFRAMETAG, sizeof( struct stack_frame ) );
- debug_dump_object( result, DEBUG_STACK );
+ debug_dump_object( result, DEBUG_ALLOC );
- debug_printf( DEBUG_STACK,
- L"make_empty_frame: got vector_space_object with size %lu, tag %4.4s\n",
- pointer_to_vso( result )->header.size,
- &pointer_to_vso( result )->header.tag.bytes );
+// debug_printf( DEBUG_STACK,
+// L"make_empty_frame: got vector_space_object with size %lu, tag %4.4s\n",
+// pointer_to_vso( result )->header.size,
+// &pointer_to_vso( result )->header.tag.bytes );
if ( !nilp( result ) ) {
- debug_print( L"make_empty_frame: about to call get_stack_frame\n",
- DEBUG_STACK );
struct stack_frame *frame = get_stack_frame( result );
/*
* TODO: later, pop a frame off a free-list of stack frames
*/
- debug_printf( DEBUG_STACK,
- L"make_empty_frame: about to set previous to %4.4s\n",
- &pointer2cell( previous ).tag.bytes );
frame->previous = previous;
- debug_print( L"make_empty_frame: about to call inc_ref\n",
- DEBUG_STACK );
- inc_ref( previous );
/*
* clearing the frame with memset would probably be slightly quicker, but
@@ -88,13 +92,12 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
frame->function = NIL;
frame->args = 0;
- debug_print( L"make_empty_frame: about to initialise arg registers\n",
- DEBUG_STACK );
for ( int i = 0; i < args_in_frame; i++ ) {
- set_reg( frame, i, NIL );
+ frame->arg[i] = NIL;
}
}
- debug_print( L"Leaving make_empty_frame\n", DEBUG_STACK );
+ debug_print( L"Leaving make_empty_frame\n", DEBUG_ALLOC );
+ debug_dump_object( result, DEBUG_ALLOC);
return result;
}
@@ -121,8 +124,7 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
} else {
struct stack_frame *frame = get_stack_frame( result );
- for ( frame->args = 0; frame->args < args_in_frame && consp( args );
- frame->args++ ) {
+ while ( frame->args < args_in_frame && consp( args )) {
/* iterate down the arg list filling in the arg slots in the
* frame. When there are no more slots, if there are still args,
* stash them on more */
@@ -134,23 +136,7 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
* processor to be evaled in parallel; but see notes here:
* https://github.com/simon-brooke/post-scarcity/wiki/parallelism
*/
- struct cons_pointer arg_frame_pointer = make_empty_frame( result );
- inc_ref( arg_frame_pointer );
-
- if ( nilp( arg_frame_pointer ) ) {
- result =
- make_exception( c_string_to_lisp_string
- ( L"Memory exhausted." ), previous );
- break;
- } else {
- struct stack_frame *arg_frame =
- get_stack_frame( arg_frame_pointer );
- debug_print( L"Setting argument 0 of arg_frame to ", DEBUG_STACK);
- debug_print_object(cell.payload.cons.car, DEBUG_STACK);
- set_reg( arg_frame, 0, cell.payload.cons.car );
-
- struct cons_pointer val =
- lisp_eval( arg_frame, arg_frame_pointer, env );
+ struct cons_pointer val = eval_form(frame, result, cell.payload.cons.car, env);
if ( exceptionp( val ) ) {
result = val;
break;
@@ -160,11 +146,9 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
set_reg( frame, frame->args, val );
}
- dec_ref( arg_frame_pointer );
-
args = cell.payload.cons.cdr;
}
- }
+
if ( !exceptionp( result ) ) {
if ( consp( args ) ) {
/* if we still have args, eval them and stick the values on `more` */
@@ -175,10 +159,10 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
inc_ref( more );
}
- debug_dump_object( result, DEBUG_STACK );
}
}
- debug_print( L"Leaving make_stack_frame\n", DEBUG_STACK );
+ debug_print( L"make_stack_frame: returning\n", DEBUG_STACK );
+ debug_dump_object( result, DEBUG_STACK );
return result;
}
@@ -206,8 +190,7 @@ struct cons_pointer make_special_frame( struct cons_pointer previous,
} else {
struct stack_frame *frame = get_stack_frame( result );
- for ( frame->args = 0; frame->args < args_in_frame && !nilp( args );
- frame->args++ ) {
+ while ( frame->args < args_in_frame && !nilp( args )) {
/* iterate down the arg list filling in the arg slots in the
* frame. When there are no more slots, if there are still args,
* stash them on more */
@@ -222,11 +205,10 @@ struct cons_pointer make_special_frame( struct cons_pointer previous,
frame->more = args;
inc_ref( args );
}
-
- debug_dump_object( result, DEBUG_STACK );
}
}
- debug_print( L"Leaving make_special_frame\n", DEBUG_STACK );
+ debug_print( L"make_special_frame: returning\n", DEBUG_STACK );
+ debug_dump_object( result, DEBUG_STACK );
return result;
}
diff --git a/src/memory/stack.h b/src/memory/stack.h
index b56f432..79cd1e2 100644
--- a/src/memory/stack.h
+++ b/src/memory/stack.h
@@ -39,7 +39,9 @@
* 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!
*/
-#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);}
+
+void set_reg(struct stack_frame * frame, int reg, struct cons_pointer value);
struct stack_frame *get_stack_frame( struct cons_pointer pointer );
diff --git a/src/ops/intern.c b/src/ops/intern.c
index 8dea7c8..27c745d 100644
--- a/src/ops/intern.c
+++ b/src/ops/intern.c
@@ -111,6 +111,12 @@ struct cons_pointer c_assoc( struct cons_pointer key,
struct cons_pointer
bind( struct cons_pointer key, struct cons_pointer value,
struct cons_pointer store ) {
+ debug_print(L"Binding ", DEBUG_ALLOC);
+ debug_print_object(key, DEBUG_ALLOC);
+ debug_print(L" to ", DEBUG_ALLOC);
+ debug_print_object(value, DEBUG_ALLOC);
+ debug_println(DEBUG_ALLOC);
+
return make_cons( make_cons( key, value ), store );
}
diff --git a/src/ops/lispops.c b/src/ops/lispops.c
index 43665e9..79195e4 100644
--- a/src/ops/lispops.c
+++ b/src/ops/lispops.c
@@ -94,6 +94,7 @@ struct cons_pointer eval_form( struct stack_frame *parent,
struct stack_frame *next = get_stack_frame( next_pointer );
set_reg( next, 0, form );
+ next->args = 1;
result = lisp_eval( next, next_pointer, env );
@@ -253,25 +254,15 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
struct cons_pointer
c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
- struct cons_pointer result = NIL;
+ debug_print(L"Entering c_apply\n", DEBUG_EVAL);
+ struct cons_pointer result = NIL;
- /* 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] ) );
struct cons_pointer fn_pointer =
- lisp_eval( fn_frame, fn_frame_pointer, 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. */
- dec_ref( fn_frame_pointer );
- }
+ eval_form( frame, frame_pointer, c_car( frame->arg[0] ), env );
+ if ( exceptionp( fn_pointer ) ) {
+ result = fn_pointer;
+ } else {
struct cons_space_object fn_cell = pointer2cell( fn_pointer );
struct cons_pointer args = c_cdr( frame->arg[0] );
@@ -327,9 +318,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct stack_frame *next =
get_stack_frame( frame_pointer );
result = eval_lambda( fn_cell, next, next_pointer, env );
- if ( !exceptionp( result ) ) {
dec_ref( next_pointer );
- }
}
}
break;
@@ -341,15 +330,14 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_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,
+ ( *fn_cell.payload.special.executable ) ( get_stack_frame( next_pointer ),
next_pointer,
env );
- if ( !exceptionp( result ) ) {
- dec_ref( next_pointer );
- }
+ debug_print(L"Special form returning: ", DEBUG_EVAL);
+ debug_print_object(result, DEBUG_EVAL);
+ debug_println(DEBUG_EVAL);
+ dec_ref( next_pointer );
}
}
break;
@@ -367,7 +355,11 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
result = throw_exception( message, frame_pointer );
}
}
- dec_ref( fn_frame_pointer );
+ }
+
+ debug_print(L"c_apply: returning: ", DEBUG_EVAL);
+ debug_print_object(result, DEBUG_EVAL);
+ debug_println(DEBUG_EVAL);
return result;
}
diff --git a/src/repl.c b/src/repl.c
index 04cf33c..e0170b6 100644
--- a/src/repl.c
+++ b/src/repl.c
@@ -52,16 +52,11 @@ struct cons_pointer repl_read( struct cons_pointer stream_pointer ) {
* Dummy up a Lisp eval call with its own stack frame.
*/
struct cons_pointer repl_eval( struct cons_pointer input ) {
- debug_print( L"Entered repl_eval\n", DEBUG_REPL );
+ debug_print( L"Entered repl_eval\n", DEBUG_REPL );
struct cons_pointer result = NIL;
- struct cons_pointer frame_pointer = make_stack_frame( NIL, make_cons( input, NIL ), oblist);
- if ( !nilp( frame_pointer ) ) {
- inc_ref(frame_pointer);
- result = lisp_eval( get_stack_frame( frame_pointer ), frame_pointer, oblist );
+ result = eval_form( NULL, NIL, input, oblist );
- dec_ref( frame_pointer );
- }
debug_print( L"repl_eval: returning\n", DEBUG_REPL );
debug_dump_object( result, DEBUG_REPL );
@@ -73,15 +68,10 @@ struct cons_pointer repl_eval( struct cons_pointer input ) {
*/
struct cons_pointer repl_print( struct cons_pointer stream_pointer,
struct cons_pointer value ) {
- debug_print( L"Entered repl_print\n", DEBUG_REPL );
+ debug_print( L"Entered repl_print\n", DEBUG_REPL );
debug_dump_object( value, DEBUG_REPL );
- struct cons_pointer result = NIL;
- struct cons_pointer frame_pointer = make_stack_frame( NIL, make_cons( value, NIL ), oblist);
- if ( !nilp( frame_pointer ) ) {
- inc_ref(frame_pointer);
- result = lisp_print( get_stack_frame( frame_pointer ), frame_pointer, oblist );
- dec_ref( frame_pointer );
- }
+ struct cons_pointer result =
+ print( pointer2cell( stream_pointer ).payload.stream.stream, value );
debug_print( L"repl_print: returning\n", DEBUG_REPL );
debug_dump_object( result, DEBUG_REPL );
@@ -98,7 +88,7 @@ struct cons_pointer repl_print( struct cons_pointer stream_pointer,
void
repl( FILE * in_stream, FILE * out_stream, FILE * error_stream,
bool show_prompt ) {
- debug_print( L"Entered repl\n", DEBUG_REPL );
+ debug_print( L"Entered repl\n", DEBUG_REPL );
struct cons_pointer input_stream = make_read_stream( in_stream );
inc_ref( input_stream );
From 570634bc4325f833624c2215a2303b013cb9cb3c Mon Sep 17 00:00:00 2001
From: Simon Brooke <simon@journeyman.cc>
Date: Fri, 28 Dec 2018 21:33:35 +0000
Subject: [PATCH 6/6] Success! All tests pass.
---
src/ops/lispops.c | 5 +++--
1 file changed, 3 insertions(+), 2 deletions(-)
diff --git a/src/ops/lispops.c b/src/ops/lispops.c
index 79195e4..82746e0 100644
--- a/src/ops/lispops.c
+++ b/src/ops/lispops.c
@@ -203,7 +203,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
if ( consp( names ) ) {
/* if `names` is a list, bind successive items from that list
* to values of arguments */
- for ( int i = 0; i < args_in_frame && consp( names ); i++ ) {
+ for ( int i = 0; i < frame->args && consp( names ); i++ ) {
struct cons_pointer name = c_car( names );
struct cons_pointer val = frame->arg[i];
@@ -212,6 +212,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
names = c_cdr( names );
}
+ /* TODO: if there's more than `args_in_frame` arguments, bind those too. */
} else if ( symbolp( names ) ) {
/* if `names` is a symbol, rather than a list of symbols,
* then bind a list of the values of args to that symbol. */
@@ -316,7 +317,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
result = next_pointer;
} else {
struct stack_frame *next =
- get_stack_frame( frame_pointer );
+ get_stack_frame( next_pointer );
result = eval_lambda( fn_cell, next, next_pointer, env );
dec_ref( next_pointer );
}