From 9661ad339a5f75c248700e198859447e2f6c280a Mon Sep 17 00:00:00 2001 From: simon Date: Wed, 13 Sep 2017 12:50:20 +0100 Subject: [PATCH] This isn't working, but I think it's progress. --- include/licence-header.txt | 2 ++ src/consspaceobject.c | 32 ++++++++++++++++++----- src/consspaceobject.h | 2 +- src/equal.c | 52 +++++++++++++++++++++++++++++--------- src/init.c | 21 +++++++++++---- src/integer.c | 2 +- src/intern.c | 6 ++--- src/intern.h | 2 +- src/lispops.c | 25 ++++++++---------- src/peano.c | 35 +++++++++++++++++++++++++ src/print.c | 6 +++++ src/read.c | 3 ++- src/repl.c | 10 ++++---- 13 files changed, 149 insertions(+), 49 deletions(-) create mode 100644 include/licence-header.txt create mode 100644 src/peano.c diff --git a/include/licence-header.txt b/include/licence-header.txt new file mode 100644 index 0000000..f2b4107 --- /dev/null +++ b/include/licence-header.txt @@ -0,0 +1,2 @@ +(c) 2017 Simon Brooke +Licensed under GPL version 2.0, or, at your option, any later version. diff --git a/src/consspaceobject.c b/src/consspaceobject.c index 35b8e5f..c7889ed 100644 --- a/src/consspaceobject.c +++ b/src/consspaceobject.c @@ -19,6 +19,7 @@ #include "conspage.h" #include "consspaceobject.h" +#include "print.h" /** * Check that the tag on the cell at this pointer is this tag @@ -73,28 +74,47 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { cell.tag.bytes[3], cell.tag.value, pointer.page, pointer.offset, cell.count ); - if ( check_tag( pointer, CONSTAG ) ) { + switch ( cell.tag.value) { + case CONSTV: fwprintf( output, L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d\n", cell.payload.cons.car.page, cell.payload.cons.car.offset, cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset ); - } else if ( check_tag( pointer, INTEGERTAG ) ) { + break; + case INTEGERTV: fwprintf( output, L"\t\tInteger cell: value %ld\n", cell.payload.integer.value ); - } else if ( check_tag( pointer, FREETAG ) ) { + 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 ); - } else if ( check_tag( pointer, REALTAG ) ) { + break; + case REALTV: fwprintf( output, L"\t\tReal cell: value %Lf\n", cell.payload.real.value ); - } else if ( check_tag( pointer, STRINGTAG ) ) { + break; + case STRINGTV: fwprintf( output, L"\t\tString cell: character '%1c' (%1d) next at page %2d offset %3d\n", cell.payload.string.character, cell.payload.string.cdr.page, cell.payload.string.cdr.offset ); + fwprintf( output, L"\t\t value:"); + print(output, pointer); + fwprintf( output, L"\n"); + break; + case SYMBOLTV: + fwprintf( output, + L"\t\tSymbol cell: character '%1c' (%1d) next at page %2d offset %3d\n", + cell.payload.string.character, + cell.payload.string.cdr.page, + cell.payload.string.cdr.offset ); + fwprintf( output, L"\t\t value:"); + print(output, pointer); + fwprintf( output, L"\n"); + break; } } @@ -150,7 +170,7 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) { inc_ref( tail ); cell->payload.string.character = c; 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. */ cell->payload.string.cdr.offset = tail.offset; } else { diff --git a/src/consspaceobject.h b/src/consspaceobject.h index 3b8c9fa..d52a241 100644 --- a/src/consspaceobject.h +++ b/src/consspaceobject.h @@ -156,7 +156,7 @@ #define stringp(conspoint) (check_tag(conspoint,STRINGTAG)) /** - * true if conspointer points to a string cell, else false + * true if conspointer points to a symbol cell, else false */ #define symbolp(conspoint) (check_tag(conspoint,SYMBOLTAG)) diff --git a/src/equal.c b/src/equal.c index 2a20d5e..23de51c 100644 --- a/src/equal.c +++ b/src/equal.c @@ -22,6 +22,21 @@ bool eq( struct cons_pointer a, struct cons_pointer b ) { return ( ( a.page == b.page ) && ( a.offset == b.offset ) ); } +/** + * True if the objects at these two cons pointers have the same tag, else false. + * @param a a pointer to a cons-space object; + * @param b another pointer to a cons-space object. + * @return true if the objects at these two cons pointers have the same tag, + * else false. + */ +bool same_type( struct cons_pointer a, struct cons_pointer b ) { + struct cons_space_object *cell_a = &pointer2cell( a ); + struct cons_space_object *cell_b = &pointer2cell( b ); + + return cell_a->tag.value == cell_b->tag.value; + +} + /** * Deep, and thus expensive, equality: true if these two objects have * identical structure, else false. @@ -29,15 +44,18 @@ bool eq( struct cons_pointer a, struct cons_pointer b ) { bool equal( struct cons_pointer a, struct cons_pointer b ) { bool result = eq( a, b ); - if ( !result ) { + if ( !result && same_type( a, b ) ) { struct cons_space_object *cell_a = &pointer2cell( a ); struct cons_space_object *cell_b = &pointer2cell( b ); - if ( consp( a ) && consp( b ) ) { + switch ( cell_a->tag.value ) { + case CONSTV: result = equal( cell_a->payload.cons.car, cell_b->payload.cons.car ) && equal( cell_a->payload.cons.cdr, cell_b->payload.cons.cdr ); - } else if ( stringp( a ) && stringp( b ) ) { + break; + case STRINGTV: + case SYMBOLTV: /* * slightly complex because a string may or may not have a '\0' * cell at the end, but I'll ignore that for now. I think in @@ -48,17 +66,27 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { cell_b->payload.string.character && equal( cell_a->payload.string.cdr, cell_b->payload.string.cdr ); - } else if ( numberp( a ) && numberp( b ) ) { - double num_a = numeric_value( a ); - double num_b = numeric_value( b ); - double max = - fabs( num_a ) > fabs( num_b ) ? fabs( num_a ) : fabs( num_b ); + break; + case INTEGERTV: + case REALTV: + { + double num_a = numeric_value( a ); + double num_b = numeric_value( b ); + double max = + fabs( num_a ) > + fabs( num_b ) ? fabs( num_a ) : fabs( num_b ); - /* - * not more different than one part in a million - close enough - */ - result = fabs( num_a - num_b ) < ( max / 1000000.0 ); + /* + * not more different than one part in a million - close enough + */ + result = fabs( num_a - num_b ) < ( max / 1000000.0 ); + } + break; + default: + result = false; + break; } + /* * there's only supposed ever to be one T and one NIL cell, so each * should be caught by eq; equality of vector-space objects is a whole diff --git a/src/init.c b/src/init.c index ff77551..1a85c22 100644 --- a/src/init.c +++ b/src/init.c @@ -54,14 +54,14 @@ int main( int argc, char *argv[] ) { show_prompt = true; break; default: - fprintf( stderr, "Unexpected option %c\n", option ); + fwprintf( stderr, L"Unexpected option %c\n", option ); break; } } if ( show_prompt ) { - fprintf( stdout, - "Post scarcity software environment version %s\n\n", + fwprintf( stdout, + L"Post scarcity software environment version %s\n\n", VERSION ); } @@ -70,12 +70,17 @@ int main( int argc, char *argv[] ) { /* * privileged variables (keywords) */ + /* deep_bind( intern( c_string_to_lisp_string( "nil" ), oblist ), NIL ); deep_bind( intern( c_string_to_lisp_string( "t" ), oblist ), TRUE ); + */ + struct cons_pointer lisp_symbol = c_string_to_lisp_symbol( "oblist"); + deep_bind( lisp_symbol, &oblist); /* * primitive function operations */ + /* bind_function( "assoc", &lisp_assoc ); bind_function( "car", &lisp_car ); bind_function( "cdr", &lisp_cdr ); @@ -84,14 +89,20 @@ int main( int argc, char *argv[] ) { bind_function( "equal", &lisp_equal ); bind_function( "read", &lisp_read ); bind_function( "print", &lisp_print ); - +*/ /* * primitive special forms */ + /* bind_special( "apply", &lisp_apply ); bind_special( "eval", &lisp_eval ); bind_special( "quote", &lisp_quote ); - + */ + if ( show_prompt) { + fwprintf( stderr, L"Oblist: "); + print(stderr, *oblist); + } + repl( stdin, stdout, stderr, show_prompt ); if ( dump_at_end ) { diff --git a/src/integer.c b/src/integer.c index ad128ee..fa1327f 100644 --- a/src/integer.c +++ b/src/integer.c @@ -41,7 +41,7 @@ struct cons_pointer make_integer( long int value ) { struct cons_space_object *cell = &pointer2cell( result ); cell->payload.integer.value = value; - dump_object( stderr, result); + dump_object( stderr, result ); return result; } diff --git a/src/intern.c b/src/intern.c index 31b7e2e..8843945 100644 --- a/src/intern.c +++ b/src/intern.c @@ -32,7 +32,7 @@ * they're visible to all users/threads, but again I don't yet have any idea how * that will work. */ -struct cons_pointer oblist = NIL; +struct cons_pointer oblist = & NIL; /** * Implementation of interned? in C. The final implementation if interned? will @@ -91,7 +91,7 @@ struct cons_pointer c_assoc( struct cons_pointer key, * Return a new key/value store containing all the key/value pairs in this store * with this key/value pair added to the front. */ -struct cons_pointer +struct cons_pointer bind( struct cons_pointer key, struct cons_pointer value, struct cons_pointer store ) { return make_cons( make_cons( key, value ), store ); @@ -104,7 +104,7 @@ bind( struct cons_pointer key, struct cons_pointer value, */ struct cons_pointer deep_bind( struct cons_pointer key, struct cons_pointer value ) { - oblist = bind( key, value, oblist ); + oblist = &bind( key, value, *oblist ); return oblist; } diff --git a/src/intern.h b/src/intern.h index e940daa..bd1656c 100644 --- a/src/intern.h +++ b/src/intern.h @@ -20,7 +20,7 @@ #ifndef __intern_h #define __intern_h -extern struct cons_pointer oblist; +extern struct cons_pointer * oblist; /** * return the value associated with this key in this store. In the current diff --git a/src/lispops.c b/src/lispops.c index 85ec7eb..3e20d52 100644 --- a/src/lispops.c +++ b/src/lispops.c @@ -104,8 +104,7 @@ eval_cons( struct cons_pointer s_expr, struct cons_pointer env, { struct cons_space_object special = pointer2cell( fn_pointer ); result = - ( *special.payload.special.executable ) ( args, env, - my_frame ); + ( *special.payload.special.executable ) ( args, env, my_frame ); } break; @@ -164,15 +163,15 @@ lisp_eval( struct cons_pointer s_expr, struct cons_pointer env, struct cons_pointer result = s_expr; struct cons_space_object cell = pointer2cell( s_expr ); - fprintf( stderr, "In eval; about to make stack frame" ); - - struct stack_frame *frame = make_stack_frame( previous, s_expr, env ); - - fprintf( stderr, "In eval; stack frame made" ); - switch ( cell.tag.value ) { case CONSTV: + fwprintf( stderr, L"In eval; about to make stack frame" ); + struct stack_frame *frame = make_stack_frame( previous, s_expr, env ); + fwprintf( stderr, L"In eval; stack frame made" ); + result = eval_cons( s_expr, env, frame ); + + free_stack_frame( frame ); break; case SYMBOLTV: @@ -197,8 +196,6 @@ lisp_eval( struct cons_pointer s_expr, struct cons_pointer env, */ } - free_stack_frame( frame ); - return result; } @@ -212,7 +209,7 @@ lisp_eval( struct cons_pointer s_expr, struct cons_pointer env, struct cons_pointer lisp_quote( struct cons_pointer args, struct cons_pointer env, struct stack_frame *frame ) { - return c_car( args ); + return frame->arg[0]; } /** @@ -360,10 +357,10 @@ lisp_print( struct stack_frame *frame, struct cons_pointer env ) { */ struct cons_pointer lisp_throw( struct cons_pointer message, struct stack_frame *frame ) { - fprintf( stderr, "\nERROR: " ); + fwprintf( stderr, L"\nERROR: " ); print( stderr, message ); - fprintf( stderr, - "\n\nAn exception was thrown and I've no idea what to do now\n" ); + fwprintf( stderr, + L"\n\nAn exception was thrown and I've no idea what to do now\n" ); exit( 1 ); } diff --git a/src/peano.c b/src/peano.c new file mode 100644 index 0000000..67fc8c2 --- /dev/null +++ b/src/peano.c @@ -0,0 +1,35 @@ +/** + * peano.c + * + * Basic peano arithmetic + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include +#include +#include + +#include "consspaceobject.h" +#include "conspage.h" +#include "equal.h" +#include "integer.h" +#include "intern.h" +#include "lispops.h" +#include "print.h" +#include "read.h" +#include "stack.h" + +/* +struct cons_pointer +lisp_plus( struct cons_pointer s_expr, struct cons_pointer env, + struct stack_frame *frame ) { + struct cons_space_object cell = pointer2cell( s_expr ); + struct cons_space_object result = NIL; + + +} +*/ diff --git a/src/print.c b/src/print.c index abe7dda..1f93f59 100644 --- a/src/print.c +++ b/src/print.c @@ -100,6 +100,12 @@ void print( FILE * output, struct cons_pointer pointer ) { case TRUETV: fwprintf( output, L"t" ); break; + case FUNCTIONTV: + fwprintf( output, L"(Function)"); + break; + case SPECIALTV: + fwprintf( output, L"(Special form)"); + break; default: fwprintf( stderr, L"Error: Unrecognised tag value %d (%c%c%c%c)\n", diff --git a/src/read.c b/src/read.c index 26e0b9d..85174ee 100644 --- a/src/read.c +++ b/src/read.c @@ -96,7 +96,8 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) { } else { accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' ); - fprintf( stderr, "Added character %c, accumulator now %ld\n", c, accumulator); + fprintf( stderr, "Added character %c, accumulator now %ld\n", c, + accumulator ); if ( seen_period ) { places_of_decimals++; diff --git a/src/repl.c b/src/repl.c index 22c1571..acfb73c 100644 --- a/src/repl.c +++ b/src/repl.c @@ -35,13 +35,13 @@ repl( FILE * in_stream, FILE * out_stream, FILE * error_stream, fwprintf( out_stream, L"\n-> " ); } - /* OK, I think what's going wrong here is we're passing by - * value and I think we should be passing by reference. + /* OK, I think what's going wrong here is we're passing by + * value and I think we should be passing by reference. * I'm not certain about that, and as it will be a really * major change I'm going to think some more before making - * in */ - // print( out_stream, lisp_eval(input, oblist, NULL)); - print( out_stream, input ); + * in */ + print( out_stream, lisp_eval( input, oblist, NULL ) ); + // print( out_stream, input ); fwprintf( out_stream, L"\n" ); fwprintf( error_stream, L"\neval {%d,%d}=> ", input.page, input.offset );