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

Merge branch 'feature/stack-in-vector-space' into develop

Browse source
This commit is contained in:
Simon Brooke 2018-12-28 21:33:49 +00:00
parent ae8ba67ed7 570634bc43
commit 3d2d680041
33 changed files with 1411 additions and 871 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
Doxyfile
View file

@ -32,7 +32,7 @@ DOXYFILE_ENCODING = UTF-8
# title of most generated pages and in a few other places. # title of most generated pages and in a few other places.
# The default value is: My Project. # 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 # 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 # could be handy for archiving the generated documentation or if some version
@ -58,7 +58,7 @@ PROJECT_LOGO =
# entered, it will be relative to the location where doxygen was started. If # entered, it will be relative to the location where doxygen was started. If
# left blank the current directory will be used. # 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- # 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 # directories (in 2 levels) under the output directory of each output format and
@ -778,7 +778,7 @@ WARN_FORMAT = "$file:$line: $text"
# messages should be written. If left blank the output is written to standard # messages should be written. If left blank the output is written to standard
# error (stderr). # error (stderr).
WARN_LOGFILE = WARN_LOGFILE = doxy.log
#--------------------------------------------------------------------------- #---------------------------------------------------------------------------
# Configuration options related to the input files # Configuration options related to the input files
@ -790,7 +790,7 @@ WARN_LOGFILE =
# spaces. See also FILE_PATTERNS and EXTENSION_MAPPING # spaces. See also FILE_PATTERNS and EXTENSION_MAPPING
# Note: If this tag is empty the current directory is searched. # 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 # 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 # that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses

4
Makefile
View file

@ -23,7 +23,7 @@ LDFLAGS := -lm
$(TARGET): $(OBJS) Makefile $(TARGET): $(OBJS) Makefile
$(CC) $(LDFLAGS) $(OBJS) -DVERSION=$(VERSION) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS) $(CC) $(LDFLAGS) $(OBJS) -DVERSION=$(VERSION) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS)
doc: $(SRCS) Makefile doc: $(SRCS) Makefile Doxyfile
doxygen doxygen
format: $(SRCS) $(HDRS) Makefile format: $(SRCS) $(HDRS) Makefile
@ -38,7 +38,7 @@ test: $(OBJS) $(TESTS) Makefile
.PHONY: clean .PHONY: clean
clean: clean:
$(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ *~ $(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ $(SRC_DIRS)/*/*~ *~
repl: repl:
$(TARGET) -p 2> psse.log $(TARGET) -p 2> psse.log

5
src/arith/integer.c
View file

@ -13,6 +13,7 @@
#include "conspage.h" #include "conspage.h"
#include "consspaceobject.h" #include "consspaceobject.h"
#include "debug.h"
/** /**
* return the numeric value of this cell, as a C primitive double, not * 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 ); struct cons_space_object *cell = &pointer2cell( result );
cell->payload.integer.value = value; cell->payload.integer.value = value;
#ifdef DEBUG debug_dump_object( result, DEBUG_ARITH );
dump_object( stderr, result );
#endif
return result; return result;
} }

204
src/arith/peano.c
View file

@ -8,14 +8,15 @@
*/ */
#include <ctype.h> #include <ctype.h>
#include <math.h>
#include <stdbool.h> #include <stdbool.h>
#include <stdio.h> #include <stdio.h>
#include <stdlib.h> #include <stdlib.h>
#include <string.h> #include <string.h>
#include <math.h>
#include "consspaceobject.h" #include "consspaceobject.h"
#include "conspage.h" #include "conspage.h"
#include "debug.h"
#include "equal.h" #include "equal.h"
#include "integer.h" #include "integer.h"
#include "intern.h" #include "intern.h"
@ -28,7 +29,9 @@
long double to_long_double( struct cons_pointer arg ); long double to_long_double( struct cons_pointer arg );
int64_t to_long_int( struct cons_pointer arg ); int64_t to_long_int( struct cons_pointer arg );
struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, struct cons_pointer add_2( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 ); struct cons_pointer arg2 );
@ -84,9 +87,9 @@ long double to_long_double( struct cons_pointer arg ) {
break; break;
} }
fputws( L"to_long_double( ", stderr ); debug_print( L"to_long_double( ", DEBUG_ARITH );
print( stderr, arg ); debug_print_object( arg, DEBUG_ARITH );
fwprintf( stderr, L") => %lf\n", result ); debug_printf( DEBUG_ARITH, L") => %lf\n", result );
return result; return result;
} }
@ -119,19 +122,19 @@ int64_t to_long_int( struct cons_pointer arg ) {
* return a cons_pointer indicating a number which is the sum of * return a cons_pointer indicating a number which is the sum of
* the numbers indicated by `arg1` and `arg2`. * the numbers indicated by `arg1` and `arg2`.
*/ */
struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, struct cons_pointer add_2( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 ) { struct cons_pointer arg2 ) {
struct cons_pointer result; struct cons_pointer result;
struct cons_space_object cell1 = pointer2cell( arg1 ); struct cons_space_object cell1 = pointer2cell( arg1 );
struct cons_space_object cell2 = pointer2cell( arg2 ); struct cons_space_object cell2 = pointer2cell( arg2 );
#ifdef DEBUG debug_print( L"add_2( arg1 = ", DEBUG_ARITH );
fputws( L"add_2( arg1 = ", stderr ); debug_print_object( arg1, DEBUG_ARITH );
print( stderr, arg1 ); debug_print( L"; arg2 = ", DEBUG_ARITH );
fputws( L"; arg2 = ", stderr ); debug_print_object( arg2, DEBUG_ARITH );
print( stderr, arg2 ); debug_print( L"\n", DEBUG_ARITH );
fputws( L")\n", stderr );
#endif
if ( zerop( arg1 ) ) { if ( zerop( arg1 ) ) {
result = arg2; result = arg2;
@ -153,7 +156,8 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1,
cell2.payload.integer.value ); cell2.payload.integer.value );
break; break;
case RATIOTV: case RATIOTV:
result = add_integer_ratio( frame, arg1, arg2 ); result =
add_integer_ratio( frame_pointer, arg1, arg2 );
break; break;
case REALTV: case REALTV:
result = result =
@ -161,9 +165,9 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1,
to_long_double( arg2 ) ); to_long_double( arg2 ) );
break; break;
default: default:
result = lisp_throw( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot add: not a number" ), ( L"Cannot add: not a number" ),
frame ); frame_pointer );
break; break;
} }
break; break;
@ -173,10 +177,11 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1,
result = arg2; result = arg2;
break; break;
case INTEGERTV: case INTEGERTV:
result = add_integer_ratio( frame, arg2, arg1 ); result =
add_integer_ratio( frame_pointer, arg2, arg1 );
break; break;
case RATIOTV: case RATIOTV:
result = add_ratio_ratio( frame, arg1, arg2 ); result = add_ratio_ratio( frame_pointer, arg1, arg2 );
break; break;
case REALTV: case REALTV:
result = result =
@ -184,9 +189,9 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1,
to_long_double( arg2 ) ); to_long_double( arg2 ) );
break; break;
default: default:
result = lisp_throw( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot add: not a number" ), ( L"Cannot add: not a number" ),
frame ); frame_pointer );
break; break;
} }
break; break;
@ -197,16 +202,15 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1,
break; break;
default: default:
result = exceptionp( arg2 ) ? arg2 : result = exceptionp( arg2 ) ? arg2 :
lisp_throw( c_string_to_lisp_string throw_exception( c_string_to_lisp_string
( "Cannot add: not a number" ), frame ); ( L"Cannot add: not a number" ),
frame_pointer );
} }
} }
#ifdef DEBUG debug_print( L"}; => ", DEBUG_ARITH );
fputws( L"}; => ", stderr ); debug_print_object( arg2, DEBUG_ARITH );
print( stderr, arg2 ); debug_print( L"\n", DEBUG_ARITH );
fputws( L"\n", stderr );
#endif
return result; return result;
} }
@ -218,7 +222,7 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1,
* @return a pointer to an integer or real. * @return a pointer to an integer or real.
*/ */
struct cons_pointer lisp_add( struct stack_frame struct cons_pointer lisp_add( struct stack_frame
*frame, struct *frame, struct cons_pointer frame_pointer, struct
cons_pointer env ) { cons_pointer env ) {
struct cons_pointer result = make_integer( 0 ); struct cons_pointer result = make_integer( 0 );
struct cons_pointer tmp; struct cons_pointer tmp;
@ -227,7 +231,7 @@ struct cons_pointer lisp_add( struct stack_frame
i < args_in_frame && i < args_in_frame &&
!nilp( frame->arg[i] ) && !exceptionp( result ); i++ ) { !nilp( frame->arg[i] ) && !exceptionp( result ); i++ ) {
tmp = result; tmp = result;
result = add_2( frame, result, frame->arg[i] ); result = add_2( frame, frame_pointer, result, frame->arg[i] );
if ( !eq( tmp, result ) ) { if ( !eq( tmp, result ) ) {
dec_ref( tmp ); dec_ref( tmp );
} }
@ -236,7 +240,7 @@ struct cons_pointer lisp_add( struct stack_frame
struct cons_pointer more = frame->more; struct cons_pointer more = frame->more;
while ( consp( more ) && !exceptionp( result ) ) { while ( consp( more ) && !exceptionp( result ) ) {
tmp = result; tmp = result;
result = add_2( frame, result, c_car( more ) ); result = add_2( frame, frame_pointer, result, c_car( more ) );
if ( !eq( tmp, result ) ) { if ( !eq( tmp, result ) ) {
dec_ref( tmp ); dec_ref( tmp );
} }
@ -253,19 +257,18 @@ struct cons_pointer lisp_add( struct stack_frame
* the numbers indicated by `arg1` and `arg2`. * the numbers indicated by `arg1` and `arg2`.
*/ */
struct cons_pointer multiply_2( struct stack_frame *frame, struct cons_pointer multiply_2( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer arg1, struct cons_pointer arg1,
struct cons_pointer arg2 ) { struct cons_pointer arg2 ) {
struct cons_pointer result; struct cons_pointer result;
struct cons_space_object cell1 = pointer2cell( arg1 ); struct cons_space_object cell1 = pointer2cell( arg1 );
struct cons_space_object cell2 = pointer2cell( arg2 ); struct cons_space_object cell2 = pointer2cell( arg2 );
#ifdef DEBUG debug_print( L"multiply_2( arg1 = ", DEBUG_ARITH );
fputws( L"multiply_2( arg1 = ", stderr ); debug_print_object( arg1, DEBUG_ARITH );
print( stderr, arg1 ); debug_print( L"; arg2 = ", DEBUG_ARITH );
fputws( L"; arg2 = ", stderr ); debug_print_object( arg2, DEBUG_ARITH );
print( stderr, arg2 ); debug_print( L")", DEBUG_ARITH );
fputws( L")\n", stderr );
#endif
if ( zerop( arg1 ) ) { if ( zerop( arg1 ) ) {
result = arg2; result = arg2;
@ -286,7 +289,9 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
cell2.payload.integer.value ); cell2.payload.integer.value );
break; break;
case RATIOTV: case RATIOTV:
result = multiply_integer_ratio( frame, arg1, arg2 ); result =
multiply_integer_ratio( frame_pointer, arg1,
arg2 );
break; break;
case REALTV: case REALTV:
result = result =
@ -294,9 +299,9 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
to_long_double( arg2 ) ); to_long_double( arg2 ) );
break; break;
default: default:
result = lisp_throw( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot multiply: not a number" ), ( L"Cannot multiply: not a number" ),
frame ); frame_pointer );
break; break;
} }
break; break;
@ -306,10 +311,13 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
result = arg2; result = arg2;
break; break;
case INTEGERTV: case INTEGERTV:
result = multiply_integer_ratio( frame, arg2, arg1 ); result =
multiply_integer_ratio( frame_pointer, arg2,
arg1 );
break; break;
case RATIOTV: case RATIOTV:
result = multiply_ratio_ratio( frame, arg1, arg2 ); result =
multiply_ratio_ratio( frame_pointer, arg1, arg2 );
break; break;
case REALTV: case REALTV:
result = result =
@ -317,9 +325,9 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
to_long_double( arg2 ) ); to_long_double( arg2 ) );
break; break;
default: default:
result = lisp_throw( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot multiply: not a number" ), ( L"Cannot multiply: not a number" ),
frame ); frame_pointer );
} }
break; break;
case REALTV: case REALTV:
@ -328,18 +336,16 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
to_long_double( arg2 ) ); to_long_double( arg2 ) );
break; break;
default: default:
result = lisp_throw( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot multiply: not a number" ), ( L"Cannot multiply: not a number" ),
frame ); frame_pointer );
break; break;
} }
} }
#ifdef DEBUG debug_print( L" => ", DEBUG_ARITH );
fputws( L" => ", stderr ); debug_print_object( arg2, DEBUG_ARITH );
print( stderr, arg2 ); debug_print( L"\n", DEBUG_ARITH );
fputws( L"\n", stderr );
#endif
return result; return result;
} }
@ -353,7 +359,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
*/ */
struct cons_pointer lisp_multiply( struct struct cons_pointer lisp_multiply( struct
stack_frame stack_frame
*frame, struct *frame, struct cons_pointer frame_pointer, struct
cons_pointer env ) { cons_pointer env ) {
struct cons_pointer result = make_integer( 1 ); struct cons_pointer result = make_integer( 1 );
struct cons_pointer tmp; struct cons_pointer tmp;
@ -361,7 +367,7 @@ struct cons_pointer lisp_multiply( struct
for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ) for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] )
&& !exceptionp( result ); i++ ) { && !exceptionp( result ); i++ ) {
tmp = result; tmp = result;
result = multiply_2( frame, result, frame->arg[i] ); result = multiply_2( frame, frame_pointer, result, frame->arg[i] );
if ( !eq( tmp, result ) ) { if ( !eq( tmp, result ) ) {
dec_ref( tmp ); dec_ref( tmp );
@ -372,7 +378,7 @@ struct cons_pointer lisp_multiply( struct
while ( consp( more ) while ( consp( more )
&& !exceptionp( result ) ) { && !exceptionp( result ) ) {
tmp = result; tmp = result;
result = multiply_2( frame, result, c_car( more ) ); result = multiply_2( frame, frame_pointer, result, c_car( more ) );
if ( !eq( tmp, result ) ) { if ( !eq( tmp, result ) ) {
dec_ref( tmp ); dec_ref( tmp );
@ -388,7 +394,7 @@ struct cons_pointer lisp_multiply( struct
* return a cons_pointer indicating a number which is the * return a cons_pointer indicating a number which is the
* inverse of the number indicated by `arg`. * inverse of the number indicated by `arg`.
*/ */
struct cons_pointer inverse( struct stack_frame *frame, struct cons_pointer inverse( struct cons_pointer frame,
struct cons_pointer arg ) { struct cons_pointer arg ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( arg ); struct cons_space_object cell = pointer2cell( arg );
@ -406,8 +412,8 @@ struct cons_pointer inverse( struct stack_frame *frame,
case RATIOTV: case RATIOTV:
result = make_ratio( frame, result = make_ratio( frame,
make_integer( 0 - make_integer( 0 -
to_long_int( cell.payload.ratio. to_long_int( cell.payload.
dividend ) ), ratio.dividend ) ),
cell.payload.ratio.divisor ); cell.payload.ratio.divisor );
break; break;
case REALTV: case REALTV:
@ -430,7 +436,7 @@ struct cons_pointer inverse( struct stack_frame *frame,
*/ */
struct cons_pointer lisp_subtract( struct struct cons_pointer lisp_subtract( struct
stack_frame stack_frame
*frame, struct *frame, struct cons_pointer frame_pointer, struct
cons_pointer env ) { cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct cons_space_object cell0 = pointer2cell( frame->arg[0] ); struct cons_space_object cell0 = pointer2cell( frame->arg[0] );
@ -451,10 +457,12 @@ struct cons_pointer lisp_subtract( struct
break; break;
case RATIOTV:{ case RATIOTV:{
struct cons_pointer tmp = struct cons_pointer tmp =
make_ratio( frame, frame->arg[0], make_ratio( frame_pointer, frame->arg[0],
make_integer( 1 ) ); make_integer( 1 ) );
inc_ref( tmp );
result = result =
subtract_ratio_ratio( frame, tmp, frame->arg[1] ); subtract_ratio_ratio( frame_pointer, tmp,
frame->arg[1] );
dec_ref( tmp ); dec_ref( tmp );
} }
break; break;
@ -464,9 +472,9 @@ struct cons_pointer lisp_subtract( struct
to_long_double( frame->arg[1] ) ); to_long_double( frame->arg[1] ) );
break; break;
default: default:
result = lisp_throw( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot multiply: not a number" ), ( L"Cannot subtract: not a number" ),
frame ); frame_pointer );
break; break;
} }
break; break;
@ -477,16 +485,18 @@ struct cons_pointer lisp_subtract( struct
break; break;
case INTEGERTV:{ case INTEGERTV:{
struct cons_pointer tmp = struct cons_pointer tmp =
make_ratio( frame, frame->arg[1], make_ratio( frame_pointer, frame->arg[1],
make_integer( 1 ) ); make_integer( 1 ) );
inc_ref( tmp );
result = result =
subtract_ratio_ratio( frame, frame->arg[0], tmp ); subtract_ratio_ratio( frame_pointer, frame->arg[0],
tmp );
dec_ref( tmp ); dec_ref( tmp );
} }
break; break;
case RATIOTV: case RATIOTV:
result = result =
subtract_ratio_ratio( frame, frame->arg[0], subtract_ratio_ratio( frame_pointer, frame->arg[0],
frame->arg[1] ); frame->arg[1] );
break; break;
case REALTV: case REALTV:
@ -495,9 +505,9 @@ struct cons_pointer lisp_subtract( struct
to_long_double( frame->arg[1] ) ); to_long_double( frame->arg[1] ) );
break; break;
default: default:
result = lisp_throw( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot multiply: not a number" ), ( L"Cannot subtract: not a number" ),
frame ); frame_pointer );
break; break;
} }
break; break;
@ -507,8 +517,9 @@ struct cons_pointer lisp_subtract( struct
to_long_double( frame->arg[1] ) ); to_long_double( frame->arg[1] ) );
break; break;
default: default:
result = lisp_throw( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot multiply: not a number" ), frame ); ( L"Cannot subtract: not a number" ),
frame_pointer );
break; break;
} }
@ -525,7 +536,7 @@ struct cons_pointer lisp_subtract( struct
*/ */
struct cons_pointer lisp_divide( struct struct cons_pointer lisp_divide( struct
stack_frame stack_frame
*frame, struct *frame, struct cons_pointer frame_pointer, struct
cons_pointer env ) { cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct cons_space_object arg0 = pointer2cell( frame->arg[0] ); struct cons_space_object arg0 = pointer2cell( frame->arg[0] );
@ -542,8 +553,11 @@ struct cons_pointer lisp_divide( struct
break; break;
case INTEGERTV:{ case INTEGERTV:{
struct cons_pointer unsimplified = struct cons_pointer unsimplified =
make_ratio( frame, frame->arg[0], frame->arg[1] ); make_ratio( frame_pointer, frame->arg[0],
result = simplify_ratio( frame, unsimplified ); 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 ) ) { if ( !eq( unsimplified, result ) ) {
dec_ref( unsimplified ); dec_ref( unsimplified );
} }
@ -552,9 +566,10 @@ struct cons_pointer lisp_divide( struct
case RATIOTV:{ case RATIOTV:{
struct cons_pointer one = make_integer( 1 ); struct cons_pointer one = make_integer( 1 );
struct cons_pointer ratio = struct cons_pointer ratio =
make_ratio( frame, frame->arg[0], one ); make_ratio( frame_pointer, frame->arg[0], one );
result = result =
divide_ratio_ratio( frame, ratio, frame->arg[1] ); divide_ratio_ratio( frame_pointer, ratio,
frame->arg[1] );
dec_ref( ratio ); dec_ref( ratio );
} }
break; break;
@ -564,9 +579,9 @@ struct cons_pointer lisp_divide( struct
to_long_double( frame->arg[1] ) ); to_long_double( frame->arg[1] ) );
break; break;
default: default:
result = lisp_throw( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot divide: not a number" ), ( L"Cannot divide: not a number" ),
frame ); frame_pointer );
break; break;
} }
break; break;
@ -577,16 +592,20 @@ struct cons_pointer lisp_divide( struct
break; break;
case INTEGERTV:{ case INTEGERTV:{
struct cons_pointer one = make_integer( 1 ); struct cons_pointer one = make_integer( 1 );
inc_ref( one );
struct cons_pointer ratio = struct cons_pointer ratio =
make_ratio( frame, frame->arg[1], one ); make_ratio( frame_pointer, frame->arg[1], one );
inc_ref( ratio );
result = result =
divide_ratio_ratio( frame, frame->arg[0], ratio ); divide_ratio_ratio( frame_pointer, frame->arg[0],
ratio );
dec_ref( ratio ); dec_ref( ratio );
dec_ref( one );
} }
break; break;
case RATIOTV: case RATIOTV:
result = result =
divide_ratio_ratio( frame, frame->arg[0], divide_ratio_ratio( frame_pointer, frame->arg[0],
frame->arg[1] ); frame->arg[1] );
break; break;
case REALTV: case REALTV:
@ -595,9 +614,9 @@ struct cons_pointer lisp_divide( struct
to_long_double( frame->arg[1] ) ); to_long_double( frame->arg[1] ) );
break; break;
default: default:
result = lisp_throw( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot divide: not a number" ), ( L"Cannot divide: not a number" ),
frame ); frame_pointer );
break; break;
} }
break; break;
@ -607,8 +626,9 @@ struct cons_pointer lisp_divide( struct
to_long_double( frame->arg[1] ) ); to_long_double( frame->arg[1] ) );
break; break;
default: default:
result = lisp_throw( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Cannot divide: not a number" ), frame ); ( L"Cannot divide: not a number" ),
frame_pointer );
break; break;
} }

14
src/arith/peano.h
View file

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

151
src/arith/ratio.c
View file

@ -13,6 +13,7 @@
#include "conspage.h" #include "conspage.h"
#include "consspaceobject.h" #include "consspaceobject.h"
#include "debug.h"
#include "equal.h" #include "equal.h"
#include "integer.h" #include "integer.h"
#include "lispops.h" #include "lispops.h"
@ -24,7 +25,7 @@
* declared in peano.c, can't include piano.h here because * declared in peano.c, can't include piano.h here because
* circularity. TODO: refactor. * circularity. TODO: refactor.
*/ */
struct cons_pointer inverse( struct stack_frame *frame, struct cons_pointer inverse( struct cons_pointer frame_pointer,
struct cons_pointer arg ); struct cons_pointer arg );
/** /**
@ -54,31 +55,31 @@ int64_t least_common_multiple( int64_t m, int64_t n ) {
* be in a simplified representation. If `arg` isn't a ratio, * be in a simplified representation. If `arg` isn't a ratio,
* will throw exception. * will throw exception.
*/ */
struct cons_pointer simplify_ratio( struct stack_frame *frame, struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg ) { struct cons_pointer arg ) {
struct cons_pointer result = arg; struct cons_pointer result = arg;
if ( ratiop( arg ) ) { if ( ratiop( arg ) ) {
int64_t ddrv = int64_t ddrv =
pointer2cell( pointer2cell( arg ).payload.ratio.dividend ).payload. pointer2cell( pointer2cell( arg ).payload.ratio.dividend ).
integer.value, drrv = payload.integer.value, drrv =
pointer2cell( pointer2cell( arg ).payload.ratio.divisor ).payload. pointer2cell( pointer2cell( arg ).payload.ratio.divisor ).
integer.value, gcd = greatest_common_divisor( ddrv, drrv ); payload.integer.value, gcd = greatest_common_divisor( ddrv, drrv );
if ( gcd > 1 ) { if ( gcd > 1 ) {
if ( drrv / gcd == 1 ) { if ( drrv / gcd == 1 ) {
result = make_integer( ddrv / gcd ); result = make_integer( ddrv / gcd );
} else { } else {
result = result =
make_ratio( frame, make_integer( ddrv / gcd ), make_ratio( frame_pointer, make_integer( ddrv / gcd ),
make_integer( drrv / gcd ) ); make_integer( drrv / gcd ) );
} }
} }
} else { } else {
result = result =
lisp_throw( make_cons( c_string_to_lisp_string throw_exception( make_cons( c_string_to_lisp_string
( "Shouldn't happen: bad arg to simplify_ratio" ), ( L"Shouldn't happen: bad arg to simplify_ratio" ),
arg ), frame ); arg ), frame_pointer );
} }
return result; return result;
@ -91,18 +92,16 @@ struct cons_pointer simplify_ratio( struct stack_frame *frame,
* the ratios indicated by `arg1` and `arg2`. If you pass non-ratios, * the ratios indicated by `arg1` and `arg2`. If you pass non-ratios,
* this is going to break horribly. * this is going to break horribly.
*/ */
struct cons_pointer add_ratio_ratio( struct stack_frame *frame, struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1, struct cons_pointer arg1,
struct cons_pointer arg2 ) { struct cons_pointer arg2 ) {
struct cons_pointer r, result; struct cons_pointer r, result;
#ifdef DEBUG debug_print( L"add_ratio_ratio( arg1 = ", DEBUG_ARITH );
fputws( L"add_ratio_ratio( arg1 = ", stderr ); debug_print_object( arg1, DEBUG_ARITH );
print( stderr, arg1 ); debug_print( L"; arg2 = ", DEBUG_ARITH );
fputws( L"; arg2 = ", stderr ); debug_print_object( arg2, DEBUG_ARITH );
print( stderr, arg2 ); debug_print( L")\n", DEBUG_ARITH );
fputws( L")\n", stderr );
#endif
if ( ratiop( arg1 ) && ratiop( arg2 ) ) { if ( ratiop( arg1 ) && ratiop( arg2 ) ) {
struct cons_space_object cell1 = pointer2cell( arg1 ); struct cons_space_object cell1 = pointer2cell( arg1 );
@ -118,12 +117,10 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame,
lcm = least_common_multiple( dr1v, dr2v ), lcm = least_common_multiple( dr1v, dr2v ),
m1 = lcm / dr1v, m2 = lcm / dr2v; m1 = lcm / dr1v, m2 = lcm / dr2v;
#ifdef DEBUG debug_printf( DEBUG_ARITH, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 );
fwprintf( stderr, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 );
#endif
if ( dr1v == dr2v ) { if ( dr1v == dr2v ) {
r = make_ratio( frame, r = make_ratio( frame_pointer,
make_integer( dd1v + dd2v ), make_integer( dd1v + dd2v ),
cell1.payload.ratio.divisor ); cell1.payload.ratio.divisor );
} else { } else {
@ -131,10 +128,10 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame,
dr1vm = make_integer( dr1v * m1 ), dr1vm = make_integer( dr1v * m1 ),
dd2vm = make_integer( dd2v * m2 ), dd2vm = make_integer( dd2v * m2 ),
dr2vm = make_integer( dr2v * m2 ), dr2vm = make_integer( dr2v * m2 ),
r1 = make_ratio( frame, dd1vm, dr1vm ), r1 = make_ratio( frame_pointer, dd1vm, dr1vm ),
r2 = make_ratio( frame, dd2vm, dr2vm ); r2 = make_ratio( frame_pointer, dd2vm, dr2vm );
r = add_ratio_ratio( frame, r1, r2 ); r = add_ratio_ratio( frame_pointer, r1, r2 );
/* because the references on dd1vm, dr1vm, dd2vm and dr2vm were /* because the references on dd1vm, dr1vm, dd2vm and dr2vm were
* never incremented except when making r1 and r2, decrementing * never incremented except when making r1 and r2, decrementing
@ -143,24 +140,22 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame,
dec_ref( r2 ); dec_ref( r2 );
} }
result = simplify_ratio( frame, r ); result = simplify_ratio( frame_pointer, r );
if ( !eq( r, result ) ) { if ( !eq( r, result ) ) {
dec_ref( r ); dec_ref( r );
} }
} else { } else {
result = result =
lisp_throw( make_cons( c_string_to_lisp_string throw_exception( make_cons( c_string_to_lisp_string
( "Shouldn't happen: bad arg to add_ratio_ratio" ), ( L"Shouldn't happen: bad arg to add_ratio_ratio" ),
make_cons( arg1, make_cons( arg1,
make_cons( arg2, NIL ) ) ), make_cons( arg2, NIL ) ) ),
frame ); frame_pointer );
} }
#ifdef DEBUG debug_print( L" => ", DEBUG_ARITH );
fputws( L" => ", stderr ); debug_print_object( result, DEBUG_ARITH );
print( stderr, result ); debug_print( L"\n", DEBUG_ARITH );
fputws( L"\n", stderr );
#endif
return result; return result;
} }
@ -171,26 +166,27 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame,
* the intger indicated by `intarg` and the ratio indicated by * the intger indicated by `intarg` and the ratio indicated by
* `ratarg`. If you pass other types, this is going to break horribly. * `ratarg`. If you pass other types, this is going to break horribly.
*/ */
struct cons_pointer add_integer_ratio( struct stack_frame *frame, struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer,
struct cons_pointer intarg, struct cons_pointer intarg,
struct cons_pointer ratarg ) { struct cons_pointer ratarg ) {
struct cons_pointer result; struct cons_pointer result;
if ( integerp( intarg ) && ratiop( ratarg ) ) { if ( integerp( intarg ) && ratiop( ratarg ) ) {
struct cons_pointer one = make_integer( 1 ), struct cons_pointer one = make_integer( 1 ),
ratio = make_ratio( frame, intarg, one ); ratio = make_ratio( frame_pointer, intarg, one );
result = add_ratio_ratio( frame, ratio, ratarg ); result = add_ratio_ratio( frame_pointer, ratio, ratarg );
dec_ref( one ); dec_ref( one );
dec_ref( ratio ); dec_ref( ratio );
} else { } else {
result = result =
lisp_throw( make_cons( c_string_to_lisp_string throw_exception( make_cons( c_string_to_lisp_string
( "Shouldn't happen: bad arg to add_integer_ratio" ), ( L"Shouldn't happen: bad arg to add_integer_ratio" ),
make_cons( intarg, make_cons( intarg,
make_cons( ratarg, NIL ) ) ), make_cons( ratarg,
frame ); NIL ) ) ),
frame_pointer );
} }
return result; return result;
@ -201,15 +197,16 @@ struct cons_pointer add_integer_ratio( struct stack_frame *frame,
* indicated by `arg1` divided by the ratio indicated by `arg2`. If either * indicated by `arg1` divided by the ratio indicated by `arg2`. If either
* of these aren't RTIO cells, something horrid will happen and it is YOUR FAULT. * of these aren't RTIO cells, something horrid will happen and it is YOUR FAULT.
*/ */
struct cons_pointer divide_ratio_ratio( struct stack_frame *frame, struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1, struct cons_pointer arg1,
struct cons_pointer arg2 ) { struct cons_pointer arg2 ) {
struct cons_pointer i = make_ratio( frame, struct cons_pointer i = make_ratio( frame_pointer,
pointer2cell( arg2 ).payload.ratio. pointer2cell( arg2 ).payload.
divisor, ratio.divisor,
pointer2cell( arg2 ).payload.ratio. pointer2cell( arg2 ).payload.
dividend ), result = ratio.dividend ),
multiply_ratio_ratio( frame, arg1, i ); result =
multiply_ratio_ratio( frame_pointer, arg1, i );
dec_ref( i ); dec_ref( i );
@ -221,20 +218,17 @@ struct cons_pointer divide_ratio_ratio( struct stack_frame *frame,
* the ratios indicated by `arg1` and `arg2`. If you pass non-ratios, * the ratios indicated by `arg1` and `arg2`. If you pass non-ratios,
* this is going to break horribly. * this is going to break horribly.
*/ */
struct cons_pointer multiply_ratio_ratio( struct struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, struct
stack_frame
*frame, struct
cons_pointer arg1, struct cons_pointer arg1, struct
cons_pointer arg2 ) { cons_pointer arg2 ) {
struct cons_pointer result; struct cons_pointer result;
#ifdef DEBUG debug_print( L"multiply_ratio_ratio( arg1 = ", DEBUG_ARITH );
fputws( L"multiply_ratio_ratio( arg1 = ", stderr ); debug_print_object( arg1, DEBUG_ARITH );
print( stderr, arg1 ); debug_print( L"; arg2 = ", DEBUG_ARITH );
fputws( L"; arg2 = ", stderr ); debug_print_object( arg2, DEBUG_ARITH );
print( stderr, arg2 ); debug_print( L")\n", DEBUG_ARITH );
fputws( L")\n", stderr );
#endif
if ( ratiop( arg1 ) && ratiop( arg2 ) ) { if ( ratiop( arg1 ) && ratiop( arg2 ) ) {
struct cons_space_object cell1 = pointer2cell( arg1 ); struct cons_space_object cell1 = pointer2cell( arg1 );
struct cons_space_object cell2 = pointer2cell( arg2 ); struct cons_space_object cell2 = pointer2cell( arg2 );
@ -249,18 +243,18 @@ struct cons_pointer multiply_ratio_ratio( struct
ddrv = dd1v * dd2v, drrv = dr1v * dr2v; ddrv = dd1v * dd2v, drrv = dr1v * dr2v;
struct cons_pointer unsimplified = struct cons_pointer unsimplified =
make_ratio( frame, make_integer( ddrv ), make_ratio( frame_pointer, make_integer( ddrv ),
make_integer( drrv ) ); make_integer( drrv ) );
result = simplify_ratio( frame, unsimplified ); result = simplify_ratio( frame_pointer, unsimplified );
if ( !eq( unsimplified, result ) ) { if ( !eq( unsimplified, result ) ) {
dec_ref( unsimplified ); dec_ref( unsimplified );
} }
} else { } else {
result = result =
lisp_throw( c_string_to_lisp_string throw_exception( c_string_to_lisp_string
( "Shouldn't happen: bad arg to multiply_ratio_ratio" ), ( L"Shouldn't happen: bad arg to multiply_ratio_ratio" ),
frame ); frame_pointer );
} }
return result; return result;
@ -271,23 +265,23 @@ struct cons_pointer multiply_ratio_ratio( struct
* the intger indicated by `intarg` and the ratio indicated by * the intger indicated by `intarg` and the ratio indicated by
* `ratarg`. If you pass other types, this is going to break horribly. * `ratarg`. If you pass other types, this is going to break horribly.
*/ */
struct cons_pointer multiply_integer_ratio( struct stack_frame *frame, struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer,
struct cons_pointer intarg, struct cons_pointer intarg,
struct cons_pointer ratarg ) { struct cons_pointer ratarg ) {
struct cons_pointer result; struct cons_pointer result;
if ( integerp( intarg ) && ratiop( ratarg ) ) { if ( integerp( intarg ) && ratiop( ratarg ) ) {
struct cons_pointer one = make_integer( 1 ), struct cons_pointer one = make_integer( 1 ),
ratio = make_ratio( frame, intarg, one ); ratio = make_ratio( frame_pointer, intarg, one );
result = multiply_ratio_ratio( frame, ratio, ratarg ); result = multiply_ratio_ratio( frame_pointer, ratio, ratarg );
dec_ref( one ); dec_ref( one );
dec_ref( ratio ); dec_ref( ratio );
} else { } else {
result = result =
lisp_throw( c_string_to_lisp_string throw_exception( c_string_to_lisp_string
( "Shouldn't happen: bad arg to multiply_integer_ratio" ), ( L"Shouldn't happen: bad arg to multiply_integer_ratio" ),
frame ); frame_pointer );
} }
return result; return result;
@ -299,11 +293,11 @@ struct cons_pointer multiply_integer_ratio( struct stack_frame *frame,
* the ratios indicated by `arg1` and `arg2`. If you pass non-ratios, * the ratios indicated by `arg1` and `arg2`. If you pass non-ratios,
* this is going to break horribly. * this is going to break horribly.
*/ */
struct cons_pointer subtract_ratio_ratio( struct stack_frame *frame, struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1, struct cons_pointer arg1,
struct cons_pointer arg2 ) { struct cons_pointer arg2 ) {
struct cons_pointer i = inverse( frame, arg2 ), struct cons_pointer i = inverse( frame_pointer, arg2 ),
result = add_ratio_ratio( frame, arg1, i ); result = add_ratio_ratio( frame_pointer, arg1, i );
dec_ref( i ); dec_ref( i );
@ -315,7 +309,7 @@ struct cons_pointer subtract_ratio_ratio( struct stack_frame *frame,
* Construct a ratio frame from these two pointers, expected to be integers * Construct a ratio frame from these two pointers, expected to be integers
* or (later) bignums, in the context of this stack_frame. * or (later) bignums, in the context of this stack_frame.
*/ */
struct cons_pointer make_ratio( struct stack_frame *frame, struct cons_pointer make_ratio( struct cons_pointer frame_pointer,
struct cons_pointer dividend, struct cons_pointer dividend,
struct cons_pointer divisor ) { struct cons_pointer divisor ) {
struct cons_pointer result; struct cons_pointer result;
@ -328,13 +322,12 @@ struct cons_pointer make_ratio( struct stack_frame *frame,
cell->payload.ratio.divisor = divisor; cell->payload.ratio.divisor = divisor;
} else { } else {
result = result =
lisp_throw( c_string_to_lisp_string throw_exception( c_string_to_lisp_string
( "Dividend and divisor of a ratio must be integers" ), ( L"Dividend and divisor of a ratio must be integers" ),
frame ); frame_pointer );
} }
#ifdef DEBUG debug_dump_object( result, DEBUG_ARITH );
dump_object( stderr, result );
#endif
return result; return result;
} }

18
src/arith/ratio.h
View file

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

5
src/arith/real.c
View file

@ -9,6 +9,7 @@
#include "conspage.h" #include "conspage.h"
#include "consspaceobject.h" #include "consspaceobject.h"
#include "debug.h"
#include "read.h" #include "read.h"
/** /**
@ -22,9 +23,7 @@ struct cons_pointer make_real( long double value ) {
struct cons_space_object *cell = &pointer2cell( result ); struct cons_space_object *cell = &pointer2cell( result );
cell->payload.real.value = value; cell->payload.real.value = value;
#ifdef DEBUG debug_dump_object( result, DEBUG_ARITH );
dump_object( stderr, result );
#endif
return result; return result;
} }

99
src/debug.c Normal file
View file

@ -0,0 +1,99 @@
/**
* 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 <stdarg.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 ) {
fwide( stderr, 1 );
fputws( message, stderr );
}
#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`.
*/
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
* 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 ) {
fwide( stderr, 1 );
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 ) {
fwide( stderr, 1 );
dump_object( stderr, pointer );
}
#endif
}

33
src/debug.h Normal file
View file

@ -0,0 +1,33 @@
/**
* 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
#define DEBUG_REPL 128
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 );
#endif

92
src/init.c
View file

@ -11,26 +11,32 @@
#include <stdbool.h> #include <stdbool.h>
#include <stdio.h> #include <stdio.h>
#include <stdlib.h>
#include <unistd.h> #include <unistd.h>
#include <wchar.h> #include <wchar.h>
#include "version.h" #include "version.h"
#include "conspage.h" #include "conspage.h"
#include "consspaceobject.h" #include "consspaceobject.h"
#include "debug.h"
#include "intern.h" #include "intern.h"
#include "lispops.h" #include "lispops.h"
#include "peano.h" #include "peano.h"
#include "print.h" #include "print.h"
#include "repl.h" #include "repl.h"
void bind_function( char *name, struct cons_pointer ( *executable ) // extern char *optarg; /* defined in unistd.h */
( struct stack_frame *, struct cons_pointer ) ) {
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 ), deep_bind( c_string_to_lisp_symbol( name ),
make_function( NIL, executable ) ); 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 * frame, struct cons_pointer env ) ) { ( struct stack_frame *,
struct cons_pointer, struct cons_pointer ) ) {
deep_bind( c_string_to_lisp_symbol( name ), deep_bind( c_string_to_lisp_symbol( name ),
make_special( NIL, executable ) ); make_special( NIL, executable ) );
} }
@ -46,7 +52,7 @@ int main( int argc, char *argv[] ) {
bool dump_at_end = false; bool dump_at_end = false;
bool show_prompt = false; bool show_prompt = false;
while ( ( option = getopt( argc, argv, "pdc" ) ) != -1 ) { while ( ( option = getopt( argc, argv, "cpdv:" ) ) != -1 ) {
switch ( option ) { switch ( option ) {
case 'c': case 'c':
print_use_colours = true; print_use_colours = true;
@ -57,6 +63,9 @@ int main( int argc, char *argv[] ) {
case 'p': case 'p':
show_prompt = true; show_prompt = true;
break; break;
case 'v':
verbosity = atoi( optarg );
break;
default: default:
fwprintf( stderr, L"Unexpected option %c\n", option ); fwprintf( stderr, L"Unexpected option %c\n", option );
break; break;
@ -69,53 +78,60 @@ int main( int argc, char *argv[] ) {
VERSION ); VERSION );
} }
debug_print( L"About to initialise cons pages\n", DEBUG_BOOTSTRAP );
initialise_cons_pages( ); initialise_cons_pages( );
debug_print( L"Initialised cons pages, about to bind\n", DEBUG_BOOTSTRAP );
/* /*
* privileged variables (keywords) * privileged variables (keywords)
*/ */
deep_bind( c_string_to_lisp_symbol( "nil" ), NIL ); deep_bind( c_string_to_lisp_symbol( L"nil" ), NIL );
deep_bind( c_string_to_lisp_symbol( "t" ), TRUE ); deep_bind( c_string_to_lisp_symbol( L"t" ), TRUE );
/* /*
* primitive function operations * primitive function operations
*/ */
bind_function( "add", &lisp_add ); bind_function( L"add", &lisp_add );
bind_function( "apply", &lisp_apply ); bind_function( L"apply", &lisp_apply );
bind_function( "assoc", &lisp_assoc ); bind_function( L"assoc", &lisp_assoc );
bind_function( "car", &lisp_car ); bind_function( L"car", &lisp_car );
bind_function( "cdr", &lisp_cdr ); bind_function( L"cdr", &lisp_cdr );
bind_function( "cons", &lisp_cons ); bind_function( L"cons", &lisp_cons );
bind_function( "divide", &lisp_divide ); bind_function( L"divide", &lisp_divide );
bind_function( "eq", &lisp_eq ); bind_function( L"eq", &lisp_eq );
bind_function( "equal", &lisp_equal ); bind_function( L"equal", &lisp_equal );
bind_function( "eval", &lisp_eval ); bind_function( L"eval", &lisp_eval );
bind_function( "multiply", &lisp_multiply ); bind_function( L"exception", &lisp_exception );
bind_function( "read", &lisp_read ); bind_function( L"multiply", &lisp_multiply );
bind_function( "oblist", &lisp_oblist ); bind_function( L"read", &lisp_read );
bind_function( "print", &lisp_print ); bind_function( L"oblist", &lisp_oblist );
bind_function( "progn", &lisp_progn ); bind_function( L"print", &lisp_print );
bind_function( "reverse", &lisp_reverse ); bind_function( L"progn", &lisp_progn );
bind_function( "set", &lisp_set ); bind_function( L"reverse", &lisp_reverse );
bind_function( "subtract", &lisp_subtract ); bind_function( L"set", &lisp_set );
bind_function( "type", &lisp_type ); bind_function( L"subtract", &lisp_subtract );
bind_function( L"throw", &lisp_exception );
bind_function( L"type", &lisp_type );
bind_function( "+", &lisp_add ); bind_function( L"+", &lisp_add );
bind_function( "*", &lisp_multiply ); bind_function( L"*", &lisp_multiply );
bind_function( "-", &lisp_subtract ); bind_function( L"-", &lisp_subtract );
bind_function( "/", &lisp_divide ); bind_function( L"/", &lisp_divide );
bind_function( "=", &lisp_equal ); bind_function( L"=", &lisp_equal );
/* /*
* primitive special forms * primitive special forms
*/ */
bind_special( "cond", &lisp_cond ); bind_special( L"cond", &lisp_cond );
bind_special( "lambda", &lisp_lambda ); bind_special( L"lambda", &lisp_lambda );
/* bind_special( "λ", &lisp_lambda ); */ // bind_special( L"λ", &lisp_lambda );
bind_special( "nlambda", &lisp_nlambda ); bind_special( L"nlambda", &lisp_nlambda );
bind_special( "progn", &lisp_progn ); // bind_special( L"nλ", &lisp_nlambda );
bind_special( "quote", &lisp_quote ); bind_special( L"progn", &lisp_progn );
bind_special( "set!", &lisp_set_shriek ); bind_special( L"quote", &lisp_quote );
bind_special( L"set!", &lisp_set_shriek );
repl( stdin, stdout, stderr, show_prompt ); repl( stdin, stdout, stderr, show_prompt );

32
src/memory/conspage.c
View file

@ -18,6 +18,8 @@
#include "consspaceobject.h" #include "consspaceobject.h"
#include "conspage.h" #include "conspage.h"
#include "debug.h"
#include "dump.h"
/** /**
* Flag indicating whether conspage initialisation has been done. * Flag indicating whether conspage initialisation has been done.
@ -64,7 +66,7 @@ void make_cons_page( ) {
cell->count = MAXREFERENCE; cell->count = MAXREFERENCE;
cell->payload.free.car = NIL; cell->payload.free.car = NIL;
cell->payload.free.cdr = 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; break;
case 1: case 1:
/* /*
@ -78,7 +80,7 @@ void make_cons_page( ) {
cell->payload.free.cdr = ( struct cons_pointer ) { cell->payload.free.cdr = ( struct cons_pointer ) {
0, 1 0, 1
}; };
fwprintf( stderr, L"Allocated special cell T\n" ); debug_printf( DEBUG_ALLOC, L"Allocated special cell T\n" );
break; break;
} }
} else { } else {
@ -95,7 +97,7 @@ void make_cons_page( ) {
initialised_cons_pages++; initialised_cons_pages++;
} else { } else {
fwprintf( stderr, debug_printf( DEBUG_ALLOC,
L"FATAL: Failed to allocate memory for cons page %d\n", L"FATAL: Failed to allocate memory for cons page %d\n",
initialised_cons_pages ); initialised_cons_pages );
exit( 1 ); exit( 1 );
@ -127,10 +129,8 @@ void dump_pages( FILE * output ) {
void free_cell( struct cons_pointer pointer ) { void free_cell( struct cons_pointer pointer ) {
struct cons_space_object *cell = &pointer2cell( pointer ); struct cons_space_object *cell = &pointer2cell( pointer );
#ifdef DEBUG debug_printf( DEBUG_ALLOC, L"Freeing cell " );
fwprintf( stderr, L"Freeing cell " ); debug_dump_object( pointer, DEBUG_ALLOC );
dump_object( stderr, pointer );
#endif
switch ( cell->tag.value ) { switch ( cell->tag.value ) {
/* for all the types of cons-space object which point to other /* for all the types of cons-space object which point to other
@ -164,11 +164,9 @@ void free_cell( struct cons_pointer pointer ) {
case VECTORPOINTTV: case VECTORPOINTTV:
/* for vector space pointers, free the actual vector-space /* for vector space pointers, free the actual vector-space
* object. Dangerous! */ * object. Dangerous! */
#ifdef DEBUG debug_printf( DEBUG_ALLOC, L"About to free vector-space object at %ld\n",
fwprintf( stderr, L"About to free vector-space object at %ld\n",
cell->payload.vectorp.address ); cell->payload.vectorp.address );
#endif //free( ( void * ) cell->payload.vectorp.address );
free( ( void * ) cell->payload.vectorp.address );
break; break;
} }
@ -180,12 +178,12 @@ void free_cell( struct cons_pointer pointer ) {
cell->payload.free.cdr = freelist; cell->payload.free.cdr = freelist;
freelist = pointer; freelist = pointer;
} else { } else {
fwprintf( stderr, debug_printf( DEBUG_ALLOC,
L"ERROR: Attempt to free cell with %d dangling references at page %d, offset %d\n", L"ERROR: Attempt to free cell with %d dangling references at page %d, offset %d\n",
cell->count, pointer.page, pointer.offset ); cell->count, pointer.page, pointer.offset );
} }
} else { } else {
fwprintf( stderr, debug_printf( DEBUG_ALLOC,
L"ERROR: Attempt to free cell which is already FREE at page %d, offset %d\n", L"ERROR: Attempt to free cell which is already FREE at page %d, offset %d\n",
pointer.page, pointer.offset ); pointer.page, pointer.offset );
} }
@ -217,13 +215,11 @@ struct cons_pointer allocate_cell( char *tag ) {
cell->payload.cons.car = NIL; cell->payload.cons.car = NIL;
cell->payload.cons.cdr = NIL; cell->payload.cons.cdr = NIL;
#ifdef DEBUG debug_printf( DEBUG_ALLOC,
fwprintf( stderr,
L"Allocated cell of type '%s' at %d, %d \n", tag, L"Allocated cell of type '%s' at %d, %d \n", tag,
result.page, result.offset ); result.page, result.offset );
#endif
} else { } else {
fwprintf( stderr, L"WARNING: Allocating non-free cell!" ); debug_printf( DEBUG_ALLOC, L"WARNING: Allocating non-free cell!" );
} }
} }
@ -242,7 +238,7 @@ void initialise_cons_pages( ) {
make_cons_page( ); make_cons_page( );
conspageinitihasbeencalled = true; conspageinitihasbeencalled = true;
} else { } else {
fwprintf( stderr, debug_printf( DEBUG_ALLOC,
L"WARNING: initialise_cons_pages() called a second or subsequent time\n" ); L"WARNING: initialise_cons_pages() called a second or subsequent time\n" );
} }
} }

135
src/memory/consspaceobject.c
View file

@ -20,6 +20,7 @@
#include "conspage.h" #include "conspage.h"
#include "consspaceobject.h" #include "consspaceobject.h"
#include "debug.h"
#include "print.h" #include "print.h"
#include "stack.h" #include "stack.h"
@ -63,98 +64,6 @@ void dec_ref( struct cons_pointer pointer ) {
} }
} }
void dump_string_cell( FILE * output, wchar_t *prefix,
struct cons_pointer pointer ) {
struct cons_space_object cell = pointer2cell( pointer );
if ( cell.payload.string.character == 0 ) {
fwprintf( output,
L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n",
prefix,
cell.payload.string.cdr.page, cell.payload.string.cdr.offset,
cell.count );
} else {
fwprintf( output,
L"\t\t%ls cell: character '%lc' (%d) next at page %d offset %d, count %u\n",
prefix,
( wint_t ) cell.payload.string.character,
cell.payload.string.character,
cell.payload.string.cdr.page,
cell.payload.string.cdr.offset, cell.count );
fwprintf( output, L"\t\t value: " );
print( output, pointer );
fwprintf( output, L"\n" );
}
}
/**
* dump the object at this cons_pointer to this output stream.
*/
void dump_object( FILE * output, struct cons_pointer pointer ) {
struct cons_space_object cell = pointer2cell( pointer );
fwprintf( output,
L"\t%c%c%c%c (%d) at page %d, offset %d count %u\n",
cell.tag.bytes[0],
cell.tag.bytes[1],
cell.tag.bytes[2],
cell.tag.bytes[3],
cell.tag.value, pointer.page, pointer.offset, cell.count );
switch ( cell.tag.value ) {
case CONSTV:
fwprintf( output,
L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u\n",
cell.payload.cons.car.page,
cell.payload.cons.car.offset,
cell.payload.cons.cdr.page,
cell.payload.cons.cdr.offset, cell.count );
break;
case EXCEPTIONTV:
fwprintf( output, L"\t\tException cell: " );
print( output, cell.payload.exception.message );
fwprintf( output, L"\n" );
for ( struct stack_frame * frame = cell.payload.exception.frame;
frame != NULL; frame = frame->previous ) {
dump_frame( output, frame );
}
break;
case FREETV:
fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n",
cell.payload.cons.cdr.page,
cell.payload.cons.cdr.offset );
break;
case INTEGERTV:
fwprintf( output,
L"\t\tInteger cell: value %ld, count %u\n",
cell.payload.integer.value, cell.count );
break;
case LAMBDATV:
fwprintf( output, L"\t\tLambda cell; args: " );
print( output, cell.payload.lambda.args );
fwprintf( output, L";\n\t\t\tbody: " );
print( output, cell.payload.lambda.body );
break;
case RATIOTV:
fwprintf( output,
L"\t\tRational cell: value %ld/%ld, count %u\n",
pointer2cell( cell.payload.ratio.dividend ).payload.
integer.value,
pointer2cell( cell.payload.ratio.divisor ).payload.
integer.value, cell.count );
break;
case READTV:
fwprintf( output, L"\t\tInput stream\n" );
case REALTV:
fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n",
cell.payload.real.value, cell.count );
break;
case STRINGTV:
dump_string_cell( output, L"String", pointer );
break;
case SYMBOLTV:
dump_string_cell( output, L"Symbol", pointer );
break;
}
}
/** /**
* Construct a cons cell from this pair of pointers. * Construct a cons cell from this pair of pointers.
@ -178,20 +87,24 @@ struct cons_pointer make_cons( struct cons_pointer car,
/** /**
* Construct an exception cell. * Construct an exception cell.
* @param message should be a lisp string describing the problem, but actually any cons pointer will do; * @param message should be a lisp string describing the problem, but actually any cons pointer will do;
* @param frame should be the frame in which the exception occurred. * @param frame_pointer should be the pointer to the frame in which the exception occurred.
*/ */
struct cons_pointer make_exception( struct cons_pointer message, struct cons_pointer make_exception( struct cons_pointer message,
struct stack_frame *frame ) { struct cons_pointer frame_pointer ) {
struct cons_pointer result = NIL;
struct cons_pointer pointer = allocate_cell( EXCEPTIONTAG ); struct cons_pointer pointer = allocate_cell( EXCEPTIONTAG );
struct cons_space_object *cell = &pointer2cell( pointer ); struct cons_space_object *cell = &pointer2cell( pointer );
inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */ inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */
inc_ref( message ); inc_ref( message );
inc_ref( frame_pointer );
cell->payload.exception.message = message; cell->payload.exception.message = message;
cell->payload.exception.frame = frame; cell->payload.exception.frame = frame_pointer;
return pointer; result = pointer;
return result;
} }
@ -200,7 +113,8 @@ struct cons_pointer make_exception( struct cons_pointer message,
*/ */
struct cons_pointer struct cons_pointer
make_function( struct cons_pointer src, struct cons_pointer ( *executable ) make_function( struct cons_pointer src, struct cons_pointer ( *executable )
( struct stack_frame *, struct cons_pointer ) ) { ( struct stack_frame *,
struct cons_pointer, struct cons_pointer ) ) {
struct cons_pointer pointer = allocate_cell( FUNCTIONTAG ); struct cons_pointer pointer = allocate_cell( FUNCTIONTAG );
struct cons_space_object *cell = &pointer2cell( pointer ); struct cons_space_object *cell = &pointer2cell( pointer );
@ -265,11 +179,13 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) {
cell->payload.string.character = c; cell->payload.string.character = c;
cell->payload.string.cdr.page = tail.page; cell->payload.string.cdr.page = tail.page;
/* TODO: There's a problem here. Sometimes the offsets on /* 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; cell->payload.string.cdr.offset = tail.offset;
} else { } else {
fwprintf( stderr, // TODO: should throw an exception!
L"Warning: only NIL and %s can be appended to %s\n", debug_printf( DEBUG_ALLOC,
L"Warning: only NIL and %s can be prepended to %s\n",
tag, tag ); tag, tag );
} }
@ -298,7 +214,8 @@ struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) {
*/ */
struct cons_pointer struct cons_pointer
make_special( struct cons_pointer src, struct cons_pointer ( *executable ) make_special( struct cons_pointer src, struct cons_pointer ( *executable )
( struct stack_frame * frame, struct cons_pointer env ) ) { ( struct stack_frame * frame,
struct cons_pointer, struct cons_pointer env ) ) {
struct cons_pointer pointer = allocate_cell( SPECIALTAG ); struct cons_pointer pointer = allocate_cell( SPECIALTAG );
struct cons_space_object *cell = &pointer2cell( pointer ); struct cons_space_object *cell = &pointer2cell( pointer );
@ -335,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; struct cons_pointer result = NIL;
for ( int i = strlen( string ); i > 0; i-- ) { for ( int i = wcslen( string ); i > 0; i-- ) {
result = make_string( ( wint_t ) string[i - 1], result ); result = make_string( string[i - 1], result );
} }
return 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; struct cons_pointer result = NIL;
for ( int i = strlen( symbol ); i > 0; i-- ) { for ( int i = wcslen( symbol ); i > 0; i-- ) {
result = make_symbol( ( wint_t ) symbol[i - 1], result ); result = make_symbol( symbol[i - 1], result );
} }
return result; return result;

49
src/memory/consspaceobject.h
View file

@ -133,7 +133,7 @@
* A pointer to an object in vector space. * A pointer to an object in vector space.
*/ */
#define VECTORPOINTTAG "VECP" #define VECTORPOINTTAG "VECP"
#define VECTORPOINTTV 0 #define VECTORPOINTTV 1346585942
/** /**
* An open write stream. * An open write stream.
*/ */
@ -263,9 +263,10 @@
* An indirect pointer to a cons cell * An indirect pointer to a cons cell
*/ */
struct cons_pointer { struct cons_pointer {
uint32_t page; /* the index of the page on which this cell /** the index of the page on which this cell resides */
* resides */ uint32_t page;
uint32_t offset; /* the index of the cell within the page */ /** the index of the cell within the page */
uint32_t offset;
}; };
/* /*
@ -278,13 +279,14 @@ struct cons_pointer {
* here to avoid circularity. TODO: refactor. * here to avoid circularity. TODO: refactor.
*/ */
struct stack_frame { struct stack_frame {
struct stack_frame *previous; /* the previous frame */ struct cons_pointer previous; /* the previous frame */
struct cons_pointer arg[args_in_frame]; struct cons_pointer arg[args_in_frame];
/* /*
* first 8 arument bindings * first 8 arument bindings
*/ */
struct cons_pointer more; /* list of any further argument bindings */ struct cons_pointer more; /* list of any further argument bindings */
struct cons_pointer function; /* the function to be called */ struct cons_pointer function; /* the function to be called */
int args;
}; };
/** /**
@ -311,7 +313,7 @@ struct cons_payload {
*/ */
struct exception_payload { struct exception_payload {
struct cons_pointer message; struct cons_pointer message;
struct stack_frame *frame; struct cons_pointer frame;
}; };
/** /**
@ -326,6 +328,7 @@ struct exception_payload {
struct function_payload { struct function_payload {
struct cons_pointer source; struct cons_pointer source;
struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer ( *executable ) ( struct stack_frame *,
struct cons_pointer,
struct cons_pointer ); struct cons_pointer );
}; };
@ -379,13 +382,11 @@ struct real_payload {
* its argument list) and a cons pointer (representing its environment) and a * its argument list) and a cons pointer (representing its environment) and a
* stack frame (representing the previous stack frame) as arguments and returns * stack frame (representing the previous stack frame) as arguments and returns
* a cons pointer (representing its result). * a cons pointer (representing its result).
*
* NOTE that this means that special forms do not appear on the lisp stack,
* which may be confusing. TODO: think about this.
*/ */
struct special_payload { struct special_payload {
struct cons_pointer source; struct cons_pointer source;
struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer ( *executable ) ( struct stack_frame *,
struct cons_pointer,
struct cons_pointer ); struct cons_pointer );
}; };
@ -421,7 +422,8 @@ struct vectorp_payload {
* tag. */ * tag. */
uint32_t value; /* the tag considered as a number */ uint32_t value; /* the tag considered as a number */
} tag; } tag;
uint64_t address; /* the address of the actual vector space void *address;
/* the address of the actual vector space
* object (TODO: will change when I actually * object (TODO: will change when I actually
* implement vector space) */ * implement vector space) */
}; };
@ -514,20 +516,11 @@ void inc_ref( struct cons_pointer pointer );
*/ */
void dec_ref( struct cons_pointer pointer ); void dec_ref( struct cons_pointer pointer );
/**
* dump the object at this cons_pointer to this output stream.
*/
void dump_object( FILE * output, struct cons_pointer pointer );
struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer make_cons( struct cons_pointer car,
struct cons_pointer cdr ); struct cons_pointer cdr );
/**
* Construct an exception cell.
* @param message should be a lisp string describing the problem, but actually any cons pointer will do;
* @param frame should be the frame in which the exception occurred.
*/
struct cons_pointer make_exception( struct cons_pointer message, struct cons_pointer make_exception( struct cons_pointer message,
struct stack_frame *frame ); struct cons_pointer frame_pointer );
/** /**
* Construct a cell which points to an executable Lisp special form. * Construct a cell which points to an executable Lisp special form.
@ -535,6 +528,7 @@ struct cons_pointer make_exception( struct cons_pointer message,
struct cons_pointer make_function( struct cons_pointer src, struct cons_pointer make_function( struct cons_pointer src,
struct cons_pointer ( *executable ) struct cons_pointer ( *executable )
( struct stack_frame *, ( struct stack_frame *,
struct cons_pointer,
struct cons_pointer ) ); struct cons_pointer ) );
/** /**
@ -550,20 +544,13 @@ struct cons_pointer make_lambda( struct cons_pointer args,
struct cons_pointer make_nlambda( struct cons_pointer args, struct cons_pointer make_nlambda( struct cons_pointer args,
struct cons_pointer body ); struct cons_pointer body );
/**
* Construct a ratio frame from these two pointers, expected to be integers
* or (later) bignums, in the context of this stack_frame.
*/
struct cons_pointer make_ratio( struct stack_frame *frame,
struct cons_pointer dividend,
struct cons_pointer divisor );
/** /**
* Construct a cell which points to an executable Lisp special form. * Construct a cell which points to an executable Lisp special form.
*/ */
struct cons_pointer make_special( struct cons_pointer src, struct cons_pointer make_special( struct cons_pointer src,
struct cons_pointer ( *executable ) struct cons_pointer ( *executable )
( struct stack_frame *, ( struct stack_frame *,
struct cons_pointer,
struct cons_pointer ) ); struct cons_pointer ) );
/** /**
@ -595,11 +582,11 @@ 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 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. * 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 #endif

9
src/memory/cursor.c Normal file
View file

@ -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)
*/

BIN
src/memory/cursor.h Normal file
View file

Binary file not shown.

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

@ -0,0 +1,140 @@
/*
* 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 "debug.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%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 ) {
case CONSTV:
fwprintf( output,
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: " );
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 NILTV:
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" );
break;
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 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 (%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;
}
}
break;
case WRITETV:
fwprintf( output, L"\t\tOutput stream\n" );
break;
}
}

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

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

195
src/memory/stack.c
View file

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

50
src/memory/stack.h
View file

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

58
src/memory/vectorspace.c
View file

@ -8,6 +8,7 @@
* Licensed under GPL version 2.0, or, at your option, any later version. * Licensed under GPL version 2.0, or, at your option, any later version.
*/ */
#include <math.h>
#include <stdint.h> #include <stdint.h>
#include <stdlib.h> #include <stdlib.h>
#include <string.h> #include <string.h>
@ -20,6 +21,7 @@
#include "conspage.h" #include "conspage.h"
#include "consspaceobject.h" #include "consspaceobject.h"
#include "debug.h"
#include "vectorspace.h" #include "vectorspace.h"
@ -29,12 +31,18 @@
* NOTE that `tag` should be the vector-space tag of the particular type of * NOTE that `tag` should be the vector-space tag of the particular type of
* vector-space object, NOT `VECTORPOINTTAG`. * vector-space object, NOT `VECTORPOINTTAG`.
*/ */
struct cons_pointer make_vec_pointer( char *tag, uint64_t address ) { struct cons_pointer make_vec_pointer( struct vector_space_object *address ) {
debug_print( L"Entered make_vec_pointer\n", DEBUG_ALLOC );
struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG ); struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG );
struct cons_space_object cell = pointer2cell( pointer ); struct cons_space_object *cell = &pointer2cell( pointer );
debug_printf( DEBUG_ALLOC,
L"make_vec_pointer: tag written, about to set pointer address to %p\n",
address );
cell->payload.vectorp.address = address;
debug_printf( DEBUG_ALLOC, L"make_vec_pointer: all good, returning pointer to %p\n",
cell->payload.vectorp.address );
strncpy( &cell.payload.vectorp.tag.bytes[0], tag, 4 ); debug_dump_object( pointer, DEBUG_ALLOC );
cell.payload.vectorp.address = address;
return pointer; return pointer;
} }
@ -44,26 +52,46 @@ struct cons_pointer make_vec_pointer( char *tag, uint64_t address ) {
* and return a `cons_pointer` which points to an object whigh points to it. * and return a `cons_pointer` which points to an object whigh points to it.
* NOTE that `tag` should be the vector-space tag of the particular type of * NOTE that `tag` should be the vector-space tag of the particular type of
* vector-space object, NOT `VECTORPOINTTAG`. * vector-space object, NOT `VECTORPOINTTAG`.
* Returns NIL if the vector could not be allocated due to memory exhaustion.
*/ */
struct cons_pointer make_vso( char *tag, int64_t payload_size ) { struct cons_pointer make_vso( char *tag, uint64_t payload_size ) {
debug_print( L"Entered make_vso\n", DEBUG_ALLOC );
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
int64_t total_size = sizeof( struct vector_space_header ) + payload_size; int64_t total_size = sizeof( struct vector_space_header ) + payload_size;
struct vector_space_header *vso = malloc( total_size ); /* Pad size to 64 bit words. This is intended to promote access efficiancy
* on 64 bit machines but may just be voodoo coding */
uint64_t padded = ceil( ( total_size * 8.0 ) / 8.0 );
debug_print( L"make_vso: about to malloc\n", DEBUG_ALLOC );
struct vector_space_object *vso = malloc( padded );
if ( vso != NULL ) { if ( vso != NULL ) {
strncpy( &vso->tag.bytes[0], tag, TAGLENGTH ); debug_printf( DEBUG_ALLOC,
vso->vecp = make_vec_pointer( tag, ( uint64_t ) vso ); L"make_vso: about to write tag '%s' into vso at %p\n", tag,
vso->size = payload_size; vso );
strncpy( &vso->header.tag.bytes[0], tag, TAGLENGTH );
result = make_vec_pointer( vso );
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 #ifdef DEBUG
fwprintf( stderr, debug_printf( DEBUG_ALLOC,
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, at address %p, payload address %p\n",
tag, total_size, payload_size ); &vso->header.tag.bytes, total_size, vso->header.size, vso,
#endif &vso->payload );
if ( padded != total_size ) {
result = vso->vecp; debug_printf( DEBUG_ALLOC, L"\t\tPadded from %d to %d\n",
total_size, padded );
} }
#endif
}
#ifdef DEBUG
debug_printf( DEBUG_ALLOC, L"make_vso: all good, returning pointer to %p\n",
pointer2cell( result ).payload.vectorp.address );
#endif
return result; return result;
} }

16
src/memory/vectorspace.h
View file

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

4
src/ops/equal.c
View file

@ -80,8 +80,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
&& ( equal( cell_a->payload.string.cdr, && ( equal( cell_a->payload.string.cdr,
cell_b->payload.string.cdr ) cell_b->payload.string.cdr )
|| ( end_of_string( cell_a->payload.string.cdr ) || ( end_of_string( cell_a->payload.string.cdr )
&& end_of_string( cell_b->payload.string. && end_of_string( cell_b->payload.
cdr ) ) ); string.cdr ) ) );
break; break;
case INTEGERTV: case INTEGERTV:
result = result =

37
src/ops/intern.c
View file

@ -21,6 +21,7 @@
#include "conspage.h" #include "conspage.h"
#include "consspaceobject.h" #include "consspaceobject.h"
#include "debug.h"
#include "equal.h" #include "equal.h"
#include "lispops.h" #include "lispops.h"
#include "print.h" #include "print.h"
@ -56,22 +57,22 @@ internedp( struct cons_pointer key, struct cons_pointer store ) {
struct cons_space_object entry = struct cons_space_object entry =
pointer2cell( pointer2cell( next ).payload.cons.car ); pointer2cell( pointer2cell( next ).payload.cons.car );
fputws( L"Internedp: checking whether `", stderr ); debug_print( L"Internedp: checking whether `", DEBUG_ALLOC );
print( stderr, key ); debug_print_object( key, DEBUG_ALLOC );
fputws( L"` equals `", stderr ); debug_print( L"` equals `", DEBUG_ALLOC );
print( stderr, entry.payload.cons.car ); debug_print_object( entry.payload.cons.car, DEBUG_ALLOC );
fputws( L"`\n", stderr ); debug_print( L"`\n", DEBUG_ALLOC );
if ( equal( key, entry.payload.cons.car ) ) { if ( equal( key, entry.payload.cons.car ) ) {
result = entry.payload.cons.car; result = entry.payload.cons.car;
} }
} }
} else { } else {
fputws( L"`", stderr ); debug_print( L"`", DEBUG_ALLOC );
print( stderr, key ); debug_print_object( key, DEBUG_ALLOC );
fputws( L"` is a ", stderr ); debug_print( L"` is a ", DEBUG_ALLOC );
print( stderr, c_type( key ) ); debug_print_object( c_type( key ), DEBUG_ALLOC );
fputws( L", not a SYMB", stderr ); debug_print( L", not a SYMB", DEBUG_ALLOC );
} }
return result; return result;
@ -110,6 +111,12 @@ struct cons_pointer c_assoc( struct cons_pointer key,
struct cons_pointer struct cons_pointer
bind( struct cons_pointer key, struct cons_pointer value, bind( struct cons_pointer key, struct cons_pointer value,
struct cons_pointer store ) { 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 ); return make_cons( make_cons( key, value ), store );
} }
@ -120,7 +127,17 @@ bind( struct cons_pointer key, struct cons_pointer value,
*/ */
struct cons_pointer struct cons_pointer
deep_bind( struct cons_pointer key, struct cons_pointer value ) { 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 ); oblist = bind( key, value, oblist );
debug_print( L"Leaving deep_bind\n", DEBUG_ALLOC );
return oblist; return oblist;
} }

376
src/ops/lispops.c
View file

@ -26,6 +26,8 @@
#include "consspaceobject.h" #include "consspaceobject.h"
#include "conspage.h" #include "conspage.h"
#include "debug.h"
#include "dump.h"
#include "equal.h" #include "equal.h"
#include "integer.h" #include "integer.h"
#include "intern.h" #include "intern.h"
@ -80,22 +82,27 @@ struct cons_pointer c_cdr( struct cons_pointer arg ) {
* @return the result of evaluating the form. * @return the result of evaluating the form.
*/ */
struct cons_pointer eval_form( struct stack_frame *parent, struct cons_pointer eval_form( struct stack_frame *parent,
struct cons_pointer parent_pointer,
struct cons_pointer form, struct cons_pointer form,
struct cons_pointer env ) { struct cons_pointer env ) {
fputws( L"eval_form: ", stderr ); debug_print( L"eval_form: ", DEBUG_EVAL );
print( stderr, form ); debug_dump_object( form, DEBUG_EVAL );
fputws( L"\n", stderr );
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct stack_frame *next = make_empty_frame( parent, env ); struct cons_pointer next_pointer = make_empty_frame( parent_pointer );
inc_ref( next_pointer );
struct stack_frame *next = get_stack_frame( next_pointer );
set_reg( next, 0, form ); set_reg( next, 0, form );
result = lisp_eval( next, env ); next->args = 1;
result = lisp_eval( next, next_pointer, env );
if ( !exceptionp( result ) ) { if ( !exceptionp( result ) ) {
/* if we're returning an exception, we should NOT free the /* if we're returning an exception, we should NOT free the
* stack frame. Corollary is, when we free an exception, we * stack frame. Corollary is, when we free an exception, we
* should free all the frames it's holding on to. */ * should free all the frames it's holding on to. */
free_stack_frame( next ); dec_ref( next_pointer );
} }
return result; return result;
@ -107,11 +114,14 @@ struct cons_pointer eval_form( struct stack_frame *parent,
* `list` is not in fact a list, return nil. * `list` is not in fact a list, return nil.
*/ */
struct cons_pointer eval_forms( struct stack_frame *frame, struct cons_pointer eval_forms( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer list, struct cons_pointer list,
struct cons_pointer env ) { struct cons_pointer env ) {
/* TODO: refactor. This runs up the C stack. */
return consp( list ) ? return consp( list ) ?
make_cons( eval_form( frame, c_car( list ), env ), make_cons( eval_form( frame, frame_pointer, c_car( list ), env ),
eval_forms( frame, c_cdr( list ), env ) ) : NIL; eval_forms( frame, frame_pointer, c_cdr( list ),
env ) ) : NIL;
} }
/** /**
@ -120,7 +130,8 @@ struct cons_pointer eval_forms( struct stack_frame *frame,
* (oblist) * (oblist)
*/ */
struct cons_pointer struct cons_pointer
lisp_oblist( struct stack_frame *frame, struct cons_pointer env ) { lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return oblist; return oblist;
} }
@ -139,9 +150,8 @@ struct cons_pointer compose_body( struct stack_frame *frame ) {
} }
} }
fputws( L"compose_body returning ", stderr ); debug_print( L"compose_body returning ", DEBUG_LAMBDA );
print( stderr, body ); debug_dump_object( body, DEBUG_LAMBDA );
fputws( L"\n", stderr );
return body; return body;
} }
@ -153,7 +163,8 @@ struct cons_pointer compose_body( struct stack_frame *frame ) {
* @param env the environment in which it is to be intepreted. * @param env the environment in which it is to be intepreted.
*/ */
struct cons_pointer struct cons_pointer
lisp_lambda( struct stack_frame *frame, struct cons_pointer env ) { lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return make_lambda( frame->arg[0], compose_body( frame ) ); return make_lambda( frame->arg[0], compose_body( frame ) );
} }
@ -164,18 +175,16 @@ lisp_lambda( struct stack_frame *frame, struct cons_pointer env ) {
* @param env the environment in which it is to be intepreted. * @param env the environment in which it is to be intepreted.
*/ */
struct cons_pointer struct cons_pointer
lisp_nlambda( struct stack_frame *frame, struct cons_pointer env ) { lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return make_nlambda( frame->arg[0], compose_body( frame ) ); return make_nlambda( frame->arg[0], compose_body( frame ) );
} }
void log_binding( struct cons_pointer name, struct cons_pointer val ) { void log_binding( struct cons_pointer name, struct cons_pointer val ) {
#ifdef DEBUG debug_print( L"\n\tBinding ", DEBUG_ALLOC );
fputws( L"\n\tBinding ", stderr ); debug_dump_object( name, DEBUG_ALLOC );
print( stderr, name ); debug_print( L" to ", DEBUG_ALLOC );
fputws( L" to ", stderr ); debug_dump_object( val, DEBUG_ALLOC );
print( stderr, val );
fputws( L"\"\n", stderr );
#endif
} }
/** /**
@ -183,9 +192,9 @@ void log_binding( struct cons_pointer name, struct cons_pointer val ) {
*/ */
struct cons_pointer struct cons_pointer
eval_lambda( struct cons_space_object cell, struct stack_frame *frame, eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
struct cons_pointer env ) { struct cons_pointer frame_pointer, struct cons_pointer env ) {
struct cons_pointer result = NIL; 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 new_env = env;
struct cons_pointer names = cell.payload.lambda.args; struct cons_pointer names = cell.payload.lambda.args;
@ -194,7 +203,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
if ( consp( names ) ) { if ( consp( names ) ) {
/* if `names` is a list, bind successive items from that list /* if `names` is a list, bind successive items from that list
* to values of arguments */ * 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 name = c_car( names );
struct cons_pointer val = frame->arg[i]; struct cons_pointer val = frame->arg[i];
@ -203,13 +212,16 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
names = c_cdr( names ); names = c_cdr( names );
} }
/* TODO: if there's more than `args_in_frame` arguments, bind those too. */
} else if ( symbolp( names ) ) { } else if ( symbolp( names ) ) {
/* if `names` is a symbol, rather than a list of symbols, /* if `names` is a symbol, rather than a list of symbols,
* then bind a list of the values of args to that symbol. */ * then bind a list of the values of args to that symbol. */
/* TODO: eval all the things in frame->more */
struct cons_pointer vals = frame->more; struct cons_pointer vals = frame->more;
for ( int i = args_in_frame - 1; i >= 0; i-- ) { for ( int i = args_in_frame - 1; i >= 0; i-- ) {
struct cons_pointer val = eval_form( frame, frame->arg[i], env ); struct cons_pointer val =
eval_form( frame, frame_pointer, frame->arg[i], env );
if ( nilp( val ) && nilp( vals ) ) { /* nothing */ if ( nilp( val ) && nilp( vals ) ) { /* nothing */
} else { } else {
@ -223,8 +235,10 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
while ( !nilp( body ) ) { while ( !nilp( body ) ) {
struct cons_pointer sexpr = c_car( body ); struct cons_pointer sexpr = c_car( body );
body = c_cdr( body ); body = c_cdr( body );
fputws( L"In lambda: ", stderr );
result = eval_form( frame, sexpr, new_env ); debug_print( L"In lambda: ", DEBUG_LAMBDA );
result = eval_form( frame, frame_pointer, sexpr, new_env );
} }
return result; return result;
@ -239,19 +253,17 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
* @return the result of evaluating the function with its arguments. * @return the result of evaluating the function with its arguments.
*/ */
struct cons_pointer struct cons_pointer
c_apply( struct stack_frame *frame, struct cons_pointer env ) { c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
debug_print(L"Entering c_apply\n", DEBUG_EVAL);
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct stack_frame *fn_frame = make_empty_frame( frame, env );
set_reg( fn_frame, 0, c_car( frame->arg[0] ) );
struct cons_pointer fn_pointer = lisp_eval( fn_frame, env );
if ( !exceptionp( result ) ) { struct cons_pointer fn_pointer =
/* if we're returning an exception, we should NOT free the eval_form( frame, frame_pointer, c_car( frame->arg[0] ), env );
* 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 );
}
if ( exceptionp( fn_pointer ) ) {
result = fn_pointer;
} else {
struct cons_space_object fn_cell = pointer2cell( fn_pointer ); struct cons_space_object fn_cell = pointer2cell( fn_pointer );
struct cons_pointer args = c_cdr( frame->arg[0] ); struct cons_pointer args = c_cdr( frame->arg[0] );
@ -263,84 +275,92 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
case FUNCTIONTV: case FUNCTIONTV:
{ {
struct cons_pointer exep = NIL; struct cons_pointer exep = NIL;
struct stack_frame *next = struct cons_pointer next_pointer =
make_stack_frame( frame, args, env, &exep ); make_stack_frame( frame_pointer, args, env );
result = ( *fn_cell.payload.special.executable ) ( next, env ); inc_ref( next_pointer );
if ( exceptionp( exep ) ) { if ( exceptionp( next_pointer ) ) {
/* if we're returning an exception, we should NOT free the result = next_pointer;
* stack frame. Corollary is, when we free an exception, we
* should free all the frames it's holding on to. */
result = exep;
} else { } else {
free_stack_frame( next ); struct stack_frame *next = get_stack_frame( next_pointer );
result =
( *fn_cell.payload.function.executable ) ( next,
next_pointer,
env );
dec_ref( next_pointer );
} }
} }
break; break;
case LAMBDATV: case LAMBDATV:
{ {
struct cons_pointer exep = NIL; struct cons_pointer exep = NIL;
struct stack_frame *next = struct cons_pointer next_pointer =
make_stack_frame( frame, args, env, &exep ); make_stack_frame( frame_pointer, args, env );
#ifdef DEBUG inc_ref( next_pointer );
fputws( L"Stack frame for lambda\n", stderr ); if ( exceptionp( next_pointer ) ) {
dump_frame( stderr, next ); result = next_pointer;
#endif
result = eval_lambda( fn_cell, next, env );
if ( exceptionp( result ) ) {
/* if we're returning an exception, we should NOT free the
* stack frame. Corollary is, when we free an exception, we
* should free all the frames it's holding on to. */
result = exep;
} else { } else {
free_stack_frame( next ); struct stack_frame *next = get_stack_frame( next_pointer );
result = eval_lambda( fn_cell, next, next_pointer, env );
if ( !exceptionp( result ) ) {
dec_ref( next_pointer );
}
} }
} }
break; break;
case NLAMBDATV: case NLAMBDATV:
{ {
struct 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 = struct stack_frame *next =
make_special_frame( frame, args, env ); get_stack_frame( next_pointer );
#ifdef DEBUG result = eval_lambda( fn_cell, next, next_pointer, env );
fputws( L"Stack frame for nlambda\n", stderr ); dec_ref( next_pointer );
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. */
free_stack_frame( next );
} }
} }
break; break;
case SPECIALTV: case SPECIALTV:
{ {
struct stack_frame *next = struct cons_pointer next_pointer =
make_special_frame( frame, args, env ); make_special_frame( frame_pointer, args, env );
result = ( *fn_cell.payload.special.executable ) ( next, env ); inc_ref( next_pointer );
if ( !exceptionp( result ) ) { if ( exceptionp( next_pointer ) ) {
/* if we're returning an exception, we should NOT free the result = next_pointer;
* stack frame. Corollary is, when we free an exception, we } else {
* should free all the frames it's holding on to. */ result =
free_stack_frame( next ); ( *fn_cell.payload.special.executable ) ( get_stack_frame( next_pointer ),
next_pointer,
env );
debug_print(L"Special form returning: ", DEBUG_EVAL);
debug_print_object(result, DEBUG_EVAL);
debug_println(DEBUG_EVAL);
dec_ref( next_pointer );
} }
} }
break; break;
default: default:
{ {
char *buffer = malloc( 1024 ); int bs = sizeof(wchar_t) * 1024;
memset( buffer, '\0', 1024 ); wchar_t *buffer = malloc( bs );
sprintf( buffer, memset( buffer, '\0', bs );
"Unexpected cell with tag %d (%c%c%c%c) in function position", swprintf( buffer, bs,
fn_cell.tag.value, fn_cell.tag.bytes[0], L"Unexpected cell with tag %d (%4.4s) in function position",
fn_cell.tag.bytes[1], fn_cell.tag.bytes[2], fn_cell.tag.value, &fn_cell.tag.bytes[0] );
fn_cell.tag.bytes[3] );
struct cons_pointer message = struct cons_pointer message =
c_string_to_lisp_string( buffer ); c_string_to_lisp_string( buffer );
free( buffer ); free( buffer );
result = lisp_throw( message, frame ); result = throw_exception( message, frame_pointer );
} }
} }
}
debug_print(L"c_apply: returning: ", DEBUG_EVAL);
debug_print_object(result, DEBUG_EVAL);
debug_println(DEBUG_EVAL);
return result; return result;
} }
@ -352,13 +372,13 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
* @return As a Lisp string, the tag of the object which is at that 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 ) { struct cons_pointer c_type( struct cons_pointer pointer ) {
char *buffer = malloc( TAGLENGTH + 1 ); struct cons_pointer result = NIL;
memset( buffer, 0, TAGLENGTH + 1 );
struct cons_space_object cell = pointer2cell( pointer ); struct cons_space_object cell = pointer2cell( pointer );
strncpy( buffer, cell.tag.bytes, TAGLENGTH );
struct cons_pointer result = c_string_to_lisp_string( buffer ); for (int i = TAGLENGTH; i >= 0; i--)
free( buffer ); {
result = make_string((wchar_t)cell.tag.bytes[i], result);
}
return result; return result;
} }
@ -378,19 +398,18 @@ struct cons_pointer c_type( struct cons_pointer pointer ) {
* If a special form, passes the cdr of s_expr to the special form as argument. * If a special form, passes the cdr of s_expr to the special form as argument.
*/ */
struct cons_pointer struct cons_pointer
lisp_eval( struct stack_frame *frame, struct cons_pointer env ) { lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
debug_print( L"Eval: ", DEBUG_EVAL );
debug_dump_object( frame_pointer, DEBUG_EVAL );
struct cons_pointer result = frame->arg[0]; struct cons_pointer result = frame->arg[0];
struct cons_space_object cell = pointer2cell( frame->arg[0] ); struct cons_space_object cell = pointer2cell( frame->arg[0] );
#ifdef DEBUG
fputws( L"Eval: ", stderr );
dump_frame( stderr, frame );
#endif
switch ( cell.tag.value ) { switch ( cell.tag.value ) {
case CONSTV: case CONSTV:
{ {
result = c_apply( frame, env ); result = c_apply( frame, frame_pointer, env );
} }
break; break;
@ -401,9 +420,9 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
if ( nilp( canonical ) ) { if ( nilp( canonical ) ) {
struct cons_pointer message = struct cons_pointer message =
make_cons( c_string_to_lisp_string 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] ); frame->arg[0] );
result = lisp_throw( message, frame ); result = throw_exception( message, frame_pointer );
} else { } else {
result = c_assoc( canonical, env ); result = c_assoc( canonical, env );
inc_ref( result ); inc_ref( result );
@ -423,11 +442,8 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
break; break;
} }
#ifdef DEBUG debug_print( L"Eval returning ", DEBUG_EVAL );
fputws( L"Eval returning ", stderr ); debug_dump_object( result, DEBUG_EVAL );
print( stderr, result );
fputws( L"\n", stderr );
#endif
return result; return result;
} }
@ -441,21 +457,19 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
* the second argument * the second argument
*/ */
struct cons_pointer struct cons_pointer
lisp_apply( struct stack_frame *frame, struct cons_pointer env ) { lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
#ifdef DEBUG #ifdef DEBUG
fputws( L"Apply: ", stderr ); debug_print( L"Apply: ", DEBUG_EVAL );
dump_frame( stderr, frame ); dump_frame( stderr, frame_pointer );
#endif #endif
set_reg( frame, 0, make_cons( frame->arg[0], frame->arg[1] ) ); set_reg( frame, 0, make_cons( frame->arg[0], frame->arg[1] ) );
set_reg( frame, 1, NIL ); set_reg( frame, 1, NIL );
struct cons_pointer result = c_apply( frame, env ); struct cons_pointer result = c_apply( frame, frame_pointer, env );
#ifdef DEBUG debug_print( L"Apply returning ", DEBUG_EVAL );
fputws( L"Apply returning ", stderr ); debug_dump_object( result, DEBUG_EVAL );
print( stderr, result );
fputws( L"\n", stderr );
#endif
return result; return result;
} }
@ -469,7 +483,8 @@ lisp_apply( struct stack_frame *frame, struct cons_pointer env ) {
* this isn't at this stage checked) unevaluated. * this isn't at this stage checked) unevaluated.
*/ */
struct cons_pointer struct cons_pointer
lisp_quote( struct stack_frame *frame, struct cons_pointer env ) { lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return frame->arg[0]; return frame->arg[0];
} }
@ -484,7 +499,8 @@ lisp_quote( struct stack_frame *frame, struct cons_pointer env ) {
* the namespace in so doing. `namespace` defaults to the value of `oblist`. * the namespace in so doing. `namespace` defaults to the value of `oblist`.
*/ */
struct cons_pointer struct cons_pointer
lisp_set( struct stack_frame *frame, struct cons_pointer env ) { lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct cons_pointer namespace = struct cons_pointer namespace =
nilp( frame->arg[2] ) ? oblist : frame->arg[2]; nilp( frame->arg[2] ) ? oblist : frame->arg[2];
@ -496,8 +512,9 @@ lisp_set( struct stack_frame *frame, struct cons_pointer env ) {
result = result =
make_exception( make_cons make_exception( make_cons
( c_string_to_lisp_string ( c_string_to_lisp_string
( "The first argument to `set!` is not a symbol: " ), ( L"The first argument to `set` is not a symbol: " ),
make_cons( frame->arg[0], NIL ) ), frame ); make_cons( frame->arg[0], NIL ) ),
frame_pointer );
} }
return result; return result;
@ -514,21 +531,24 @@ lisp_set( struct stack_frame *frame, struct cons_pointer env ) {
* the namespace in so doing. `namespace` defaults to the value of `oblist`. * the namespace in so doing. `namespace` defaults to the value of `oblist`.
*/ */
struct cons_pointer struct cons_pointer
lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ) { lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct cons_pointer namespace = struct cons_pointer namespace =
nilp( frame->arg[2] ) ? oblist : frame->arg[2]; nilp( frame->arg[2] ) ? oblist : frame->arg[2];
if ( symbolp( frame->arg[0] ) ) { if ( symbolp( frame->arg[0] ) ) {
struct cons_pointer val = eval_form( frame, frame->arg[1], env ); struct cons_pointer val =
eval_form( frame, frame_pointer, frame->arg[1], env );
deep_bind( frame->arg[0], val ); deep_bind( frame->arg[0], val );
result = val; result = val;
} else { } else {
result = result =
make_exception( make_cons make_exception( make_cons
( c_string_to_lisp_string ( c_string_to_lisp_string
( "The first argument to `set!` is not a symbol: " ), ( L"The first argument to `set!` is not a symbol: " ),
make_cons( frame->arg[0], NIL ) ), frame ); make_cons( frame->arg[0], NIL ) ),
frame_pointer );
} }
return result; return result;
@ -543,7 +563,8 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ) {
* otherwise returns a new cons cell. * otherwise returns a new cons cell.
*/ */
struct cons_pointer struct cons_pointer
lisp_cons( struct stack_frame *frame, struct cons_pointer env ) { lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer car = frame->arg[0]; struct cons_pointer car = frame->arg[0];
struct cons_pointer cdr = frame->arg[1]; struct cons_pointer cdr = frame->arg[1];
struct cons_pointer result; struct cons_pointer result;
@ -567,7 +588,8 @@ lisp_cons( struct stack_frame *frame, struct cons_pointer env ) {
* strings, and TODO read streams and other things which can be considered as sequences. * strings, and TODO read streams and other things which can be considered as sequences.
*/ */
struct cons_pointer struct cons_pointer
lisp_car( struct stack_frame *frame, struct cons_pointer env ) { lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
if ( consp( frame->arg[0] ) ) { if ( consp( frame->arg[0] ) ) {
@ -578,8 +600,8 @@ lisp_car( struct stack_frame *frame, struct cons_pointer env ) {
result = make_string( cell.payload.string.character, NIL ); result = make_string( cell.payload.string.character, NIL );
} else { } else {
struct cons_pointer message = struct cons_pointer message =
c_string_to_lisp_string( "Attempt to take CAR of non sequence" ); c_string_to_lisp_string( L"Attempt to take CAR of non sequence" );
result = lisp_throw( message, frame ); result = throw_exception( message, frame_pointer );
} }
return result; return result;
@ -591,7 +613,8 @@ lisp_car( struct stack_frame *frame, struct cons_pointer env ) {
* strings, and TODO read streams and other things which can be considered as sequences. * strings, and TODO read streams and other things which can be considered as sequences.
*/ */
struct cons_pointer struct cons_pointer
lisp_cdr( struct stack_frame *frame, struct cons_pointer env ) { lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
if ( consp( frame->arg[0] ) ) { if ( consp( frame->arg[0] ) ) {
@ -602,8 +625,8 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer env ) {
result = cell.payload.string.cdr; result = cell.payload.string.cdr;
} else { } else {
struct cons_pointer message = struct cons_pointer message =
c_string_to_lisp_string( "Attempt to take CDR of non sequence" ); c_string_to_lisp_string( L"Attempt to take CDR of non sequence" );
result = lisp_throw( message, frame ); result = throw_exception( message, frame_pointer );
} }
return result; return result;
@ -614,7 +637,8 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer env ) {
* Returns the value associated with key in store, or NIL if not found. * Returns the value associated with key in store, or NIL if not found.
*/ */
struct cons_pointer struct cons_pointer
lisp_assoc( struct stack_frame *frame, struct cons_pointer env ) { lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return c_assoc( frame->arg[0], frame->arg[1] ); return c_assoc( frame->arg[0], frame->arg[1] );
} }
@ -623,6 +647,7 @@ lisp_assoc( struct stack_frame *frame, struct cons_pointer env ) {
* Returns T if a and b are pointers to the same object, else NIL * Returns T if a and b are pointers to the same object, else NIL
*/ */
struct cons_pointer lisp_eq( struct stack_frame *frame, struct cons_pointer lisp_eq( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
return eq( frame->arg[0], frame->arg[1] ) ? TRUE : NIL; return eq( frame->arg[0], frame->arg[1] ) ? TRUE : NIL;
} }
@ -632,7 +657,8 @@ struct cons_pointer lisp_eq( struct stack_frame *frame,
* Returns T if a and b are pointers to structurally identical objects, else NIL * Returns T if a and b are pointers to structurally identical objects, else NIL
*/ */
struct cons_pointer struct cons_pointer
lisp_equal( struct stack_frame *frame, struct cons_pointer env ) { lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return equal( frame->arg[0], frame->arg[1] ) ? TRUE : NIL; return equal( frame->arg[0], frame->arg[1] ) ? TRUE : NIL;
} }
@ -643,14 +669,22 @@ lisp_equal( struct stack_frame *frame, struct cons_pointer env ) {
* is a read stream, then read from that stream, else stdin. * is a read stream, then read from that stream, else stdin.
*/ */
struct cons_pointer struct cons_pointer
lisp_read( struct stack_frame *frame, struct cons_pointer env ) { lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
#ifdef DEBUG
debug_print( L"entering lisp_read\n", DEBUG_IO );
#endif
FILE *input = stdin; FILE *input = stdin;
if ( readp( frame->arg[0] ) ) { if ( readp( frame->arg[0] ) ) {
input = pointer2cell( frame->arg[0] ).payload.stream.stream; input = pointer2cell( frame->arg[0] ).payload.stream.stream;
} }
return read( frame, input ); 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;
} }
@ -684,6 +718,7 @@ struct cons_pointer c_reverse( struct cons_pointer arg ) {
* Return a sequence like this sequence but with the members in the reverse order. * Return a sequence like this sequence but with the members in the reverse order.
*/ */
struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer lisp_reverse( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
return c_reverse( frame->arg[0] ); return c_reverse( frame->arg[0] );
} }
@ -696,19 +731,24 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame,
* is a write stream, then print to that stream, else stdout. * is a write stream, then print to that stream, else stdout.
*/ */
struct cons_pointer struct cons_pointer
lisp_print( struct stack_frame *frame, struct cons_pointer env ) { lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
debug_print( L"Entering print\n", DEBUG_IO );
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
FILE *output = stdout; FILE *output = stdout;
if ( writep( frame->arg[1] ) ) { 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; 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] ); result = print( output, frame->arg[0] );
fputws( L"Print returning ", stderr ); debug_print( L"lisp_print returning\n", DEBUG_IO );
print( stderr, result ); debug_dump_object( result, DEBUG_IO );
fputws( L"\n", stderr );
return result; return result;
} }
@ -721,7 +761,8 @@ lisp_print( struct stack_frame *frame, struct cons_pointer env ) {
* @return As a Lisp string, the tag of the object which is the argument. * @return As a Lisp string, the tag of the object which is the argument.
*/ */
struct cons_pointer struct cons_pointer
lisp_type( struct stack_frame *frame, struct cons_pointer env ) { lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return c_type( frame->arg[0] ); return c_type( frame->arg[0] );
} }
@ -739,16 +780,17 @@ lisp_type( struct stack_frame *frame, struct cons_pointer env ) {
* argument. * argument.
*/ */
struct cons_pointer struct cons_pointer
lisp_progn( struct stack_frame *frame, struct cons_pointer env ) { lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer remaining = frame->more; struct cons_pointer remaining = frame->more;
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) { for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) {
result = eval_form( frame, frame->arg[i], env ); result = eval_form( frame, frame_pointer, frame->arg[i], env );
} }
while ( consp( remaining ) ) { while ( consp( remaining ) ) {
result = eval_form( frame, c_car( remaining ), env ); result = eval_form( frame, frame_pointer, c_car( remaining ), env );
remaining = c_cdr( remaining ); remaining = c_cdr( remaining );
} }
@ -766,22 +808,26 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer env ) {
* @return the value of the last form of the first successful clause. * @return the value of the last form of the first successful clause.
*/ */
struct cons_pointer struct cons_pointer
lisp_cond( struct stack_frame *frame, struct cons_pointer env ) { lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
bool done = false; bool done = false;
for ( int i = 0; i < args_in_frame && !done; i++ ) { for ( int i = 0; i < args_in_frame && !done; i++ ) {
struct cons_pointer clause_pointer = frame->arg[i]; struct cons_pointer clause_pointer = frame->arg[i];
fputws( L"Cond clause: ", stderr ); debug_print( L"Cond clause: ", DEBUG_EVAL );
print( stderr, clause_pointer ); debug_dump_object( clause_pointer, DEBUG_EVAL );
if ( consp( clause_pointer ) ) { if ( consp( clause_pointer ) ) {
struct cons_space_object cell = pointer2cell( clause_pointer ); struct cons_space_object cell = pointer2cell( clause_pointer );
result = eval_form( frame, c_car( clause_pointer ), env ); result =
eval_form( frame, frame_pointer, c_car( clause_pointer ),
env );
if ( !nilp( result ) ) { if ( !nilp( result ) ) {
struct cons_pointer vals = struct cons_pointer vals =
eval_forms( frame, c_cdr( clause_pointer ), env ); eval_forms( frame, frame_pointer, c_cdr( clause_pointer ),
env );
while ( consp( vals ) ) { while ( consp( vals ) ) {
result = c_car( vals ); result = c_car( vals );
@ -793,9 +839,9 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) {
} else if ( nilp( clause_pointer ) ) { } else if ( nilp( clause_pointer ) ) {
done = true; done = true;
} else { } else {
result = lisp_throw( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Arguments to `cond` must be lists" ), ( L"Arguments to `cond` must be lists" ),
frame ); frame_pointer );
} }
} }
/* TODO: if there are more than 8 clauses we need to continue into the /* TODO: if there are more than 8 clauses we need to continue into the
@ -805,17 +851,20 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) {
} }
/** /**
* TODO: make this do something sensible somehow. * Throw an exception.
* This requires that a frame be a heap-space object with a cons-space * `throw_exception` is a misnomer, because it doesn't obey the calling signature of a
* lisp function; but it is nevertheless to be preferred to make_exception. A
* real `throw_exception`, which does, will be needed.
* object pointing to it. Then this should become a normal lisp function * object pointing to it. Then this should become a normal lisp function
* which expects a normally bound frame and environment, such that * which expects a normally bound frame and environment, such that
* frame->arg[0] is the message, and frame->arg[1] is the cons-space * frame->arg[0] is the message, and frame->arg[1] is the cons-space
* pointer to the frame in which the exception occurred. * pointer to the frame in which the exception occurred.
*/ */
struct cons_pointer struct cons_pointer
lisp_throw( struct cons_pointer message, struct stack_frame *frame ) { throw_exception( struct cons_pointer message,
fwprintf( stderr, L"\nERROR: " ); struct cons_pointer frame_pointer ) {
print( stderr, message ); debug_print( L"\nERROR: ", DEBUG_EVAL );
debug_dump_object( message, DEBUG_EVAL );
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( message ); struct cons_space_object cell = pointer2cell( message );
@ -823,8 +872,25 @@ lisp_throw( struct cons_pointer message, struct stack_frame *frame ) {
if ( cell.tag.value == EXCEPTIONTV ) { if ( cell.tag.value == EXCEPTIONTV ) {
result = message; result = message;
} else { } else {
result = make_exception( message, frame ); result = make_exception( message, frame_pointer );
} }
return result; return result;
} }
/**
* (exception <message>)
*
* Function. Returns an exception whose message is this `message`, and whose
* stack frame is the parent stack frame when the function is invoked.
* `message` does not have to be a string but should be something intelligible
* which can be read.
* If `message` is itself an exception, returns that instead.
*/
struct cons_pointer
lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer message = frame->arg[0];
return exceptionp( message ) ? message : make_exception( message,
frame->previous );
}

51
src/ops/lispops.h
View file

@ -51,6 +51,7 @@ struct cons_pointer c_reverse( struct cons_pointer arg );
* @return the result of evaluating the form. * @return the result of evaluating the form.
*/ */
struct cons_pointer eval_form( struct stack_frame *parent, struct cons_pointer eval_form( struct stack_frame *parent,
struct cons_pointer parent_pointer,
struct cons_pointer form, struct cons_pointer form,
struct cons_pointer env ); struct cons_pointer env );
@ -60,6 +61,7 @@ struct cons_pointer eval_form( struct stack_frame *parent,
* `list` is not in fact a list, return nil. * `list` is not in fact a list, return nil.
*/ */
struct cons_pointer eval_forms( struct stack_frame *frame, struct cons_pointer eval_forms( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer list, struct cons_pointer list,
struct cons_pointer env ); struct cons_pointer env );
@ -68,18 +70,23 @@ struct cons_pointer eval_forms( struct stack_frame *frame,
* special forms * special forms
*/ */
struct cons_pointer lisp_eval( struct stack_frame *frame, struct cons_pointer lisp_eval( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_apply( struct stack_frame *frame, struct cons_pointer lisp_apply( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer struct cons_pointer
lisp_oblist( struct stack_frame *frame, struct cons_pointer env ); lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer struct cons_pointer
lisp_set( struct stack_frame *frame, struct cons_pointer env ); lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer struct cons_pointer
lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ); lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
/** /**
* Construct an interpretable function. * Construct an interpretable function.
@ -89,6 +96,7 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env );
* @param env the environment in which it is to be intepreted. * @param env the environment in which it is to be intepreted.
*/ */
struct cons_pointer lisp_lambda( struct stack_frame *frame, struct cons_pointer lisp_lambda( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
/** /**
@ -98,31 +106,42 @@ struct cons_pointer lisp_lambda( struct stack_frame *frame,
* @param env the environment in which it is to be intepreted. * @param env the environment in which it is to be intepreted.
*/ */
struct cons_pointer struct cons_pointer
lisp_nlambda( struct stack_frame *frame, struct cons_pointer env ); lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_quote( struct stack_frame *frame, struct cons_pointer lisp_quote( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
/* /*
* functions * functions
*/ */
struct cons_pointer lisp_cons( struct stack_frame *frame, struct cons_pointer lisp_cons( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_car( struct stack_frame *frame, struct cons_pointer lisp_car( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_cdr( struct stack_frame *frame, struct cons_pointer lisp_cdr( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_assoc( struct stack_frame *frame, struct cons_pointer lisp_assoc( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_eq( struct stack_frame *frame, struct cons_pointer lisp_eq( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_equal( struct stack_frame *frame, struct cons_pointer lisp_equal( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_print( struct stack_frame *frame, struct cons_pointer lisp_print( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_read( struct stack_frame *frame, struct cons_pointer lisp_read( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer lisp_reverse( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
/** /**
* Function: Get the Lisp type of the single argument. * Function: Get the Lisp type of the single argument.
@ -131,7 +150,8 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame,
* @return As a Lisp string, the tag of the object which is the argument. * @return As a Lisp string, the tag of the object which is the argument.
*/ */
struct cons_pointer struct cons_pointer
lisp_type( struct stack_frame *frame, struct cons_pointer env ); lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
/** /**
@ -145,7 +165,8 @@ lisp_type( struct stack_frame *frame, struct cons_pointer env );
* argument. * argument.
*/ */
struct cons_pointer struct cons_pointer
lisp_progn( struct stack_frame *frame, struct cons_pointer env ); lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
/** /**
* Special form: conditional. Each arg is expected to be a list; if the first * Special form: conditional. Each arg is expected to be a list; if the first
@ -157,10 +178,18 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer env );
* @return the value of the last form of the first successful clause. * @return the value of the last form of the first successful clause.
*/ */
struct cons_pointer struct cons_pointer
lisp_cond( struct stack_frame *frame, struct cons_pointer env ); lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
/* /**
* neither, at this stage, really * Throw an exception.
* `throw_exception` is a misnomer, because it doesn't obey the calling signature of a
* lisp function; but it is nevertheless to be preferred to make_exception. A
* real `throw_exception`, which does, will be needed.
*/ */
struct cons_pointer lisp_throw( struct cons_pointer message, struct cons_pointer throw_exception( struct cons_pointer message,
struct stack_frame *frame ); struct cons_pointer frame_pointer );
struct cons_pointer
lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );

25
src/ops/print.c
View file

@ -20,6 +20,7 @@
#include "conspage.h" #include "conspage.h"
#include "consspaceobject.h" #include "consspaceobject.h"
#include "integer.h" #include "integer.h"
#include "stack.h"
#include "print.h" #include "print.h"
/** /**
@ -36,7 +37,7 @@ int print_use_colours = 0;
void print_string_contents( FILE * output, struct cons_pointer pointer ) { void print_string_contents( FILE * output, struct cons_pointer pointer ) {
while ( stringp( pointer ) || symbolp( pointer ) ) { while ( stringp( pointer ) || symbolp( pointer ) ) {
struct cons_space_object *cell = &pointer2cell( 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' ) { if ( c != '\0' ) {
fputwc( c, output ); fputwc( c, output );
@ -118,12 +119,7 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
case EXCEPTIONTV: case EXCEPTIONTV:
fwprintf( output, L"\n%sException: ", fwprintf( output, L"\n%sException: ",
print_use_colours ? "\x1B[31m" : "" ); print_use_colours ? "\x1B[31m" : "" );
if ( stringp( cell.payload.exception.message ) ) { dump_stack_trace( output, pointer );
print_string_contents( output,
cell.payload.exception.message );
} else {
print( output, cell.payload.exception.message );
}
break; break;
case FUNCTIONTV: case FUNCTIONTV:
fwprintf( output, L"(Function)" ); fwprintf( output, L"(Function)" );
@ -135,19 +131,19 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
fwprintf( output, L"%ld%", cell.payload.integer.value ); fwprintf( output, L"%ld%", cell.payload.integer.value );
break; break;
case LAMBDATV: 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, make_cons( cell.payload.lambda.args,
cell.payload. cell.payload.lambda.
lambda.body ) ) ); body ) ) );
break; break;
case NILTV: case NILTV:
fwprintf( output, L"nil" ); fwprintf( output, L"nil" );
break; break;
case NLAMBDATV: 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, make_cons( cell.payload.lambda.args,
cell.payload. cell.payload.lambda.
lambda.body ) ) ); body ) ) );
break; break;
case RATIOTV: case RATIOTV:
print( output, cell.payload.ratio.dividend ); print( output, cell.payload.ratio.dividend );
@ -194,6 +190,9 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
case TRUETV: case TRUETV:
fwprintf( output, L"t" ); fwprintf( output, L"t" );
break; break;
case WRITETV:
fwprintf( output, L"(Output stream)" );
break;
default: default:
fwprintf( stderr, fwprintf( stderr,
L"%sError: Unrecognised tag value %d (%c%c%c%c)\n", L"%sError: Unrecognised tag value %d (%c%c%c%c)\n",

131
src/ops/read.c
View file

@ -18,6 +18,8 @@
#include <wctype.h> #include <wctype.h>
#include "consspaceobject.h" #include "consspaceobject.h"
#include "debug.h"
#include "dump.h"
#include "integer.h" #include "integer.h"
#include "intern.h" #include "intern.h"
#include "lispops.h" #include "lispops.h"
@ -25,6 +27,7 @@
#include "ratio.h" #include "ratio.h"
#include "read.h" #include "read.h"
#include "real.h" #include "real.h"
#include "vectorspace.h"
/* /*
* for the time being things which may be read are: strings numbers - either * for the time being things which may be read are: strings numbers - either
@ -32,9 +35,12 @@
* atoms because I don't yet know what an atom is or how it's stored. * atoms because I don't yet know what an atom is or how it's stored.
*/ */
struct cons_pointer read_number( struct stack_frame *frame, FILE * input, struct cons_pointer read_number( struct stack_frame *frame,
wint_t initial, bool seen_period ); struct cons_pointer frame_pointer,
struct cons_pointer read_list( struct stack_frame *frame, FILE * input, FILE * input, wint_t initial,
bool seen_period );
struct cons_pointer read_list( struct stack_frame *frame,
struct cons_pointer frame_pointer, FILE * input,
wint_t initial ); wint_t initial );
struct cons_pointer read_string( FILE * input, wint_t initial ); struct cons_pointer read_string( FILE * input, wint_t initial );
struct cons_pointer read_symbol( FILE * input, wint_t initial ); struct cons_pointer read_symbol( FILE * input, wint_t initial );
@ -43,7 +49,7 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial );
* quote reader macro in C (!) * quote reader macro in C (!)
*/ */
struct cons_pointer c_quote( struct cons_pointer arg ) { 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 ) ); make_cons( arg, NIL ) );
} }
@ -52,8 +58,10 @@ struct cons_pointer c_quote( struct cons_pointer arg ) {
* treating this initial character as the first character of the object * treating this initial character as the first character of the object
* representation. * representation.
*/ */
struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input, struct cons_pointer read_continuation( struct stack_frame *frame,
wint_t initial ) { struct cons_pointer frame_pointer,
FILE * input, wint_t initial ) {
debug_print( L"entering read_continuation\n", DEBUG_IO );
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
wint_t c; wint_t c;
@ -63,8 +71,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
if ( feof( input ) ) { if ( feof( input ) ) {
result = result =
make_exception( c_string_to_lisp_string throw_exception( c_string_to_lisp_string
( "End of file while reading" ), frame ); ( L"End of file while reading" ), frame_pointer );
} else { } else {
switch ( c ) { switch ( c ) {
case ';': case ';':
@ -72,16 +80,19 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
/* skip all characters from semi-colon to the end of the line */ /* skip all characters from semi-colon to the end of the line */
break; break;
case EOF: case EOF:
result = lisp_throw( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "End of input while reading" ), frame ); ( L"End of input while reading" ),
frame_pointer );
break; break;
case '\'': case '\'':
result = result =
c_quote( read_continuation c_quote( read_continuation
( frame, input, fgetwc( input ) ) ); ( frame, frame_pointer, input,
fgetwc( input ) ) );
break; break;
case '(': case '(':
result = read_list( frame, input, fgetwc( input ) ); result =
read_list( frame, frame_pointer, input, fgetwc( input ) );
break; break;
case '"': case '"':
result = read_string( input, fgetwc( input ) ); result = read_string( input, fgetwc( input ) );
@ -90,7 +101,9 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
wint_t next = fgetwc( input ); wint_t next = fgetwc( input );
ungetwc( next, input ); ungetwc( next, input );
if ( iswdigit( next ) ) { if ( iswdigit( next ) ) {
result = read_number( frame, input, c, false ); result =
read_number( frame, frame_pointer, input, c,
false );
} else { } else {
result = read_symbol( input, c ); result = read_symbol( input, c );
} }
@ -101,12 +114,15 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
wint_t next = fgetwc( input ); wint_t next = fgetwc( input );
if ( iswdigit( next ) ) { if ( iswdigit( next ) ) {
ungetwc( next, input ); ungetwc( next, input );
result = read_number( frame, input, c, true ); result =
read_number( frame, frame_pointer, input, c,
true );
} else if ( iswblank( next ) ) { } else if ( iswblank( next ) ) {
/* dotted pair. TODO: this isn't right, we /* dotted pair. TODO: this isn't right, we
* really need to backtrack up a level. */ * really need to backtrack up a level. */
result = result =
read_continuation( frame, input, fgetwc( input ) ); read_continuation( frame, frame_pointer, input,
fgetwc( input ) );
} else { } else {
read_symbol( input, c ); read_symbol( input, c );
} }
@ -114,19 +130,22 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
break; break;
default: default:
if ( iswdigit( c ) ) { if ( iswdigit( c ) ) {
result = read_number( frame, input, c, false ); result =
read_number( frame, frame_pointer, input, c, false );
} else if ( iswprint( c ) ) { } else if ( iswprint( c ) ) {
result = read_symbol( input, c ); result = read_symbol( input, c );
} else { } else {
result = result =
make_exception( make_cons( c_string_to_lisp_string throw_exception( make_cons( c_string_to_lisp_string
( "Unrecognised start of input character" ), ( L"Unrecognised start of input character" ),
make_string( c, NIL ) ), make_string( c, NIL ) ),
frame ); frame_pointer );
} }
break; break;
} }
} }
debug_print( L"read_continuation returning\n", DEBUG_IO );
debug_dump_object( result, DEBUG_IO );
return result; return result;
} }
@ -136,8 +155,11 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
* TODO: to be able to read bignums, we need to read the number from the * TODO: to be able to read bignums, we need to read the number from the
* input stream into a Lisp string, and then convert it to a number. * input stream into a Lisp string, and then convert it to a number.
*/ */
struct cons_pointer read_number( struct stack_frame *frame, FILE * input, struct cons_pointer read_number( struct stack_frame *frame,
struct cons_pointer frame_pointer,
FILE * input,
wint_t initial, bool seen_period ) { wint_t initial, bool seen_period ) {
debug_print( L"entering read_number\n", DEBUG_IO );
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
int64_t accumulator = 0; int64_t accumulator = 0;
int64_t dividend = 0; int64_t dividend = 0;
@ -148,24 +170,24 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input,
if ( negative ) { if ( negative ) {
initial = fgetwc( input ); initial = fgetwc( input );
} }
#ifdef DEBUG
fwprintf( stderr, L"read_number starting '%c' (%d)\n", initial, initial ); debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial, initial );
#endif
for ( c = initial; iswdigit( c ) for ( c = initial; iswdigit( c )
|| c == btowc( '.' ) || c == btowc( '/' ); c = fgetwc( input ) ) { || c == btowc( '.' ) || c == btowc( '/' ); c = fgetwc( input ) ) {
if ( c == btowc( '.' ) ) { if ( c == btowc( '.' ) ) {
if ( seen_period || dividend != 0 ) { if ( seen_period || dividend != 0 ) {
return make_exception( c_string_to_lisp_string return throw_exception( c_string_to_lisp_string
( "Malformed number: too many periods" ), ( L"Malformed number: too many periods" ),
frame ); frame_pointer );
} else { } else {
seen_period = true; seen_period = true;
} }
} else if ( c == btowc( '/' ) ) { } else if ( c == btowc( '/' ) ) {
if ( seen_period || dividend > 0 ) { if ( seen_period || dividend > 0 ) {
return make_exception( c_string_to_lisp_string return throw_exception( c_string_to_lisp_string
( "Malformed number: dividend of rational must be integer" ), ( L"Malformed number: dividend of rational must be integer" ),
frame ); frame_pointer );
} else { } else {
dividend = negative ? 0 - accumulator : accumulator; dividend = negative ? 0 - accumulator : accumulator;
@ -173,11 +195,11 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input,
} }
} else { } else {
accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' ); accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' );
#ifdef DEBUG
fwprintf( stderr, debug_printf( DEBUG_IO,
L"Added character %c, accumulator now %ld\n", L"Added character %c, accumulator now %ld\n",
c, accumulator ); c, accumulator );
#endif
if ( seen_period ) { if ( seen_period ) {
places_of_decimals++; places_of_decimals++;
} }
@ -194,13 +216,10 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input,
if ( negative ) { if ( negative ) {
rv = 0 - rv; rv = 0 - rv;
} }
#ifdef DEBUG
fwprintf( stderr, L"read_numer returning %Lf\n", rv );
#endif
result = make_real( rv ); result = make_real( rv );
} else if ( dividend != 0 ) { } else if ( dividend != 0 ) {
result = result =
make_ratio( frame, make_integer( dividend ), make_ratio( frame_pointer, make_integer( dividend ),
make_integer( accumulator ) ); make_integer( accumulator ) );
} else { } else {
if ( negative ) { if ( negative ) {
@ -209,6 +228,9 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input,
result = make_integer( accumulator ); result = make_integer( accumulator );
} }
debug_print( L"read_number returning\n", DEBUG_IO );
debug_dump_object( result, DEBUG_IO );
return result; return result;
} }
@ -216,24 +238,23 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input,
* Read a list from this input stream, which no longer contains the opening * Read a list from this input stream, which no longer contains the opening
* left parenthesis. * left parenthesis.
*/ */
struct cons_pointer read_list( struct struct cons_pointer read_list( struct stack_frame *frame,
stack_frame struct cons_pointer frame_pointer,
*frame, FILE * input, wint_t initial ) { FILE * input, wint_t initial ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
if ( initial != ')' ) { if ( initial != ')' ) {
#ifdef DEBUG debug_printf( DEBUG_IO,
fwprintf( stderr,
L"read_list starting '%C' (%d)\n", initial, initial ); L"read_list starting '%C' (%d)\n", initial, initial );
#endif struct cons_pointer car =
struct cons_pointer car = read_continuation( frame, input, read_continuation( frame, frame_pointer, input,
initial ); initial );
result = make_cons( car, read_list( frame, input, fgetwc( input ) ) ); result =
make_cons( car,
read_list( frame, frame_pointer, input,
fgetwc( input ) ) );
} 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; return result;
} }
@ -304,11 +325,8 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
break; break;
} }
#ifdef DEBUG debug_print( L"read_symbol returning\n", DEBUG_IO );
fputws( L"Read symbol '", stderr ); debug_dump_object( result, DEBUG_IO );
print( stderr, result );
fputws( L"'\n", stderr );
#endif
return result; return result;
} }
@ -318,6 +336,7 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
*/ */
struct cons_pointer read( struct struct cons_pointer read( struct
stack_frame stack_frame
*frame, FILE * input ) { *frame, struct cons_pointer frame_pointer,
return read_continuation( frame, input, fgetwc( input ) ); FILE * input ) {
return read_continuation( frame, frame_pointer, input, fgetwc( input ) );
} }

3
src/ops/read.h
View file

@ -14,6 +14,7 @@
/** /**
* read the next object on this input stream and return a cons_pointer to it. * read the next object on this input stream and return a cons_pointer to it.
*/ */
struct cons_pointer read( struct stack_frame *frame, FILE * input ); struct cons_pointer read( struct stack_frame *frame,
struct cons_pointer frame_pointer, FILE * input );
#endif #endif

48
src/repl.c
View file

@ -13,6 +13,7 @@
#include "conspage.h" #include "conspage.h"
#include "consspaceobject.h" #include "consspaceobject.h"
#include "debug.h"
#include "intern.h" #include "intern.h"
#include "lispops.h" #include "lispops.h"
#include "read.h" #include "read.h"
@ -31,11 +32,18 @@
* Dummy up a Lisp read call with its own stack frame. * Dummy up a Lisp read call with its own stack frame.
*/ */
struct cons_pointer repl_read( struct cons_pointer stream_pointer ) { struct cons_pointer repl_read( struct cons_pointer stream_pointer ) {
struct stack_frame *frame = make_empty_frame( NULL, oblist ); struct cons_pointer result = NIL;
debug_print( L"Entered repl_read\n", DEBUG_REPL );
set_reg( frame, 0, stream_pointer ); struct cons_pointer frame_pointer = make_stack_frame( NIL, make_cons(stream_pointer, NIL), oblist );
struct cons_pointer result = lisp_read( frame, oblist ); debug_print( L"repl_read: got stack_frame pointer\n", DEBUG_REPL );
free_stack_frame( frame ); debug_dump_object( frame_pointer, DEBUG_REPL );
if ( !nilp( frame_pointer ) ) {
inc_ref( frame_pointer );
result = lisp_read( get_stack_frame( frame_pointer ), frame_pointer, oblist );
dec_ref( frame_pointer );
}
debug_print( L"repl_read: returning\n", DEBUG_REPL );
debug_dump_object( result, DEBUG_REPL );
return result; return result;
} }
@ -44,14 +52,13 @@ struct cons_pointer repl_read( struct cons_pointer stream_pointer ) {
* Dummy up a Lisp eval call with its own stack frame. * Dummy up a Lisp eval call with its own stack frame.
*/ */
struct cons_pointer repl_eval( struct cons_pointer input ) { struct cons_pointer repl_eval( struct cons_pointer input ) {
struct stack_frame *frame = make_empty_frame( NULL, oblist ); debug_print( L"Entered repl_eval\n", DEBUG_REPL );
struct cons_pointer result = NIL;
set_reg( frame, 0, input ); result = eval_form( NULL, NIL, input, oblist );
struct cons_pointer result = lisp_eval( frame, oblist );
if ( !exceptionp( result ) ) { debug_print( L"repl_eval: returning\n", DEBUG_REPL );
free_stack_frame( frame ); debug_dump_object( result, DEBUG_REPL );
}
return result; return result;
} }
@ -61,12 +68,12 @@ struct cons_pointer repl_eval( struct cons_pointer input ) {
*/ */
struct cons_pointer repl_print( struct cons_pointer stream_pointer, struct cons_pointer repl_print( struct cons_pointer stream_pointer,
struct cons_pointer value ) { struct cons_pointer value ) {
struct stack_frame *frame = make_empty_frame( NULL, oblist ); debug_print( L"Entered repl_print\n", DEBUG_REPL );
debug_dump_object( value, DEBUG_REPL );
set_reg( frame, 0, value ); struct cons_pointer result =
set_reg( frame, 1, stream_pointer ); print( pointer2cell( stream_pointer ).payload.stream.stream, value );
struct cons_pointer result = lisp_print( frame, oblist ); debug_print( L"repl_print: returning\n", DEBUG_REPL );
free_stack_frame( frame ); debug_dump_object( result, DEBUG_REPL );
return result; return result;
} }
@ -81,12 +88,12 @@ struct cons_pointer repl_print( struct cons_pointer stream_pointer,
void void
repl( FILE * in_stream, FILE * out_stream, FILE * error_stream, repl( FILE * in_stream, FILE * out_stream, FILE * error_stream,
bool show_prompt ) { bool show_prompt ) {
debug_print( L"Entered repl\n", DEBUG_REPL );
struct cons_pointer input_stream = make_read_stream( in_stream ); 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 ); 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 ) ) { while ( !feof( pointer2cell( input_stream ).payload.stream.stream ) ) {
if ( show_prompt ) { if ( show_prompt ) {
fwprintf( out_stream, L"\n:: " ); fwprintf( out_stream, L"\n:: " );
@ -106,4 +113,5 @@ repl( FILE * in_stream, FILE * out_stream, FILE * error_stream,
} }
dec_ref( input ); dec_ref( input );
} }
debug_print( L"Leaving repl\n", DEBUG_REPL );
} }

BIN
utils_src/debugflags/debugflags Executable file
View file

Binary file not shown.

43
utils_src/debugflags/debugflags.c Normal file
View file

@ -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);
}
}