From 84dcbdc38b46b701208b4698a2e18e9f06dbd865 Mon Sep 17 00:00:00 2001 From: simon Date: Mon, 14 Aug 2017 09:46:08 +0100 Subject: [PATCH 01/27] Added .gitignore --- .gitignore | 6 ++++++ 1 file changed, 6 insertions(+) create mode 100644 .gitignore diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..f26dde3 --- /dev/null +++ b/.gitignore @@ -0,0 +1,6 @@ + +*.d + +*.o + +target/ From 31176e1f39ef0d97b9040674e71aeb872c434e06 Mon Sep 17 00:00:00 2001 From: simon Date: Mon, 14 Aug 2017 17:57:23 +0100 Subject: [PATCH 02/27] Some improvement, but two unit tests fail. --- .gitignore | 2 + Makefile | 5 +- src/consspaceobject.c | 31 ++++++------ src/consspaceobject.h | 1 + src/init.c | 85 +++++++++++++++++++++----------- src/print.c | 60 +++++++++++----------- src/read.c | 14 ++++-- src/real.c | 24 +++++++++ src/real.h | 35 +++++++++++++ src/repl.c | 42 ++++++++++++++++ src/repl.h | 37 ++++++++++++++ unit-tests/complex-list.sh | 2 +- unit-tests/empty-list.sh.bash | 19 +++++++ unit-tests/empty-string.sh | 2 +- unit-tests/fred.sh | 2 +- unit-tests/integer.sh | 2 +- unit-tests/nil.sh | 2 +- unit-tests/quote.sh | 2 +- unit-tests/quoted-list.sh | 2 +- unit-tests/simple-list.sh | 2 +- unit-tests/string-with-spaces.sh | 2 +- 21 files changed, 288 insertions(+), 85 deletions(-) create mode 100644 src/real.c create mode 100644 src/real.h create mode 100644 src/repl.c create mode 100644 src/repl.h create mode 100644 unit-tests/empty-list.sh.bash diff --git a/.gitignore b/.gitignore index f26dde3..ecd8e8f 100644 --- a/.gitignore +++ b/.gitignore @@ -4,3 +4,5 @@ *.o target/ + +nbproject/ diff --git a/Makefile b/Makefile index 144dbf5..84bf081 100644 --- a/Makefile +++ b/Makefile @@ -11,10 +11,11 @@ INC_FLAGS := $(addprefix -I,$(INC_DIRS)) VERSION := "0.0.0" -CPPFLAGS ?= $(INC_FLAGS) -MMD -MP +CPPFLAGS ?= $(INC_FLAGS) -MMD -MP +LDFLAGS := -lm $(TARGET): $(OBJS) - $(CC) $(LDFLAGS) $(OBJS) -DVERSION=$(VERSION) -o $@ $(LOADLIBES) $(LDLIBS) + $(CC) $(LDFLAGS) $(OBJS) -DVERSION=$(VERSION) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS) .PHONY: clean clean: diff --git a/src/consspaceobject.c b/src/consspaceobject.c index f9420d6..afc0002 100644 --- a/src/consspaceobject.c +++ b/src/consspaceobject.c @@ -66,34 +66,37 @@ void dec_ref( struct cons_pointer pointer) { */ void dump_object( FILE* output, struct cons_pointer pointer) { struct cons_space_object cell = pointer2cell(pointer); - fprintf( output, - "\tDumping object at page %d, offset %d with tag %c%c%c%c (%d), count %u\n", - pointer.page, - pointer.offset, + fwprintf( output, + L"\tDumping %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); if ( check_tag(pointer, CONSTAG)) { - fprintf( output, - "\tCons cell: car at page %d offset %d, cdr at page %d offset %d\n", + 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)) { - fprintf( output, "\t\tInteger cell: value %ld\n", cell.payload.integer.value); + fwprintf( output, + L"\t\tInteger cell: value %ld\n", + cell.payload.integer.value); } else if ( check_tag( pointer, FREETAG)) { - fprintf( output, "\t\tFree cell: next at page %d offset %d\n", + 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)) { - fprintf( output, "\t\tReal cell: value %Lf\n", cell.payload.real.value); + fwprintf( output, L"\t\tReal cell: value %Lf\n", cell.payload.real.value); } else if ( check_tag( pointer, STRINGTAG)) { - fwprintf( output, L"\t\tString cell: character '%C' next at page %d offset %d\n", - cell.payload.string.character, cell.payload.string.cdr.page, - cell.payload.string.cdr.offset); - }; + fwprintf( output, + L"String 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); + } } @@ -150,7 +153,7 @@ struct cons_pointer make_string_like_thing( wint_t c, cell->payload.string.cdr.page = tail.page; cell->payload.string.cdr.offset = tail.offset; } else { - fprintf( stderr, "Warning: only NIL and %s can be appended to %s\n", + fwprintf( stderr, L"Warning: only NIL and %s can be appended to %s\n", tag, tag); } diff --git a/src/consspaceobject.h b/src/consspaceobject.h index 4729061..b3e80cd 100644 --- a/src/consspaceobject.h +++ b/src/consspaceobject.h @@ -67,6 +67,7 @@ * A real number. */ #define REALTAG "REAL" +#define REALTV 1279346002 /** * A special form - one whose arguments are not pre-evaluated but passed as a diff --git a/src/init.c b/src/init.c index 1cee833..aeb5dfd 100644 --- a/src/init.c +++ b/src/init.c @@ -9,15 +9,17 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#include #include +#include +#include #include "version.h" #include "conspage.h" #include "consspaceobject.h" #include "intern.h" #include "lispops.h" -#include "print.h" -#include "read.h" +#include "repl.h" void bind_function( char* name, struct cons_pointer (*executable) (struct stack_frame*, struct cons_pointer)) { @@ -33,36 +35,61 @@ void bind_special( char* name, struct cons_pointer (*executable) } int main (int argc, char *argv[]) { - fprintf( stderr, "Post scarcity software environment version %s\n", VERSION); - initialise_cons_pages(); + /* attempt to set wide character acceptance on all streams */ + fwide(stdin, 1); + fwide(stdout, 1); + fwide(stderr, 1); + int option; + bool dump_at_end = false; + bool show_prompt = false; + + while ((option = getopt (argc, argv, "pd")) != -1) + { + switch (option) + { + case 'd': + dump_at_end = true; + break; + case 'p': + show_prompt = true; + break; + default: + fprintf( stderr, "Unexpected option %c\n", option); + break; + } + } - /* 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); + if (show_prompt) { + fprintf( stdout, "Post scarcity software environment version %s\n\n", VERSION); + } + + initialise_cons_pages(); - /* primitive function operations */ - bind_function( "assoc", &lisp_assoc); - bind_function( "car", &lisp_car); - bind_function( "cdr", &lisp_cdr); - bind_function( "cons", &lisp_cons); - bind_function( "eq", &lisp_eq); - bind_function( "equal", &lisp_equal); - bind_function( "read", &lisp_read); - bind_function( "print", &lisp_print); + /* 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); - /* primitive special forms */ - bind_special( "apply", &lisp_apply); - bind_special( "eval", &lisp_eval); - bind_special( "quote", &lisp_quote); + /* primitive function operations */ + bind_function( "assoc", &lisp_assoc); + bind_function( "car", &lisp_car); + bind_function( "cdr", &lisp_cdr); + bind_function( "cons", &lisp_cons); + bind_function( "eq", &lisp_eq); + bind_function( "equal", &lisp_equal); + bind_function( "read", &lisp_read); + bind_function( "print", &lisp_print); - fprintf( stderr, "\n:: "); - struct cons_pointer input = read( stdin); - fprintf( stderr, "\nread {%d,%d}=> ", input.page, input.offset); - print( stdout, input); - fprintf( stderr, "\neval {%d,%d}=> ", input.page, input.offset); - // print( stdout, lisp_eval( input, oblist, NULL)); + /* primitive special forms */ + bind_special( "apply", &lisp_apply); + bind_special( "eval", &lisp_eval); + bind_special( "quote", &lisp_quote); - dump_pages(stderr); - - return(0); + repl(stdin, stdout, stderr, show_prompt); + // print( stdout, lisp_eval( input, oblist, NULL)); + + if ( dump_at_end) { + dump_pages(stderr); + } + + return(0); } diff --git a/src/print.c b/src/print.c index 36e0fa9..78c209a 100644 --- a/src/print.c +++ b/src/print.c @@ -34,9 +34,9 @@ void print_string_contents( FILE* output, struct cons_pointer pointer) { void print_string( FILE* output, struct cons_pointer pointer) { - fputc( '"', output); + fputwc( btowc('"'), output); print_string_contents( output, pointer); - fputc( '"', output); + fputwc( btowc('"'), output); } /** @@ -49,7 +49,7 @@ void print_list_contents( FILE* output, struct cons_pointer pointer, switch ( cell->tag.value) { case CONSTV : if (initial_space) { - fputc( ' ', output); + fputwc( btowc(' '), output); } print( output, cell->payload.cons.car); @@ -58,16 +58,16 @@ void print_list_contents( FILE* output, struct cons_pointer pointer, case NILTV: break; default: - fprintf( output, " . "); + fwprintf( output, L" . "); print( output, pointer); } } void print_list( FILE* output, struct cons_pointer pointer) { - fputc( '(', output); + fputwc( btowc('('), output); print_list_contents( output, pointer, false); - fputc( ')', output); + fputwc( btowc(')'), output); } void print( FILE* output, struct cons_pointer pointer) { @@ -77,27 +77,31 @@ void print( FILE* output, struct cons_pointer pointer) { * statement can ultimately be replaced by a switch, which will * be neater. */ switch ( cell.tag.value) { - case CONSTV : - print_list( output, pointer); - break; - case INTEGERTV : - fprintf( output, "%ld", cell.payload.integer.value); - break; - case NILTV : - fprintf( output, "nil"); - break; - case STRINGTV : - print_string( output, pointer); - break; - case SYMBOLTV : - print_string_contents( output, pointer); - break; - case TRUETV : - fprintf( output, "t"); - break; - default : - fprintf( stderr, "Error: Unrecognised tag value %d (%c%c%c%c)\n", - cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1], - cell.tag.bytes[2], cell.tag.bytes[3]); + case CONSTV : + print_list( output, pointer); + break; + case INTEGERTV : + fwprintf( output, L"%ld", cell.payload.integer.value); + break; + case NILTV : + fwprintf( output, L"nil"); + break; + case REALTV: + fwprintf(output, L"%lf", cell.payload.real.value); + break; + case STRINGTV : + print_string( output, pointer); + break; + case SYMBOLTV : + print_string_contents( output, pointer); + break; + case TRUETV : + fwprintf( output, L"t"); + break; + default : + fwprintf( stderr, L"Error: Unrecognised tag value %d (%c%c%c%c)\n", + cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1], + cell.tag.bytes[2], cell.tag.bytes[3]); + break; } } diff --git a/src/read.c b/src/read.c index d45b628..d1f7753 100644 --- a/src/read.c +++ b/src/read.c @@ -8,6 +8,7 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#include #include #include /* wide characters */ @@ -18,6 +19,7 @@ #include "integer.h" #include "intern.h" #include "read.h" +#include "real.h" /* for the time being things which may be read are: strings @@ -87,8 +89,8 @@ struct cons_pointer read_number( FILE* input, wint_t initial) { fprintf( stderr, "read_number starting '%c' (%d)\n", initial, initial); - for (c = initial; iswdigit( c); c = fgetwc( input)) { - if ( c == '.') { + for (c = initial; iswdigit( c) || c == btowc('.'); c = fgetwc( input)) { + if ( c == btowc('.')) { seen_period = true; } else { accumulator = accumulator * 10 + ((int)c - (int)'0'); @@ -102,7 +104,13 @@ struct cons_pointer read_number( FILE* input, wint_t initial) { /* push back the character read which was not a digit */ ungetwc( c, input); - return make_integer( accumulator); + if (seen_period) { + return make_real(accumulator / pow(10, places_of_decimals)); + } + else + { + return make_integer( accumulator); + } } diff --git a/src/real.c b/src/real.c new file mode 100644 index 0000000..5805248 --- /dev/null +++ b/src/real.c @@ -0,0 +1,24 @@ +/* + * To change this license header, choose License Headers in Project Properties. + * To change this template file, choose Tools | Templates + * and open the template in the editor. + */ + +#include "conspage.h" +#include "consspaceobject.h" +#include "read.h" + +/** + * Allocate a real number cell representing this value and return a cons + * pointer to it. + * @param value the value to wrap; + * @return a real number cell wrapping this value. + */ +struct cons_pointer make_real( long double value) { + struct cons_pointer result = allocate_cell( REALTAG); + struct cons_space_object* cell = &pointer2cell(result); + cell->payload.real.value = value; + + return result; +} + diff --git a/src/real.h b/src/real.h new file mode 100644 index 0000000..261b0fa --- /dev/null +++ b/src/real.h @@ -0,0 +1,35 @@ +/* + * To change this license header, choose License Headers in Project Properties. + * To change this template file, choose Tools | Templates + * and open the template in the editor. + */ + +/* + * File: real.h + * Author: simon + * + * Created on 14 August 2017, 17:25 + */ + +#ifndef REAL_H +#define REAL_H + +#ifdef __cplusplus +extern "C" { +#endif + +/** + * Allocate a real number cell representing this value and return a cons + * pointer to it. + * @param value the value to wrap; + * @return a real number cell wrapping this value. + */ +struct cons_pointer make_real( double value); + + +#ifdef __cplusplus +} +#endif + +#endif /* REAL_H */ + diff --git a/src/repl.c b/src/repl.c new file mode 100644 index 0000000..8afda16 --- /dev/null +++ b/src/repl.c @@ -0,0 +1,42 @@ +/* + * To change this license header, choose License Headers in Project Properties. + * To change this template file, choose Tools | Templates + * and open the template in the editor. + */ +#include +#include +#include + +#include "conspage.h" +#include "consspaceobject.h" +#include "intern.h" +#include "lispops.h" +#include "read.h" +#include "print.h" + +/** + * The read/eval/print loop + * @param in_stream the stream to read from; + * @param out_stream the stream to write to; + * @param err_stream the stream to send errors to; + * @param show_prompt true if prompts should be shown. + */ +void repl( FILE* in_stream, FILE* out_stream, FILE* error_stream, + bool show_prompt) { + while (!feof(in_stream)) { + if (show_prompt) { + fwprintf( out_stream, L"\n:: "); + } + struct cons_pointer input = read( in_stream); + fwprintf( error_stream, L"\nread {%d,%d}=> ", input.page, input.offset); + if (show_prompt) { + fwprintf( out_stream, L"\n-> "); + } +// 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); + } +} + + diff --git a/src/repl.h b/src/repl.h new file mode 100644 index 0000000..7aff455 --- /dev/null +++ b/src/repl.h @@ -0,0 +1,37 @@ +/* + * To change this license header, choose License Headers in Project Properties. + * To change this template file, choose Tools | Templates + * and open the template in the editor. + */ + +/* + * File: repl.h + * Author: simon + * + * Created on 14 August 2017, 14:40 + */ + +#ifndef REPL_H +#define REPL_H + +#ifdef __cplusplus +extern "C" { +#endif + +/** + * The read/eval/print loop + * @param in_stream the stream to read from; + * @param out_stream the stream to write to; + * @param err_stream the stream to send errors to; + * @param show_prompt true if prompts should be shown. + */ +void repl( FILE* in_stream, FILE* out_stream, FILE* error_stream, + bool show_prompt); + + +#ifdef __cplusplus +} +#endif + +#endif /* REPL_H */ + diff --git a/unit-tests/complex-list.sh b/unit-tests/complex-list.sh index 6376fd6..c4c8e94 100644 --- a/unit-tests/complex-list.sh +++ b/unit-tests/complex-list.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='(1 2 3 ("Fred") nil 77354)' -actual=`echo '(1 2 3 ("Fred") () 77354)' | target/psse 2> /dev/null` +actual=`echo '(1 2 3 ("Fred") () 77354)' | target/psse 2> /dev/null | head -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/empty-list.sh.bash b/unit-tests/empty-list.sh.bash new file mode 100644 index 0000000..8e5d0b0 --- /dev/null +++ b/unit-tests/empty-list.sh.bash @@ -0,0 +1,19 @@ +#!/bin/bash +# +# File: empty-list.sh.bash +# Author: simon +# +# Created on 14-Aug-2017, 15:06:40 +# + +expected=nil +actual=`echo '()' | target/psse 2> /dev/null | head -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" + exit 0 +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi diff --git a/unit-tests/empty-string.sh b/unit-tests/empty-string.sh index 2eccbe3..24bcd7a 100644 --- a/unit-tests/empty-string.sh +++ b/unit-tests/empty-string.sh @@ -1,7 +1,7 @@ #!/bin/bash expected="\"\"" -actual=`echo '""' | target/psse 2> /dev/null` +actual=`echo '""' | target/psse 2> /dev/null | head -1` if [ "$expected" = "$actual" ] then diff --git a/unit-tests/fred.sh b/unit-tests/fred.sh index ebb03ac..62af33f 100644 --- a/unit-tests/fred.sh +++ b/unit-tests/fred.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='"Fred"' -actual=`echo ${expected} | target/psse 2> /dev/null` +actual=`echo ${expected} | target/psse 2> /dev/null | head -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/integer.sh b/unit-tests/integer.sh index e2d41f1..828eace 100644 --- a/unit-tests/integer.sh +++ b/unit-tests/integer.sh @@ -1,7 +1,7 @@ #!/bin/bash expected="354" -actual=`echo ${expected} | target/psse 2> /dev/null` +actual=`echo ${expected} | target/psse 2> /dev/null | head -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/nil.sh b/unit-tests/nil.sh index 5449330..8e9aea6 100644 --- a/unit-tests/nil.sh +++ b/unit-tests/nil.sh @@ -1,7 +1,7 @@ #!/bin/bash expected=nil -actual=`echo '()' | target/psse 2> /dev/null` +actual=`echo 'nil' | target/psse 2> /dev/null | head -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/quote.sh b/unit-tests/quote.sh index 624bdfb..f7bf353 100644 --- a/unit-tests/quote.sh +++ b/unit-tests/quote.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='(quote Fred)' -actual=`echo "'Fred" | target/psse 2> /dev/null` +actual=`echo "'Fred" | target/psse 2> /dev/null | head -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/quoted-list.sh b/unit-tests/quoted-list.sh index eb4e7f3..1d18369 100644 --- a/unit-tests/quoted-list.sh +++ b/unit-tests/quoted-list.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='(quote (123 (4 (5 nil)) Fred))' -actual=`echo "'(123 (4 (5 ())) Fred)" | target/psse 2> /dev/null` +actual=`echo "'(123 (4 (5 ())) Fred)" | target/psse 2> /dev/null | head -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/simple-list.sh b/unit-tests/simple-list.sh index 9ee9719..8d0c758 100644 --- a/unit-tests/simple-list.sh +++ b/unit-tests/simple-list.sh @@ -1,7 +1,7 @@ #!/bin/bash expected="(1 2 3)" -actual=`echo '(1 2 3)' | target/psse 2> /dev/null` +actual=`echo '(1 2 3)' | target/psse 2> /dev/null | head -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/string-with-spaces.sh b/unit-tests/string-with-spaces.sh index fb78b81..53e00c0 100644 --- a/unit-tests/string-with-spaces.sh +++ b/unit-tests/string-with-spaces.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='"Strings should be able to include spaces (and other stuff)!"' -actual=`echo ${expected} | target/psse 2> /dev/null` +actual=`echo ${expected} | target/psse 2> /dev/null | head -1` if [ "${expected}" = "${actual}" ] then From d7886550a62868c14b33857a78ab0b2c28bcff99 Mon Sep 17 00:00:00 2001 From: simon Date: Mon, 14 Aug 2017 20:18:13 +0100 Subject: [PATCH 03/27] Standardised formatting. --- Makefile | 9 +- src/conspage.c | 210 +++++++++++++----------- src/conspage.h | 13 +- src/consspaceobject.c | 246 +++++++++++++++------------- src/consspaceobject.h | 227 ++++++++++++++++---------- src/equal.c | 72 ++++---- src/equal.h | 4 +- src/init.c | 104 +++++++----- src/integer.c | 32 ++-- src/integer.h | 4 +- src/intern.c | 88 +++++----- src/intern.h | 19 ++- src/lispops.c | 371 +++++++++++++++++++++++------------------- src/lispops.h | 54 ++++-- src/print.c | 140 ++++++++-------- src/print.h | 2 +- src/read.c | 275 +++++++++++++++---------------- src/read.h | 2 +- src/real.c | 12 +- src/real.h | 9 +- src/repl.c | 24 +-- src/repl.h | 11 +- src/stack.c | 135 ++++++++------- src/stack.h | 16 +- src/version.h | 1 - 25 files changed, 1131 insertions(+), 949 deletions(-) diff --git a/Makefile b/Makefile index 84bf081..970f2b1 100644 --- a/Makefile +++ b/Makefile @@ -8,15 +8,22 @@ DEPS := $(OBJS:.o=.d) INC_DIRS := $(shell find $(SRC_DIRS) -type d) INC_FLAGS := $(addprefix -I,$(INC_DIRS)) +INDENT_FLAGS := -kr -nut -l79 -ts2 VERSION := "0.0.0" -CPPFLAGS ?= $(INC_FLAGS) -MMD -MP +CPPFLAGS ?= $(INC_FLAGS) -MMD -MP LDFLAGS := -lm $(TARGET): $(OBJS) $(CC) $(LDFLAGS) $(OBJS) -DVERSION=$(VERSION) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS) +format: + indent $(INDENT_FLAGS) $(SRCS) src/*.h + +test: + bash ./unit-tests.sh + .PHONY: clean clean: $(RM) $(TARGET) $(OBJS) $(DEPS) diff --git a/src/conspage.c b/src/conspage.c index 22a53e3..3e88b1e 100644 --- a/src/conspage.c +++ b/src/conspage.c @@ -19,8 +19,6 @@ #include "consspaceobject.h" #include "conspage.h" - - /** * Flag indicating whether conspage initialisation has been done. */ @@ -40,99 +38,110 @@ struct cons_pointer freelist = NIL; /** * An array of pointers to cons pages. */ -struct cons_page* conspages[NCONSPAGES]; - +struct cons_page *conspages[NCONSPAGES]; /** * Make a cons page whose serial number (i.e. index in the conspages directory) is pageno. * Initialise all cells and prepend each to the freelist; if pageno is zero, do not prepend * cells 0 and 1 to the freelist but initialise them as NIL and T respectively. */ -void make_cons_page() { - struct cons_page* result = malloc( sizeof( struct cons_page)); +void make_cons_page() +{ + struct cons_page *result = malloc(sizeof(struct cons_page)); - if ( result != NULL) { - conspages[initialised_cons_pages] = result; + if (result != NULL) { + conspages[initialised_cons_pages] = result; - for (int i = 0; i < CONSPAGESIZE; i++) { - struct cons_space_object * cell = &conspages[initialised_cons_pages]->cell[i]; - if ( initialised_cons_pages == 0 && i < 2) { - if ( i == 0) { - /* initialise cell as NIL */ - strncpy( &cell->tag.bytes[0], NILTAG, TAGLENGTH); - cell->count = MAXREFERENCE; - cell->payload.free.car = NIL; - cell->payload.free.cdr = NIL; - fprintf( stderr, "Allocated special cell NIL\n"); - } else if ( i == 1) { - /* initialise cell as T */ - strncpy( &cell->tag.bytes[0], TRUETAG, TAGLENGTH); - cell->count = MAXREFERENCE; - cell->payload.free.car = (struct cons_pointer){ 0, 1}; - cell->payload.free.cdr = (struct cons_pointer){ 0, 1}; - fprintf( stderr, "Allocated special cell T\n"); + for (int i = 0; i < CONSPAGESIZE; i++) { + struct cons_space_object *cell = + &conspages[initialised_cons_pages]->cell[i]; + if (initialised_cons_pages == 0 && i < 2) { + if (i == 0) { + /* + * initialise cell as NIL + */ + strncpy(&cell->tag.bytes[0], NILTAG, TAGLENGTH); + cell->count = MAXREFERENCE; + cell->payload.free.car = NIL; + cell->payload.free.cdr = NIL; + fprintf(stderr, "Allocated special cell NIL\n"); + } else if (i == 1) { + /* + * initialise cell as T + */ + strncpy(&cell->tag.bytes[0], TRUETAG, TAGLENGTH); + cell->count = MAXREFERENCE; + cell->payload.free.car = (struct cons_pointer) { + 0, 1}; + cell->payload.free.cdr = (struct cons_pointer) { + 0, 1}; + fprintf(stderr, "Allocated special cell T\n"); + } + } else { + /* + * otherwise, standard initialisation + */ + strncpy(&cell->tag.bytes[0], FREETAG, TAGLENGTH); + cell->payload.free.car = NIL; + cell->payload.free.cdr = freelist; + freelist.page = initialised_cons_pages; + freelist.offset = i; + } } - } else { - /* otherwise, standard initialisation */ - strncpy( &cell->tag.bytes[0], FREETAG, TAGLENGTH); - cell->payload.free.car = NIL; - cell->payload.free.cdr = freelist; - freelist.page = initialised_cons_pages; - freelist.offset = i; - } + + initialised_cons_pages++; + } else { + fprintf(stderr, + "FATAL: Failed to allocate memory for cons page %d\n", + initialised_cons_pages); + exit(1); } - initialised_cons_pages ++; - } else { - fprintf( stderr, "FATAL: Failed to allocate memory for cons page %d\n", initialised_cons_pages); - exit(1); - } - } - /** * dump the allocated pages to this output stream. */ -void dump_pages( FILE* output) { - for ( int i = 0; i < initialised_cons_pages; i++) { - fprintf( output, "\nDUMPING PAGE %d\n", i); +void dump_pages(FILE * output) +{ + for (int i = 0; i < initialised_cons_pages; i++) { + fprintf(output, "\nDUMPING PAGE %d\n", i); - for ( int j = 0; j < CONSPAGESIZE; j++) { - dump_object( output, (struct cons_pointer){i, j}); + for (int j = 0; j < CONSPAGESIZE; j++) { + dump_object(output, (struct cons_pointer) { + i, j}); + } } - } } - /** * Frees the cell at the specified pointer. Dangerous, primitive, low * level. * * @pointer the cell to free */ -void free_cell(struct cons_pointer pointer) { - struct cons_space_object* cell = &pointer2cell( pointer); +void free_cell(struct cons_pointer pointer) +{ + struct cons_space_object *cell = &pointer2cell(pointer); - if ( !check_tag(pointer, FREETAG)) { - if ( cell->count == 0) { - strncpy( &cell->tag.bytes[0], FREETAG, 4); - cell->payload.free.car = NIL; - cell->payload.free.cdr = freelist; - freelist = pointer; - } else { - fprintf( stderr, - "Attempt to free cell with %d dangling references at page %d, offset %d\n", - cell->count, pointer.page, pointer.offset); - } + if (!check_tag(pointer, FREETAG)) { + if (cell->count == 0) { + strncpy(&cell->tag.bytes[0], FREETAG, 4); + cell->payload.free.car = NIL; + cell->payload.free.cdr = freelist; + freelist = pointer; + } else { + fprintf(stderr, + "Attempt to free cell with %d dangling references at page %d, offset %d\n", + cell->count, pointer.page, pointer.offset); + } } else { - fprintf( stderr, - "Attempt to free cell which is already FREE at page %d, offset %d\n", - pointer.page, pointer.offset); - } + fprintf(stderr, + "Attempt to free cell which is already FREE at page %d, offset %d\n", + pointer.page, pointer.offset); + } } - /** * Allocates a cell with the specified tag. Dangerous, primitive, low * level. @@ -140,48 +149,51 @@ void free_cell(struct cons_pointer pointer) { * @param tag the tag of the cell to allocate - must be a valid cons space tag. * @return the cons pointer which refers to the cell allocated. */ -struct cons_pointer allocate_cell( char* tag) { - struct cons_pointer result = freelist; +struct cons_pointer allocate_cell(char *tag) +{ + struct cons_pointer result = freelist; - if ( result.page == NIL.page && result.offset == NIL.offset) { - make_cons_page(); - result = allocate_cell( tag); - } else { - struct cons_space_object* cell = &pointer2cell(result); - - if ( strncmp( &cell->tag.bytes[0], FREETAG, TAGLENGTH) == 0) { - freelist = cell->payload.free.cdr; - - strncpy( &cell->tag.bytes[0], tag, 4); - - cell->count = 0; - cell->payload.cons.car = NIL; - cell->payload.cons.cdr = NIL; - - fprintf( stderr, "Allocated cell of type '%s' at %d, %d \n", - tag, result.page, result.offset); - dump_object( stderr, result); + if (result.page == NIL.page && result.offset == NIL.offset) { + make_cons_page(); + result = allocate_cell(tag); } else { - fprintf( stderr, "WARNING: Allocating non-free cell!"); + struct cons_space_object *cell = &pointer2cell(result); + + if (strncmp(&cell->tag.bytes[0], FREETAG, TAGLENGTH) == 0) { + freelist = cell->payload.free.cdr; + + strncpy(&cell->tag.bytes[0], tag, 4); + + cell->count = 0; + cell->payload.cons.car = NIL; + cell->payload.cons.cdr = NIL; + + fprintf(stderr, + "Allocated cell of type '%s' at %d, %d \n", tag, + result.page, result.offset); + dump_object(stderr, result); + } else { + fprintf(stderr, "WARNING: Allocating non-free cell!"); + } } - } - return result; + return result; } - /** * initialise the cons page system; to be called exactly once during startup. */ -void initialise_cons_pages() { - if ( conspageinitihasbeencalled == false) { - for (int i = 0; i < NCONSPAGES; i++) { - conspages[i] = (struct cons_page *) NULL; - } +void initialise_cons_pages() +{ + if (conspageinitihasbeencalled == false) { + for (int i = 0; i < NCONSPAGES; i++) { + conspages[i] = (struct cons_page *) NULL; + } - make_cons_page(); - conspageinitihasbeencalled = true; - } else { - fprintf( stderr, "WARNING: conspageinit() called a second or subsequent time\n"); - } + make_cons_page(); + conspageinitihasbeencalled = true; + } else { + fprintf(stderr, + "WARNING: conspageinit() called a second or subsequent time\n"); + } } diff --git a/src/conspage.h b/src/conspage.h index db7b13e..4dba5c8 100644 --- a/src/conspage.h +++ b/src/conspage.h @@ -3,7 +3,6 @@ #ifndef __conspage_h #define __conspage_h - /** * the number of cons cells on a cons page. The maximum value this can be (and consequently, * the size which, by version 1, it will default to) is the maximum value of an unsigned 32 @@ -24,10 +23,9 @@ * my current view is that that's probably unneccessary. */ struct cons_page { - struct cons_space_object cell[CONSPAGESIZE]; + struct cons_space_object cell[CONSPAGESIZE]; }; - /** * The (global) pointer to the (global) freelist. Not sure whether this ultimately * belongs in this file. @@ -37,8 +35,7 @@ extern struct cons_pointer freelist; /** * An array of pointers to cons pages. */ -extern struct cons_page* conspages[NCONSPAGES]; - +extern struct cons_page *conspages[NCONSPAGES]; /** * Frees the cell at the specified pointer. Dangerous, primitive, low @@ -48,7 +45,6 @@ extern struct cons_page* conspages[NCONSPAGES]; */ void free_cell(struct cons_pointer pointer); - /** * Allocates a cell with the specified tag. Dangerous, primitive, low * level. @@ -56,8 +52,7 @@ void free_cell(struct cons_pointer pointer); * @param tag the tag of the cell to allocate - must be a valid cons space tag. * @return the cons pointer which refers to the cell allocated. */ -struct cons_pointer allocate_cell( char* tag); - +struct cons_pointer allocate_cell(char *tag); /** * initialise the cons page system; to be called exactly once during startup. @@ -67,6 +62,6 @@ void initialise_cons_pages(); /** * dump the allocated pages to this output stream. */ -void dump_pages( FILE* output); +void dump_pages(FILE * output); #endif diff --git a/src/consspaceobject.c b/src/consspaceobject.c index afc0002..7d0312b 100644 --- a/src/consspaceobject.c +++ b/src/consspaceobject.c @@ -11,7 +11,9 @@ #include #include #include -/* wide characters */ +/* + * wide characters + */ #include #include @@ -21,143 +23,145 @@ /** * Check that the tag on the cell at this pointer is this tag */ -int check_tag( struct cons_pointer pointer, char* tag) { - struct cons_space_object cell = pointer2cell(pointer); - return strncmp( &cell.tag.bytes[0], tag, TAGLENGTH) == 0; +int check_tag(struct cons_pointer pointer, char *tag) +{ + struct cons_space_object cell = pointer2cell(pointer); + return strncmp(&cell.tag.bytes[0], tag, TAGLENGTH) == 0; } - /** * increment the reference count of the object at this cons pointer. * * You can't roll over the reference count. Once it hits the maximum * value you cannot increment further. */ -void inc_ref( struct cons_pointer pointer) { - struct cons_space_object* cell = &pointer2cell( pointer); +void inc_ref(struct cons_pointer pointer) +{ + struct cons_space_object *cell = &pointer2cell(pointer); - if (cell->count < MAXREFERENCE) { - cell->count ++; - } + if (cell->count < MAXREFERENCE) { + cell->count++; + } } - /** * Decrement the reference count of the object at this cons pointer. * * If a count has reached MAXREFERENCE it cannot be decremented. * If a count is decremented to zero the cell should be freed. */ -void dec_ref( struct cons_pointer pointer) { - struct cons_space_object* cell = &pointer2cell( pointer); +void dec_ref(struct cons_pointer pointer) +{ + struct cons_space_object *cell = &pointer2cell(pointer); - if (cell->count <= MAXREFERENCE) { - cell->count --; + if (cell->count <= MAXREFERENCE) { + cell->count--; - if (cell->count == 0) { - free_cell( pointer); + if (cell->count == 0) { + free_cell(pointer); + } } - } } - /** * 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"\tDumping %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); +void dump_object(FILE * output, struct cons_pointer pointer) +{ + struct cons_space_object cell = pointer2cell(pointer); + fwprintf(output, + L"\tDumping %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); - if ( check_tag(pointer, CONSTAG)) { - 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)) { - fwprintf( output, - L"\t\tInteger cell: value %ld\n", - cell.payload.integer.value); - } else if ( check_tag( pointer, FREETAG)) { - 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)) { - fwprintf( output, L"\t\tReal cell: value %Lf\n", cell.payload.real.value); - } else if ( check_tag( pointer, STRINGTAG)) { - fwprintf( output, - L"String 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); - } + if (check_tag(pointer, CONSTAG)) { + 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)) { + fwprintf(output, + L"\t\tInteger cell: value %ld\n", cell.payload.integer.value); + } else if (check_tag(pointer, FREETAG)) { + 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)) { + fwprintf(output, L"\t\tReal cell: value %Lf\n", + cell.payload.real.value); + } else if (check_tag(pointer, STRINGTAG)) { + fwprintf(output, + L"String 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); + } } - /** * Construct a cons cell from this pair of pointers. */ -struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer cdr) { - struct cons_pointer pointer = NIL; +struct cons_pointer make_cons(struct cons_pointer car, struct cons_pointer cdr) +{ + struct cons_pointer pointer = NIL; - pointer = allocate_cell( CONSTAG); + pointer = allocate_cell(CONSTAG); - struct cons_space_object* cell = &conspages[pointer.page]->cell[pointer.offset]; + struct cons_space_object *cell = + &conspages[pointer.page]->cell[pointer.offset]; - inc_ref(car); - inc_ref(cdr); - cell->payload.cons.car = car; - cell->payload.cons.cdr = cdr; + inc_ref(car); + inc_ref(cdr); + cell->payload.cons.car = car; + cell->payload.cons.cdr = cdr; - return pointer; + return pointer; } /** * Construct a cell which points to an executable Lisp special form. */ -struct cons_pointer make_function( struct cons_pointer src, - struct cons_pointer (*executable) - (struct stack_frame*, struct cons_pointer)) { - struct cons_pointer pointer = allocate_cell( FUNCTIONTAG); - struct cons_space_object* cell = &pointer2cell(pointer); +struct cons_pointer +make_function(struct cons_pointer src, struct cons_pointer (*executable) + (struct stack_frame *, struct cons_pointer)) +{ + struct cons_pointer pointer = allocate_cell(FUNCTIONTAG); + struct cons_space_object *cell = &pointer2cell(pointer); - cell->payload.function.source = src; - cell->payload.function.executable = executable; + cell->payload.function.source = src; + cell->payload.function.executable = executable; - return pointer; + return pointer; } - + /** * Construct a string from this character (which later will be UTF) and * this tail. A string is implemented as a flat list of cells each of which * has one character and a pointer to the next; in the last cell the * pointer to next is NIL. */ -struct cons_pointer make_string_like_thing( wint_t c, - struct cons_pointer tail, - char* tag) { - struct cons_pointer pointer = NIL; - - if ( check_tag( tail, tag) || check_tag( tail, NILTAG)) { - pointer = allocate_cell( tag); - struct cons_space_object* cell = &pointer2cell(pointer); +struct cons_pointer +make_string_like_thing(wint_t c, struct cons_pointer tail, char *tag) +{ + struct cons_pointer pointer = NIL; - inc_ref(tail); - cell->payload.string.character = c; - cell->payload.string.cdr.page = tail.page; - cell->payload.string.cdr.offset = tail.offset; - } else { - fwprintf( stderr, L"Warning: only NIL and %s can be appended to %s\n", - tag, tag); - } - - return pointer; + if (check_tag(tail, tag) || check_tag(tail, NILTAG)) { + pointer = allocate_cell(tag); + struct cons_space_object *cell = &pointer2cell(pointer); + + inc_ref(tail); + cell->payload.string.character = c; + cell->payload.string.cdr.page = tail.page; + cell->payload.string.cdr.offset = tail.offset; + } else { + fwprintf(stderr, + L"Warning: only NIL and %s can be appended to %s\n", + tag, tag); + } + + return pointer; } /** @@ -166,56 +170,68 @@ struct cons_pointer make_string_like_thing( wint_t c, * has one character and a pointer to the next; in the last cell the * pointer to next is NIL. */ -struct cons_pointer make_string( wint_t c, struct cons_pointer tail) { - return make_string_like_thing( c, tail, STRINGTAG); +struct cons_pointer make_string(wint_t c, struct cons_pointer tail) +{ + return make_string_like_thing(c, tail, STRINGTAG); } /** * Construct a symbol from this character and this tail. */ -struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail) { - return make_string_like_thing( c, tail, SYMBOLTAG); +struct cons_pointer make_symbol(wint_t c, struct cons_pointer tail) +{ + return make_string_like_thing(c, tail, SYMBOLTAG); } /** * Construct a cell which points to an executable Lisp special form. */ -struct cons_pointer make_special( struct cons_pointer src, - struct cons_pointer (*executable) - (struct cons_pointer s_expr, - struct cons_pointer env, - struct stack_frame* frame)) { - struct cons_pointer pointer = allocate_cell( SPECIALTAG); - struct cons_space_object* cell = &pointer2cell(pointer); +struct cons_pointer +make_special(struct cons_pointer src, struct cons_pointer (*executable) - cell->payload.special.source = src; - cell->payload.special.executable = executable; - - return pointer; + + + + + + + + (struct cons_pointer s_expr, + struct cons_pointer env, struct stack_frame * frame)) +{ + struct cons_pointer pointer = allocate_cell(SPECIALTAG); + struct cons_space_object *cell = &pointer2cell(pointer); + + cell->payload.special.source = src; + cell->payload.special.executable = executable; + + return pointer; } /** * Return a lisp string representation of this old skool ASCII string. */ -struct cons_pointer c_string_to_lisp_string( char* string) { - struct cons_pointer result = NIL; +struct cons_pointer c_string_to_lisp_string(char *string) +{ + struct cons_pointer result = NIL; - for ( int i = strlen( string); i > 0; i--) { - result = make_string( (wint_t)string[ i - 1], result); - } + for (int i = strlen(string); i > 0; i--) { + result = make_string((wint_t) string[i - 1], result); + } - return result; + return result; } /** * Return a lisp symbol representation of this old skool ASCII string. */ -struct cons_pointer c_string_to_lisp_symbol( char* symbol) { - struct cons_pointer result = NIL; +struct cons_pointer c_string_to_lisp_symbol(char *symbol) +{ + struct cons_pointer result = NIL; - for ( int i = strlen( symbol); i > 0; i--) { - result = make_symbol( (wint_t)symbol[ i - 1], result); - } + for (int i = strlen(symbol); i > 0; i--) { + result = make_symbol((wint_t) symbol[i - 1], result); + } - return result; + return result; } diff --git a/src/consspaceobject.h b/src/consspaceobject.h index b3e80cd..ccba8df 100644 --- a/src/consspaceobject.h +++ b/src/consspaceobject.h @@ -11,7 +11,9 @@ #include #include #include -/* wide characters */ +/* + * wide characters + */ #include #include @@ -201,11 +203,14 @@ * An indirect pointer to a cons cell */ struct cons_pointer { - uint32_t page; /* the index of the page on which this cell resides */ - uint32_t offset; /* the index of the cell within the page */ + uint32_t page; /* the index of the page on which this cell + * resides */ + uint32_t offset; /* the index of the cell within the page */ }; -/* number of arguments stored in a stack frame */ +/* + * number of arguments stored in a stack frame + */ #define args_in_frame 8 /** @@ -213,20 +218,21 @@ struct cons_pointer { * here to avoid circularity. TODO: refactor. */ struct stack_frame { - struct stack_frame* previous; /* the previous frame */ - struct cons_pointer arg[args_in_frame]; - /* first 8 arument bindings */ - struct cons_pointer more; /* list of any further argument - * bindings */ - struct cons_pointer function; /* the function to be called */ + struct stack_frame *previous; /* the previous frame */ + struct cons_pointer arg[args_in_frame]; + /* + * first 8 arument bindings + */ + struct cons_pointer more; /* list of any further argument bindings */ + struct cons_pointer function; /* the function to be called */ }; /** * payload of a cons cell. */ struct cons_payload { - struct cons_pointer car; - struct cons_pointer cdr; + struct cons_pointer car; + struct cons_pointer cdr; }; /** @@ -237,10 +243,11 @@ struct cons_payload { * (representing its stack frame) and a cons pointer (representing its * environment) as arguments and returns a cons pointer (representing its * result). - */ + */ struct function_payload { - struct cons_pointer source; - struct cons_pointer (*executable)(struct stack_frame*, struct cons_pointer); + struct cons_pointer source; + struct cons_pointer (*executable) (struct stack_frame *, + struct cons_pointer); }; /** @@ -248,8 +255,8 @@ struct function_payload { * but it may not be so in future. */ struct free_payload { - struct cons_pointer car; - struct cons_pointer cdr; + struct cons_pointer car; + struct cons_pointer cdr; }; /** @@ -258,7 +265,7 @@ struct free_payload { * optional bignum object. */ struct integer_payload { - long int value; + long int value; }; /** @@ -266,7 +273,7 @@ struct integer_payload { * precision, but I'm not sure of the detail. */ struct real_payload { - long double value; + long double value; }; /** @@ -280,19 +287,19 @@ struct real_payload { * * NOTE that this means that special forms do not appear on the lisp stack, * which may be confusing. TODO: think about this. - */ + */ struct special_payload { - struct cons_pointer source; - struct cons_pointer (*executable)(struct cons_pointer s_expr, - struct cons_pointer env, - struct stack_frame* frame); + struct cons_pointer source; + struct cons_pointer (*executable) (struct cons_pointer s_expr, + struct cons_pointer env, + struct stack_frame * frame); }; /** * payload of a read or write stream cell. */ struct stream_payload { - FILE * stream; + FILE *stream; }; /** @@ -302,124 +309,164 @@ struct stream_payload { * payload of a string cell. */ struct string_payload { - wint_t character; /* the actual character stored in this cell */ - uint32_t padding; /* unused padding to word-align the cdr */ - struct cons_pointer cdr; + wint_t character; /* the actual character stored in this cell */ + uint32_t padding; /* unused padding to word-align the cdr */ + struct cons_pointer cdr; }; struct vectorp_payload { - union { - char bytes[TAGLENGTH]; /* the tag (type) of the vector-space - * object this cell points to, considered - * as bytes. NOTE that the vector space - * object should itself have the identical tag. */ - uint32_t value; /* the tag considered as a number */ - } tag; - uint64_t address; /* the address of the actual vector space - * object (TODO: will change when I actually - * implement vector space) */ + union { + char bytes[TAGLENGTH]; /* the tag (type) of the + * vector-space object this cell + * points to, considered as bytes. + * NOTE that the vector space object + * should itself have the identical + * tag. */ + uint32_t value; /* the tag considered as a number */ + } tag; + uint64_t address; /* the address of the actual vector space + * object (TODO: will change when I actually + * implement vector space) */ }; - /** * an object in cons space. */ struct cons_space_object { - union { - char bytes[TAGLENGTH]; /* the tag (type) of this cell, considered as bytes */ - uint32_t value; /* the tag considered as a number */ - } tag; - uint32_t count; /* the count of the number of references to this cell */ - struct cons_pointer access; /* cons pointer to the access control list of this cell */ - union { - /* if tag == CONSTAG */ - struct cons_payload cons; - /* if tag == FREETAG */ - struct free_payload free; - /* if tag == FUNCTIONTAG */ - struct function_payload function; - /* if tag == INTEGERTAG */ - struct integer_payload integer; - /* if tag == NILTAG; we'll treat the special cell NIL as just a cons */ - struct cons_payload nil; - /* if tag == READTAG || tag == WRITETAG */ - struct stream_payload stream; - /* if tag == REALTAG */ - struct real_payload real; - /* if tag == SPECIALTAG */ - struct special_payload special; - /* if tag == STRINGTAG || tag == SYMBOLTAG */ - struct string_payload string; - /* if tag == TRUETAG; we'll treat the special cell T as just a cons */ - struct cons_payload t; - /* if tag == VECTORPTAG */ - struct vectorp_payload vectorp; - } payload; + union { + char bytes[TAGLENGTH]; /* the tag (type) of this cell, + * considered as bytes */ + uint32_t value; /* the tag considered as a number */ + } tag; + uint32_t count; /* the count of the number of references to + * this cell */ + struct cons_pointer access; /* cons pointer to the access control list of + * this cell */ + union { + /* + * if tag == CONSTAG + */ + struct cons_payload cons; + /* + * if tag == FREETAG + */ + struct free_payload free; + /* + * if tag == FUNCTIONTAG + */ + struct function_payload function; + /* + * if tag == INTEGERTAG + */ + struct integer_payload integer; + /* + * if tag == NILTAG; we'll treat the special cell NIL as just a cons + */ + struct cons_payload nil; + /* + * if tag == READTAG || tag == WRITETAG + */ + struct stream_payload stream; + /* + * if tag == REALTAG + */ + struct real_payload real; + /* + * if tag == SPECIALTAG + */ + struct special_payload special; + /* + * if tag == STRINGTAG || tag == SYMBOLTAG + */ + struct string_payload string; + /* + * if tag == TRUETAG; we'll treat the special cell T as just a cons + */ + struct cons_payload t; + /* + * if tag == VECTORPTAG + */ + struct vectorp_payload vectorp; + } payload; }; - /** * Check that the tag on the cell at this pointer is this tag */ -int check_tag( struct cons_pointer pointer, char* tag); - +int check_tag(struct cons_pointer pointer, char *tag); /** * increment the reference count of the object at this cons pointer */ -void inc_ref( struct cons_pointer pointer); - +void inc_ref(struct cons_pointer pointer); /** * decrement the reference count of the object at this cons 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); +void dump_object(FILE * output, struct cons_pointer pointer); -struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer cdr); +struct cons_pointer make_cons(struct cons_pointer car, + struct cons_pointer cdr); /** * Construct a cell which points to an executable Lisp special form. */ -struct cons_pointer make_function( struct cons_pointer src, - struct cons_pointer (*executable) - (struct stack_frame*, struct cons_pointer)); +struct cons_pointer make_function(struct cons_pointer src, + struct cons_pointer (*executable) + + + + + + + + + (struct stack_frame *, + struct cons_pointer)); /** * Construct a cell which points to an executable Lisp special form. */ -struct cons_pointer make_special( struct cons_pointer src, - struct cons_pointer (*executable) - (struct cons_pointer s_expr, - struct cons_pointer env, - struct stack_frame* frame)); +struct cons_pointer make_special(struct cons_pointer src, + struct cons_pointer (*executable) + + + + + + + + + (struct cons_pointer s_expr, + struct cons_pointer env, + struct stack_frame * frame)); /** * Construct a string from this character and this tail. A string is * implemented as a flat list of cells each of which has one character and a * pointer to the next; in the last cell the pointer to next is NIL. */ -struct cons_pointer make_string( wint_t c, struct cons_pointer tail); +struct cons_pointer make_string(wint_t c, struct cons_pointer tail); /** * Construct a symbol from this character and this tail. A symbol is identical * to a string except for having a different tag. */ -struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail); +struct cons_pointer make_symbol(wint_t c, struct cons_pointer tail); /** * 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(char *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(char *symbol); #endif diff --git a/src/equal.c b/src/equal.c index 3b5cc6b..8814ea8 100644 --- a/src/equal.c +++ b/src/equal.c @@ -18,45 +18,55 @@ * Shallow, and thus cheap, equality: true if these two objects are * the same object, else false. */ -bool eq( struct cons_pointer a, struct cons_pointer b) { - return ((a.page == b.page) && (a.offset == b.offset)); +bool eq(struct cons_pointer a, struct cons_pointer b) +{ + return ((a.page == b.page) && (a.offset == b.offset)); } - /** * Deep, and thus expensive, equality: true if these two objects have * identical structure, else false. */ -bool equal( struct cons_pointer a, struct cons_pointer b) { - bool result = eq( a, b); +bool equal(struct cons_pointer a, struct cons_pointer b) +{ + bool result = eq(a, b); - if ( ! result) { - struct cons_space_object* cell_a = &pointer2cell( a); - struct cons_space_object* cell_b = &pointer2cell( b); + if (!result) { + struct cons_space_object *cell_a = &pointer2cell(a); + struct cons_space_object *cell_b = &pointer2cell(b); - if ( consp( a) && consp( b)) { - 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)) { - /* 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 practice only - * the empty string will. */ - result = cell_a->payload.string.character == 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); + if (consp(a) && consp(b)) { + 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)) { + /* + * 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 + * practice only the empty string will. + */ + result = + cell_a->payload.string.character == + 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); - /* 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); + } + /* + * 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 + * other ball game so we won't deal with it now (and indeedmay never). + * I'm not certain what equality means for read and write streams, so + * I'll ignore them, too, for now. + */ } - /* 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 other ball - * game so we won't deal with it now (and indeedmay never). I'm not certain - * what equality means for read and write streams, so I'll ignore them, too, - * for now.*/ - } - - return result; + + return result; } diff --git a/src/equal.h b/src/equal.h index 2c4a86d..796b983 100644 --- a/src/equal.h +++ b/src/equal.h @@ -19,12 +19,12 @@ * Shallow, and thus cheap, equality: true if these two objects are * the same object, else false. */ -bool eq( struct cons_pointer a, struct cons_pointer b); +bool eq(struct cons_pointer a, struct cons_pointer b); /** * Deep, and thus expensive, equality: true if these two objects have * identical structure, else false. */ -bool equal( struct cons_pointer a, struct cons_pointer b); +bool equal(struct cons_pointer a, struct cons_pointer b); #endif diff --git a/src/init.c b/src/init.c index aeb5dfd..38d03c8 100644 --- a/src/init.c +++ b/src/init.c @@ -21,75 +21,93 @@ #include "lispops.h" #include "repl.h" -void bind_function( char* name, struct cons_pointer (*executable) - (struct stack_frame*, struct cons_pointer)) { - deep_bind( intern( c_string_to_lisp_symbol( name), oblist ), - make_function( NIL, executable)); +void bind_function(char *name, struct cons_pointer (*executable) + (struct stack_frame *, struct cons_pointer)) +{ + deep_bind(intern(c_string_to_lisp_symbol(name), oblist), + make_function(NIL, executable)); } -void bind_special( char* name, struct cons_pointer (*executable) - (struct cons_pointer s_expr, struct cons_pointer env, - struct stack_frame* frame)) { - deep_bind( intern( c_string_to_lisp_symbol( name), oblist ), - make_special( NIL, executable)); +void bind_special(char *name, struct cons_pointer (*executable) + + + + + + + + + (struct cons_pointer s_expr, struct cons_pointer env, + struct stack_frame * frame)) +{ + deep_bind(intern(c_string_to_lisp_symbol(name), oblist), + make_special(NIL, executable)); } -int main (int argc, char *argv[]) { - /* attempt to set wide character acceptance on all streams */ +int main(int argc, char *argv[]) +{ + /* + * attempt to set wide character acceptance on all streams + */ fwide(stdin, 1); fwide(stdout, 1); fwide(stderr, 1); int option; bool dump_at_end = false; bool show_prompt = false; - - while ((option = getopt (argc, argv, "pd")) != -1) - { - switch (option) - { + + while ((option = getopt(argc, argv, "pd")) != -1) { + switch (option) { case 'd': - dump_at_end = true; - break; + dump_at_end = true; + break; case 'p': - show_prompt = true; - break; + show_prompt = true; + break; default: - fprintf( stderr, "Unexpected option %c\n", option); - break; - } + fprintf(stderr, "Unexpected option %c\n", option); + break; + } } if (show_prompt) { - fprintf( stdout, "Post scarcity software environment version %s\n\n", VERSION); + fprintf(stdout, + "Post scarcity software environment version %s\n\n", VERSION); } - + initialise_cons_pages(); - /* 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); + /* + * 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); - /* primitive function operations */ - bind_function( "assoc", &lisp_assoc); - bind_function( "car", &lisp_car); - bind_function( "cdr", &lisp_cdr); - bind_function( "cons", &lisp_cons); - bind_function( "eq", &lisp_eq); - bind_function( "equal", &lisp_equal); - bind_function( "read", &lisp_read); - bind_function( "print", &lisp_print); + /* + * primitive function operations + */ + bind_function("assoc", &lisp_assoc); + bind_function("car", &lisp_car); + bind_function("cdr", &lisp_cdr); + bind_function("cons", &lisp_cons); + bind_function("eq", &lisp_eq); + 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); + /* + * primitive special forms + */ + bind_special("apply", &lisp_apply); + bind_special("eval", &lisp_eval); + bind_special("quote", &lisp_quote); repl(stdin, stdout, stderr, show_prompt); // print( stdout, lisp_eval( input, oblist, NULL)); - if ( dump_at_end) { + if (dump_at_end) { dump_pages(stderr); } - return(0); + return (0); } diff --git a/src/integer.c b/src/integer.c index 8f7b044..b15541a 100644 --- a/src/integer.c +++ b/src/integer.c @@ -19,28 +19,28 @@ * as a cons-space object. Cell may in principle be any kind of number, * but only integers and reals are so far implemented. */ -double numeric_value( struct cons_pointer pointer) { - double result = NAN; - struct cons_space_object* cell = &pointer2cell(pointer); +double numeric_value(struct cons_pointer pointer) +{ + double result = NAN; + struct cons_space_object *cell = &pointer2cell(pointer); - if ( integerp( pointer)) { - result = (double) cell->payload.integer.value; - } else if ( realp( pointer)) { - result = cell->payload.real.value; - } + if (integerp(pointer)) { + result = (double) cell->payload.integer.value; + } else if (realp(pointer)) { + result = cell->payload.real.value; + } - return result; + return result; } - /** * Allocate an integer cell representing this value and return a cons pointer to it. */ -struct cons_pointer make_integer( int value) { - struct cons_pointer result = allocate_cell( INTEGERTAG); - struct cons_space_object* cell = &pointer2cell(result); - cell->payload.integer.value = value; +struct cons_pointer make_integer(int value) +{ + struct cons_pointer result = allocate_cell(INTEGERTAG); + struct cons_space_object *cell = &pointer2cell(result); + cell->payload.integer.value = value; - return result; + return result; } - diff --git a/src/integer.h b/src/integer.h index 5d1df67..a8cb101 100644 --- a/src/integer.h +++ b/src/integer.h @@ -11,11 +11,11 @@ #ifndef __integer_h #define __integer_h -double numeric_value( struct cons_pointer pointer); +double numeric_value(struct cons_pointer pointer); /** * Allocate an integer cell representing this value and return a cons pointer to it. */ -struct cons_pointer make_integer( int value); +struct cons_pointer make_integer(int value); #endif diff --git a/src/intern.c b/src/intern.c index 3cc9379..b71a4d1 100644 --- a/src/intern.c +++ b/src/intern.c @@ -43,21 +43,23 @@ struct cons_pointer oblist = NIL; * from the store (so that later when we want to retrieve a value, an eq test * will work); otherwise return NIL. */ -struct cons_pointer internedp( struct cons_pointer key, struct cons_pointer store) { - struct cons_pointer result = NIL; +struct cons_pointer +internedp(struct cons_pointer key, struct cons_pointer store) +{ + struct cons_pointer result = NIL; - for ( struct cons_pointer next = store; - nilp( result) && consp( next); - next = pointer2cell( next).payload.cons.cdr) { - struct cons_space_object entry = - pointer2cell( pointer2cell( next).payload.cons.car); + for (struct cons_pointer next = store; + nilp(result) && consp(next); + next = pointer2cell(next).payload.cons.cdr) { + struct cons_space_object entry = + pointer2cell(pointer2cell(next).payload.cons.car); - if ( equal( key, entry.payload.cons.car)) { - result = entry.payload.cons.car; + if (equal(key, entry.payload.cons.car)) { + result = entry.payload.cons.car; + } } - } - return result; + return result; } /** @@ -68,60 +70,64 @@ struct cons_pointer internedp( struct cons_pointer key, struct cons_pointer stor * If this key is lexically identical to a key in this store, return the value * of that key from the store; otherwise return NIL. */ -struct cons_pointer c_assoc( struct cons_pointer key, struct cons_pointer store) { - struct cons_pointer result = NIL; +struct cons_pointer c_assoc(struct cons_pointer key, struct cons_pointer store) +{ + struct cons_pointer result = NIL; - for ( struct cons_pointer next = store; - consp( next); - next = pointer2cell( next).payload.cons.cdr) { - struct cons_space_object entry = - pointer2cell( pointer2cell( next).payload.cons.car); + for (struct cons_pointer next = store; + consp(next); next = pointer2cell(next).payload.cons.cdr) { + struct cons_space_object entry = + pointer2cell(pointer2cell(next).payload.cons.car); - if ( equal( key, entry.payload.cons.car)) { - result = entry.payload.cons.cdr; - break; + if (equal(key, entry.payload.cons.car)) { + result = entry.payload.cons.cdr; + break; + } } - } - return result; + return result; } - /** * 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 bind( struct cons_pointer key, struct cons_pointer value, - struct cons_pointer store) { - return make_cons( make_cons( key, value), store); +struct cons_pointer +bind(struct cons_pointer key, struct cons_pointer value, + struct cons_pointer store) +{ + return make_cons(make_cons(key, value), store); } - /** * Binds this key to this value in the global oblist, but doesn't affect the * current environment. May not be useful except in bootstrapping (and even * there it may not be especially useful). */ -struct cons_pointer deep_bind( struct cons_pointer key, struct cons_pointer value) { - oblist = bind( key, value, oblist); - return oblist; +struct cons_pointer +deep_bind(struct cons_pointer key, struct cons_pointer value) +{ + oblist = bind(key, value, oblist); + return oblist; } - /** * Ensure that a canonical copy of this key is bound in this environment, and * return that canonical copy. If there is currently no such binding, create one * with the value NIL. */ -struct cons_pointer intern( struct cons_pointer key, - struct cons_pointer environment) { - struct cons_pointer result = environment; - struct cons_pointer canonical = internedp( key, environment); +struct cons_pointer +intern(struct cons_pointer key, struct cons_pointer environment) +{ + struct cons_pointer result = environment; + struct cons_pointer canonical = internedp(key, environment); - if ( nilp( canonical)) { - /* not currently bound */ - result = bind( key, NIL, environment); - } + if (nilp(canonical)) { + /* + * not currently bound + */ + result = bind(key, NIL, environment); + } - return result; + return result; } diff --git a/src/intern.h b/src/intern.h index 56adb33..98cc001 100644 --- a/src/intern.h +++ b/src/intern.h @@ -17,7 +17,6 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ - #ifndef __intern_h #define __intern_h @@ -28,35 +27,37 @@ extern struct cons_pointer oblist; * implementation a store is just an assoc list, but in future it might be a * namespace, a regularity or a homogeneity. */ -struct cons_pointer c_assoc( struct cons_pointer key, struct cons_pointer store); +struct cons_pointer c_assoc(struct cons_pointer key, + struct cons_pointer store); /** * Return true if this key is present as a key in this enviroment, defaulting to * the oblist if no environment is passed. */ -struct cons_pointer internedp( struct cons_pointer key, - struct cons_pointer environment); +struct cons_pointer internedp(struct cons_pointer key, + struct cons_pointer environment); /** * 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 bind( struct cons_pointer key, struct cons_pointer value, - struct cons_pointer store); +struct cons_pointer bind(struct cons_pointer key, + struct cons_pointer value, struct cons_pointer store); /** * Binds this key to this value in the global oblist, but doesn't affect the * current environment. May not be useful except in bootstrapping (and even * there it may not be especially useful). */ -struct cons_pointer deep_bind( struct cons_pointer key, struct cons_pointer value); +struct cons_pointer deep_bind(struct cons_pointer key, + struct cons_pointer value); /** * Ensure that a canonical copy of this key is bound in this environment, and * return that canonical copy. If there is currently no such binding, create one * with the value NIL. */ -struct cons_pointer intern( struct cons_pointer key, - struct cons_pointer environment); +struct cons_pointer intern(struct cons_pointer key, + struct cons_pointer environment); #endif diff --git a/src/lispops.c b/src/lispops.c index d85d9ac..9748797 100644 --- a/src/lispops.c +++ b/src/lispops.c @@ -37,11 +37,11 @@ /* * also to create in this section: * struct cons_pointer lisp_cond( struct cons_pointer args, struct cons_pointer env, - struct stack_frame* frame); + struct stack_frame* frame); * struct cons_pointer lisp_let( struct cons_pointer args, struct cons_pointer env, - struct stack_frame* frame); + struct stack_frame* frame); * struct cons_pointer lisp_mapcar( struct cons_pointer args, struct cons_pointer env, - struct stack_frame* frame); + struct stack_frame* frame); * * and others I haven't thought of yet. */ @@ -49,27 +49,29 @@ /** * Implementation of car in C. If arg is not a cons, does not error but returns nil. */ -struct cons_pointer c_car( struct cons_pointer arg) { - struct cons_pointer result = NIL; - - if ( consp(arg)) { - result = pointer2cell( arg).payload.cons.car; - } +struct cons_pointer c_car(struct cons_pointer arg) +{ + struct cons_pointer result = NIL; - return result; + if (consp(arg)) { + result = pointer2cell(arg).payload.cons.car; + } + + return result; } /** * Implementation of cdr in C. If arg is not a cons, does not error but returns nil. */ -struct cons_pointer c_cdr( struct cons_pointer arg) { - struct cons_pointer result = NIL; - - if ( consp(arg)) { - result = pointer2cell( arg).payload.cons.cdr; - } +struct cons_pointer c_cdr(struct cons_pointer arg) +{ + struct cons_pointer result = NIL; - return result; + if (consp(arg)) { + result = pointer2cell(arg).payload.cons.cdr; + } + + return result; } /** @@ -78,61 +80,70 @@ struct cons_pointer c_cdr( struct cons_pointer arg) { * I'm now confused about whether at this stage I actually need an apply special form, * and if so how it differs from eval. */ -struct cons_pointer lisp_apply( struct cons_pointer args, struct cons_pointer env, - struct stack_frame* frame) { - struct cons_pointer result = args; - - if ( consp( args)) { - lisp_eval( args, env, frame); - } +struct cons_pointer +lisp_apply(struct cons_pointer args, struct cons_pointer env, + struct stack_frame *frame) +{ + struct cons_pointer result = args; - return result; + if (consp(args)) { + lisp_eval(args, env, frame); + } + + return result; } -struct cons_pointer eval_cons( struct cons_pointer s_expr, struct cons_pointer env, - struct stack_frame* my_frame) { - struct cons_pointer result = NIL; - struct cons_pointer fn_pointer = lisp_eval( c_car( s_expr), env, my_frame); - struct cons_space_object fn_cell = pointer2cell( fn_pointer); - struct cons_pointer args = c_cdr( s_expr); +struct cons_pointer +eval_cons(struct cons_pointer s_expr, struct cons_pointer env, + struct stack_frame *my_frame) +{ + struct cons_pointer result = NIL; + struct cons_pointer fn_pointer = lisp_eval(c_car(s_expr), env, my_frame); + struct cons_space_object fn_cell = pointer2cell(fn_pointer); + struct cons_pointer args = c_cdr(s_expr); - switch ( fn_cell.tag.value) { - case SPECIALTV : - { - struct cons_space_object special = pointer2cell( fn_pointer); - result = (*special.payload.special.executable)( args, env, my_frame); + switch (fn_cell.tag.value) { + case SPECIALTV: + { + struct cons_space_object special = pointer2cell(fn_pointer); + result = + (*special.payload.special.executable) (args, env, my_frame); + } + break; + + case FUNCTIONTV: + /* + * actually, this is apply + */ + { + struct cons_space_object function = pointer2cell(fn_pointer); + struct stack_frame *frame = make_stack_frame(my_frame, args, env); + + /* + * the trick: pass the remaining arguments and environment to the + * executable code which is the payload of the function object. + */ + result = (*function.payload.function.executable) (frame, env); + free_stack_frame(frame); + } + break; + + default: + { + char *buffer = malloc(1024); + memset(buffer, '\0', 1024); + sprintf(buffer, + "Unexpected cell with tag %d (%c%c%c%c) in function position", + fn_cell.tag.value, fn_cell.tag.bytes[0], + fn_cell.tag.bytes[1], fn_cell.tag.bytes[2], + fn_cell.tag.bytes[3]); + struct cons_pointer message = c_string_to_lisp_string(buffer); + free(buffer); + result = lisp_throw(message, my_frame); + } } - break; - case FUNCTIONTV : - /* actually, this is apply */ - { - struct cons_space_object function = pointer2cell( fn_pointer); - struct stack_frame* frame = make_stack_frame( my_frame, args, env); - - /* the trick: pass the remaining arguments and environment to - the executable code which is the payload of the function - object. */ - result = (*function.payload.function.executable)( frame, env); - free_stack_frame( frame); - } - break; - - default : - { - char* buffer = malloc( 1024); - memset( buffer, '\0', 1024); - sprintf( buffer, - "Unexpected cell with tag %d (%c%c%c%c) in function position", - fn_cell.tag.value, fn_cell.tag.bytes[0], fn_cell.tag.bytes[1], - fn_cell.tag.bytes[2], fn_cell.tag.bytes[3]); - struct cons_pointer message = c_string_to_lisp_string( buffer); - free( buffer); - result = lisp_throw( message, my_frame); - } - } - - return result; + return result; } /** @@ -148,40 +159,45 @@ struct cons_pointer eval_cons( struct cons_pointer s_expr, struct cons_pointer e * passes them in a stack frame as arguments to the function. * If a special form, passes the cdr of s_expr to the special form as argument. */ -struct cons_pointer lisp_eval( struct cons_pointer s_expr, struct cons_pointer env, - struct stack_frame* previous) { - struct cons_pointer result = s_expr; - struct cons_space_object cell = pointer2cell( s_expr); - struct stack_frame* my_frame = - make_stack_frame( previous, make_cons( s_expr, NIL), env); +struct cons_pointer +lisp_eval(struct cons_pointer s_expr, struct cons_pointer env, + struct stack_frame *previous) +{ + struct cons_pointer result = s_expr; + struct cons_space_object cell = pointer2cell(s_expr); + struct stack_frame *my_frame = + make_stack_frame(previous, make_cons(s_expr, NIL), env); - switch ( cell.tag.value) { - case CONSTV : - result = eval_cons( s_expr, env, my_frame); - break; + switch (cell.tag.value) { + case CONSTV: + result = eval_cons(s_expr, env, my_frame); + break; - case SYMBOLTV : - { - struct cons_pointer canonical = internedp( s_expr, env); - if ( nilp( canonical)) { - struct cons_pointer message = - c_string_to_lisp_string( "Attempt to take value of unbound symbol."); - result = lisp_throw( message, my_frame); - } else { - result = c_assoc( canonical, env); - } + case SYMBOLTV: + { + struct cons_pointer canonical = internedp(s_expr, env); + if (nilp(canonical)) { + struct cons_pointer message = + c_string_to_lisp_string + ("Attempt to take value of unbound symbol."); + result = lisp_throw(message, my_frame); + } else { + result = c_assoc(canonical, env); + } + } + break; + /* + * the Clojure practice of having a map serve in the function place of + * an s-expression is a good one and I should adopt it; also if the + * object is a consp it could be interpretable source code but in the + * long run I don't want an interpreter, and if I can get away without + * so much the better. + */ } - break; - /* the Clojure practice of having a map serve in the function - * place of an s-expression is a good one and I should adopt it; - * also if the object is a consp it could be interpretable - * source code but in the long run I don't want an interpreter, - * and if I can get away without so much the better. */ - } - free_stack_frame( my_frame); - - return result; + free_stack_frame(my_frame); + + return result; } /** @@ -191,9 +207,11 @@ struct cons_pointer lisp_eval( struct cons_pointer s_expr, struct cons_pointer e * Returns its argument (strictly first argument - only one is expected but * this isn't at this stage checked) unevaluated. */ -struct cons_pointer lisp_quote( struct cons_pointer args, struct cons_pointer env, - struct stack_frame* frame) { - return c_car( args); +struct cons_pointer +lisp_quote(struct cons_pointer args, struct cons_pointer env, + struct stack_frame *frame) +{ + return c_car(args); } /** @@ -203,22 +221,24 @@ struct cons_pointer lisp_quote( struct cons_pointer args, struct cons_pointer en * Returns a cell constructed from a and b. If a is of type string but its * cdr is nill, and b is of type string, then returns a new string cell; * otherwise returns a new cons cell. - */ -struct cons_pointer lisp_cons(struct stack_frame* frame, struct cons_pointer env) { - struct cons_pointer car = frame->arg[0]; - struct cons_pointer cdr = frame->arg[1]; - struct cons_pointer result; + */ +struct cons_pointer +lisp_cons(struct stack_frame *frame, struct cons_pointer env) +{ + struct cons_pointer car = frame->arg[0]; + struct cons_pointer cdr = frame->arg[1]; + struct cons_pointer result; - if ( nilp( car) && nilp( cdr)) { - return NIL; - } else if ( stringp( car) && stringp( cdr) && - nilp( pointer2cell( car).payload.string.cdr)) { - result = make_string( pointer2cell( car).payload.string.character, cdr); - } else { - result = make_cons( car, cdr); - } + if (nilp(car) && nilp(cdr)) { + return NIL; + } else if (stringp(car) && stringp(cdr) && + nilp(pointer2cell(car).payload.string.cdr)) { + result = make_string(pointer2cell(car).payload.string.character, cdr); + } else { + result = make_cons(car, cdr); + } - return result; + return result; } /** @@ -226,70 +246,78 @@ struct cons_pointer lisp_cons(struct stack_frame* frame, struct cons_pointer env * Returns the first item (head) of a sequence. Valid for cons cells, * strings, and TODO read streams and other things which can be considered as sequences. */ -struct cons_pointer lisp_car(struct stack_frame* frame, struct cons_pointer env) { - struct cons_pointer result = NIL; +struct cons_pointer +lisp_car(struct stack_frame *frame, struct cons_pointer env) +{ + struct cons_pointer result = NIL; - if ( consp( frame->arg[ 0])) { - struct cons_space_object cell = pointer2cell( frame->arg[ 0]); - result = cell.payload.cons.car; - } else if ( stringp( frame->arg[ 0])) { - struct cons_space_object cell = pointer2cell( frame->arg[ 0]); - result = make_string( cell.payload.string.character, NIL); - } else { - struct cons_pointer message = - c_string_to_lisp_string( "Attempt to take CAR/CDR of non sequence"); - result = lisp_throw( message, frame); - } + if (consp(frame->arg[0])) { + struct cons_space_object cell = pointer2cell(frame->arg[0]); + result = cell.payload.cons.car; + } else if (stringp(frame->arg[0])) { + struct cons_space_object cell = pointer2cell(frame->arg[0]); + result = make_string(cell.payload.string.character, NIL); + } else { + struct cons_pointer message = + c_string_to_lisp_string("Attempt to take CAR/CDR of non sequence"); + result = lisp_throw(message, frame); + } - return result; + return result; } - /** * (cdr s_expr) * Returns the remainder of a sequence when the head is removed. Valid for cons cells, * strings, and TODO read streams and other things which can be considered as sequences. */ -struct cons_pointer lisp_cdr(struct stack_frame* frame, struct cons_pointer env) { - struct cons_pointer result = NIL; +struct cons_pointer +lisp_cdr(struct stack_frame *frame, struct cons_pointer env) +{ + struct cons_pointer result = NIL; - if ( consp( frame->arg[ 0])) { - struct cons_space_object cell = pointer2cell( frame->arg[ 0]); - result = cell.payload.cons.car; - } else if ( stringp( frame->arg[ 0])) { - struct cons_space_object cell = pointer2cell( frame->arg[ 0]); - result = cell.payload.string.cdr; - } else { - struct cons_pointer message = - c_string_to_lisp_string( "Attempt to take CAR/CDR of non sequence"); - result = lisp_throw( message, frame); - } + if (consp(frame->arg[0])) { + struct cons_space_object cell = pointer2cell(frame->arg[0]); + result = cell.payload.cons.car; + } else if (stringp(frame->arg[0])) { + struct cons_space_object cell = pointer2cell(frame->arg[0]); + result = cell.payload.string.cdr; + } else { + struct cons_pointer message = + c_string_to_lisp_string("Attempt to take CAR/CDR of non sequence"); + result = lisp_throw(message, frame); + } - return result; + return result; } /** * (assoc key store) * Returns the value associated with key in store, or NIL if not found. */ -struct cons_pointer lisp_assoc( struct stack_frame* frame, struct cons_pointer env) { - return c_assoc( frame->arg[ 0], frame->arg[ 1]); +struct cons_pointer +lisp_assoc(struct stack_frame *frame, struct cons_pointer env) +{ + return c_assoc(frame->arg[0], frame->arg[1]); } /** * (eq a b) * Returns T if a and b are pointers to the same object, else NIL */ -struct cons_pointer lisp_eq( struct stack_frame* frame, struct cons_pointer env) { - return eq( frame->arg[ 0], frame->arg[ 1]) ? TRUE : NIL; +struct cons_pointer lisp_eq(struct stack_frame *frame, struct cons_pointer env) +{ + return eq(frame->arg[0], frame->arg[1]) ? TRUE : NIL; } /** * (eq a b) * Returns T if a and b are pointers to structurally identical objects, else NIL */ -struct cons_pointer lisp_equal( struct stack_frame* frame, struct cons_pointer env) { - return equal( frame->arg[ 0], frame->arg[ 1]) ? TRUE : NIL; +struct cons_pointer +lisp_equal(struct stack_frame *frame, struct cons_pointer env) +{ + return equal(frame->arg[0], frame->arg[1]) ? TRUE : NIL; } /** @@ -298,14 +326,16 @@ struct cons_pointer lisp_equal( struct stack_frame* frame, struct cons_pointer e * Read one complete lisp form and return it. If read-stream is specified and * is a read stream, then read from that stream, else stdin. */ -struct cons_pointer lisp_read( struct stack_frame* frame, struct cons_pointer env) { - FILE* input = stdin; +struct cons_pointer +lisp_read(struct stack_frame *frame, struct cons_pointer env) +{ + FILE *input = stdin; - if ( readp( frame->arg[0])) { - input = pointer2cell( frame->arg[0]).payload.stream.stream; - } + if (readp(frame->arg[0])) { + input = pointer2cell(frame->arg[0]).payload.stream.stream; + } - return read( input); + return read(input); } /** @@ -314,27 +344,30 @@ struct cons_pointer lisp_read( struct stack_frame* frame, struct cons_pointer en * Print one complete lisp form and return NIL. If write-stream is specified and * is a write stream, then print to that stream, else stdout. */ -struct cons_pointer lisp_print( struct stack_frame* frame, struct cons_pointer env) { - FILE* output = stdout; +struct cons_pointer +lisp_print(struct stack_frame *frame, struct cons_pointer env) +{ + FILE *output = stdout; - if ( writep( frame->arg[1])) { - output = pointer2cell( frame->arg[1]).payload.stream.stream; - } + if (writep(frame->arg[1])) { + output = pointer2cell(frame->arg[1]).payload.stream.stream; + } - print( output, frame->arg[0]); - - return NIL; + print(output, frame->arg[0]); + + return NIL; } - /** * TODO: make this do something sensible somehow. */ -struct cons_pointer lisp_throw( struct cons_pointer message, struct stack_frame* frame) { - fprintf( stderr, "\nERROR: "); - print( stderr, message); - fprintf( stderr, "\n\nAn exception was thrown and I've no idea what to do now\n"); +struct cons_pointer +lisp_throw(struct cons_pointer message, struct stack_frame *frame) +{ + fprintf(stderr, "\nERROR: "); + print(stderr, message); + fprintf(stderr, + "\n\nAn exception was thrown and I've no idea what to do now\n"); - exit( 1); + exit(1); } - diff --git a/src/lispops.h b/src/lispops.h index 597d67f..de04134 100644 --- a/src/lispops.h +++ b/src/lispops.h @@ -19,23 +19,41 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ -/* special forms */ -struct cons_pointer lisp_eval( struct cons_pointer args, struct cons_pointer env, - struct stack_frame* frame); -struct cons_pointer lisp_apply( struct cons_pointer args, struct cons_pointer env, - struct stack_frame* frame); -struct cons_pointer lisp_quote( struct cons_pointer args, struct cons_pointer env, - struct stack_frame* frame); +/* + * special forms + */ +struct cons_pointer lisp_eval(struct cons_pointer args, + struct cons_pointer env, + struct stack_frame *frame); +struct cons_pointer lisp_apply(struct cons_pointer args, + struct cons_pointer env, + struct stack_frame *frame); +struct cons_pointer lisp_quote(struct cons_pointer args, + struct cons_pointer env, + struct stack_frame *frame); -/* functions */ -struct cons_pointer lisp_cons( struct stack_frame* frame, struct cons_pointer env); -struct cons_pointer lisp_car( struct stack_frame* frame, struct cons_pointer env); -struct cons_pointer lisp_cdr( struct stack_frame* frame, struct cons_pointer env); -struct cons_pointer lisp_assoc( struct stack_frame* frame, struct cons_pointer env); -struct cons_pointer lisp_eq( struct stack_frame* frame, struct cons_pointer env); -struct cons_pointer lisp_equal( struct stack_frame* frame, struct cons_pointer env); -struct cons_pointer lisp_read( struct stack_frame* frame, struct cons_pointer env); -struct cons_pointer lisp_print( struct stack_frame* frame, struct cons_pointer env); +/* + * functions + */ +struct cons_pointer lisp_cons(struct stack_frame *frame, + struct cons_pointer env); +struct cons_pointer lisp_car(struct stack_frame *frame, + struct cons_pointer env); +struct cons_pointer lisp_cdr(struct stack_frame *frame, + struct cons_pointer env); +struct cons_pointer lisp_assoc(struct stack_frame *frame, + struct cons_pointer env); +struct cons_pointer lisp_eq(struct stack_frame *frame, + struct cons_pointer env); +struct cons_pointer lisp_equal(struct stack_frame *frame, + struct cons_pointer env); +struct cons_pointer lisp_read(struct stack_frame *frame, + struct cons_pointer env); +struct cons_pointer lisp_print(struct stack_frame *frame, + struct cons_pointer env); -/* neither, at this stage, really */ -struct cons_pointer lisp_throw( struct cons_pointer message, struct stack_frame* frame); +/* + * neither, at this stage, really + */ +struct cons_pointer lisp_throw(struct cons_pointer message, + struct stack_frame *frame); diff --git a/src/print.c b/src/print.c index 78c209a..f7c3ba3 100644 --- a/src/print.c +++ b/src/print.c @@ -11,7 +11,9 @@ #include #include #include -/* wide characters */ +/* + * wide characters + */ #include #include @@ -20,88 +22,94 @@ #include "integer.h" #include "print.h" -void print_string_contents( FILE* output, struct cons_pointer pointer) { - if ( stringp( pointer) || symbolp( pointer)) { - struct cons_space_object* cell = &pointer2cell(pointer); - wint_t c = cell->payload.string.character; +void print_string_contents(FILE * output, struct cons_pointer pointer) +{ + if (stringp(pointer) || symbolp(pointer)) { + struct cons_space_object *cell = &pointer2cell(pointer); + wint_t c = cell->payload.string.character; - if ( c != '\0') { - fputwc( c, output); + if (c != '\0') { + fputwc(c, output); + } + print_string_contents(output, cell->payload.string.cdr); } - print_string_contents( output, cell->payload.string.cdr); - } } - -void print_string( FILE* output, struct cons_pointer pointer) { - fputwc( btowc('"'), output); - print_string_contents( output, pointer); - fputwc( btowc('"'), output); +void print_string(FILE * output, struct cons_pointer pointer) +{ + fputwc(btowc('"'), output); + print_string_contents(output, pointer); + fputwc(btowc('"'), output); } /** * Print a single list cell (cons cell). TODO: does not handle dotted pairs. */ -void print_list_contents( FILE* output, struct cons_pointer pointer, - bool initial_space) { - struct cons_space_object* cell = &pointer2cell(pointer); +void +print_list_contents(FILE * output, struct cons_pointer pointer, + bool initial_space) +{ + struct cons_space_object *cell = &pointer2cell(pointer); - switch ( cell->tag.value) { - case CONSTV : - if (initial_space) { - fputwc( btowc(' '), output); - } - print( output, cell->payload.cons.car); + switch (cell->tag.value) { + case CONSTV: + if (initial_space) { + fputwc(btowc(' '), output); + } + print(output, cell->payload.cons.car); - print_list_contents( output, cell->payload.cons.cdr, true); - break; - case NILTV: - break; - default: - fwprintf( output, L" . "); - print( output, pointer); - } + print_list_contents(output, cell->payload.cons.cdr, true); + break; + case NILTV: + break; + default: + fwprintf(output, L" . "); + print(output, pointer); + } } - -void print_list( FILE* output, struct cons_pointer pointer) { - fputwc( btowc('('), output); - print_list_contents( output, pointer, false); - fputwc( btowc(')'), output); +void print_list(FILE * output, struct cons_pointer pointer) +{ + fputwc(btowc('('), output); + print_list_contents(output, pointer, false); + fputwc(btowc(')'), output); } -void print( FILE* output, struct cons_pointer pointer) { - struct cons_space_object cell = pointer2cell( pointer); +void print(FILE * output, struct cons_pointer pointer) +{ + struct cons_space_object cell = pointer2cell(pointer); - /* Because tags have values as well as bytes, this if ... else if - * statement can ultimately be replaced by a switch, which will - * be neater. */ - switch ( cell.tag.value) { - case CONSTV : - print_list( output, pointer); - break; - case INTEGERTV : - fwprintf( output, L"%ld", cell.payload.integer.value); - break; - case NILTV : - fwprintf( output, L"nil"); - break; + /* + * Because tags have values as well as bytes, this if ... else if + * statement can ultimately be replaced by a switch, which will be neater. + */ + switch (cell.tag.value) { + case CONSTV: + print_list(output, pointer); + break; + case INTEGERTV: + fwprintf(output, L"%ld", cell.payload.integer.value); + break; + case NILTV: + fwprintf(output, L"nil"); + break; case REALTV: fwprintf(output, L"%lf", cell.payload.real.value); break; - case STRINGTV : - print_string( output, pointer); - break; - case SYMBOLTV : - print_string_contents( output, pointer); - break; - case TRUETV : - fwprintf( output, L"t"); - break; - default : - fwprintf( stderr, L"Error: Unrecognised tag value %d (%c%c%c%c)\n", - cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1], - cell.tag.bytes[2], cell.tag.bytes[3]); - break; - } + case STRINGTV: + print_string(output, pointer); + break; + case SYMBOLTV: + print_string_contents(output, pointer); + break; + case TRUETV: + fwprintf(output, L"t"); + break; + default: + fwprintf(stderr, + L"Error: Unrecognised tag value %d (%c%c%c%c)\n", + cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1], + cell.tag.bytes[2], cell.tag.bytes[3]); + break; + } } diff --git a/src/print.h b/src/print.h index 4ee1e5b..6f5bf85 100644 --- a/src/print.h +++ b/src/print.h @@ -14,6 +14,6 @@ #ifndef __print_h #define __print_h -void print( FILE* output, struct cons_pointer pointer); +void print(FILE * output, struct cons_pointer pointer); #endif diff --git a/src/read.c b/src/read.c index d1f7753..240816e 100644 --- a/src/read.c +++ b/src/read.c @@ -11,7 +11,9 @@ #include #include #include -/* wide characters */ +/* + * wide characters + */ #include #include @@ -21,23 +23,23 @@ #include "read.h" #include "real.h" -/* for the time being things which may be read are: - strings - numbers - either integer or real, but not yet including ratios or bignums - lists - Can't read atoms because I don't yet know what an atom is or how it's stored. */ +/* + * for the time being things which may be read are: strings numbers - either + * integer or real, but not yet including ratios or bignums lists Can't read + * atoms because I don't yet know what an atom is or how it's stored. + */ -struct cons_pointer read_number( FILE* input, wint_t initial); -struct cons_pointer read_list( 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_number(FILE * input, wint_t initial); +struct cons_pointer read_list(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); /** * quote reader macro in C (!) */ -struct cons_pointer c_quote( struct cons_pointer arg) { - return make_cons( c_string_to_lisp_symbol( "quote"), - make_cons( arg, NIL)); +struct cons_pointer c_quote(struct cons_pointer arg) +{ + return make_cons(c_string_to_lisp_symbol("quote"), make_cons(arg, NIL)); } /** @@ -45,94 +47,93 @@ struct cons_pointer c_quote( struct cons_pointer arg) { * treating this initial character as the first character of the object * representation. */ -struct cons_pointer read_continuation( FILE* input, wint_t initial) { - struct cons_pointer result = NIL; +struct cons_pointer read_continuation(FILE * input, wint_t initial) +{ + struct cons_pointer result = NIL; - wint_t c; + wint_t c; - for (c = initial; - c == '\0' || iswblank( c) || iswcntrl(c); - c = fgetwc( input)); - - switch( c) { - case '\'': - result = c_quote( read_continuation( input, fgetwc( input))); - break; - case '(' : - result = read_list(input, fgetwc( input)); - break; - case '"': - result = read_string(input, fgetwc( input)); - break; - default: - if ( iswdigit( c)) { - result = read_number( input, c); - } else if (iswprint( c)) { - result = read_symbol( input, c); - } else { - fprintf( stderr, "Unrecognised start of input character %c\n", c); + for (c = initial; + c == '\0' || iswblank(c) || iswcntrl(c); c = fgetwc(input)); + + switch (c) { + case '\'': + result = c_quote(read_continuation(input, fgetwc(input))); + break; + case '(': + result = read_list(input, fgetwc(input)); + break; + case '"': + result = read_string(input, fgetwc(input)); + break; + default: + if (iswdigit(c)) { + result = read_number(input, c); + } else if (iswprint(c)) { + result = read_symbol(input, c); + } else { + fprintf(stderr, "Unrecognised start of input character %c\n", c); + } } - } - return result; + return result; } - /** * read a number from this input stream, given this initial character. */ -struct cons_pointer read_number( FILE* input, wint_t initial) { - int accumulator = 0; - int places_of_decimals = 0; - bool seen_period = false; - wint_t c; +struct cons_pointer read_number(FILE * input, wint_t initial) +{ + int accumulator = 0; + int places_of_decimals = 0; + bool seen_period = false; + wint_t c; - fprintf( stderr, "read_number starting '%c' (%d)\n", initial, initial); - - for (c = initial; iswdigit( c) || c == btowc('.'); c = fgetwc( input)) { - if ( c == btowc('.')) { - seen_period = true; - } else { - accumulator = accumulator * 10 + ((int)c - (int)'0'); + fprintf(stderr, "read_number starting '%c' (%d)\n", initial, initial); - if ( seen_period) { - places_of_decimals ++; - } + for (c = initial; iswdigit(c) || c == btowc('.'); c = fgetwc(input)) { + if (c == btowc('.')) { + seen_period = true; + } else { + accumulator = accumulator * 10 + ((int) c - (int) '0'); + + if (seen_period) { + places_of_decimals++; + } + } } - } - /* push back the character read which was not a digit */ - ungetwc( c, input); + /* + * push back the character read which was not a digit + */ + ungetwc(c, input); - if (seen_period) { - return make_real(accumulator / pow(10, places_of_decimals)); - } - else - { - return make_integer( accumulator); - } + if (seen_period) { + return make_real(accumulator / pow(10, places_of_decimals)); + } else { + return make_integer(accumulator); + } } - /** * Read a list from this input stream, which no longer contains the opening * left parenthesis. */ -struct cons_pointer read_list( FILE* input, wint_t initial) { - struct cons_pointer result= NIL; +struct cons_pointer read_list(FILE * input, wint_t initial) +{ + struct cons_pointer result = NIL; - if ( initial != ')' ) { - fwprintf( stderr, L"read_list starting '%C' (%d)\n", initial, initial); - struct cons_pointer car = read_continuation( input, initial); - result = make_cons( car, read_list( input, fgetwc( input))); - } else { - fprintf( stderr, "End of list detected\n"); - } + if (initial != ')') { + fwprintf(stderr, L"read_list starting '%C' (%d)\n", initial, initial); + struct cons_pointer car = read_continuation(input, initial); + result = make_cons(car, read_list(input, fgetwc(input))); + } else { + fprintf(stderr, "End of list detected\n"); + } - return result; + return result; } - /** * Read a string. This means either a string delimited by double quotes * (is_quoted == true), in which case it may contain whitespace but may @@ -140,73 +141,75 @@ struct cons_pointer read_list( FILE* input, wint_t initial) { * so delimited in which case it may not contain whitespace (unless escaped) * but may contain a double quote character (probably not a good idea!) */ -struct cons_pointer read_string( FILE* input, wint_t initial) { - struct cons_pointer cdr = NIL; - struct cons_pointer result; +struct cons_pointer read_string(FILE * input, wint_t initial) +{ + struct cons_pointer cdr = NIL; + struct cons_pointer result; - fwprintf( stderr, L"read_string starting '%C' (%d)\n", - initial, initial); + fwprintf(stderr, L"read_string starting '%C' (%d)\n", initial, initial); - switch ( initial) { - case '\0': - result = make_string( initial, NIL); - break; - case '"': - result = make_string( '\0', NIL); - break; - default: - result = make_string( initial, read_string( input, fgetwc( input))); - break; - } - - return result; -} - - -struct cons_pointer read_symbol( FILE* input, wint_t initial) { - struct cons_pointer cdr = NIL; - struct cons_pointer result; - - fwprintf( stderr, L"read_symbol starting '%C' (%d)\n", - initial, initial); - - switch ( initial) { - case '\0': - result = make_symbol( initial, NIL); - break; - case '"': - /* THIS IS NOT A GOOD IDEA, but is legal */ - result = make_symbol( initial, read_symbol( input, fgetwc( input))); - break; - case ')' : - /* unquoted strings may not include right-parenthesis */ - result = make_symbol( '\0', NIL); - /* push back the character read */ - ungetwc( initial, input); - break; - default: - if ( iswblank( initial) || !iswprint( initial)) { - result = make_symbol( '\0', NIL); - /* push back the character read */ - ungetwc( initial, input); - } else { - result = make_symbol( initial, read_symbol( input, fgetwc( input))); + switch (initial) { + case '\0': + result = make_string(initial, NIL); + break; + case '"': + result = make_string('\0', NIL); + break; + default: + result = make_string(initial, read_string(input, fgetwc(input))); + break; } - break; - } - return result; + return result; } +struct cons_pointer read_symbol(FILE * input, wint_t initial) +{ + struct cons_pointer cdr = NIL; + struct cons_pointer result; + + fwprintf(stderr, L"read_symbol starting '%C' (%d)\n", initial, initial); + + switch (initial) { + case '\0': + result = make_symbol(initial, NIL); + break; + case '"': + /* + * THIS IS NOT A GOOD IDEA, but is legal + */ + result = make_symbol(initial, read_symbol(input, fgetwc(input))); + break; + case ')': + /* + * unquoted strings may not include right-parenthesis + */ + result = make_symbol('\0', NIL); + /* + * push back the character read + */ + ungetwc(initial, input); + break; + default: + if (iswblank(initial) || !iswprint(initial)) { + result = make_symbol('\0', NIL); + /* + * push back the character read + */ + ungetwc(initial, input); + } else { + result = make_symbol(initial, read_symbol(input, fgetwc(input))); + } + break; + } + + return result; +} /** * Read the next object on this input stream and return a cons_pointer to it. */ -struct cons_pointer read( FILE* input) { - return read_continuation( input, fgetwc( input)); +struct cons_pointer read(FILE * input) +{ + return read_continuation(input, fgetwc(input)); } - - - - - diff --git a/src/read.h b/src/read.h index 00e74c8..123e743 100644 --- a/src/read.h +++ b/src/read.h @@ -14,6 +14,6 @@ /** * read the next object on this input stream and return a cons_pointer to it. */ -struct cons_pointer read( FILE* input); +struct cons_pointer read(FILE * input); #endif diff --git a/src/real.c b/src/real.c index 5805248..0cd6803 100644 --- a/src/real.c +++ b/src/real.c @@ -14,11 +14,11 @@ * @param value the value to wrap; * @return a real number cell wrapping this value. */ -struct cons_pointer make_real( long double value) { - struct cons_pointer result = allocate_cell( REALTAG); - struct cons_space_object* cell = &pointer2cell(result); - cell->payload.real.value = value; +struct cons_pointer make_real(long double value) +{ + struct cons_pointer result = allocate_cell(REALTAG); + struct cons_space_object *cell = &pointer2cell(result); + cell->payload.real.value = value; - return result; + return result; } - diff --git a/src/real.h b/src/real.h index 261b0fa..9c0e1b9 100644 --- a/src/real.h +++ b/src/real.h @@ -4,7 +4,7 @@ * and open the template in the editor. */ -/* +/* * File: real.h * Author: simon * @@ -24,12 +24,9 @@ extern "C" { * @param value the value to wrap; * @return a real number cell wrapping this value. */ -struct cons_pointer make_real( double value); - + struct cons_pointer make_real(double value); #ifdef __cplusplus } #endif - -#endif /* REAL_H */ - +#endif /* REAL_H */ diff --git a/src/repl.c b/src/repl.c index 8afda16..d49fad8 100644 --- a/src/repl.c +++ b/src/repl.c @@ -21,22 +21,22 @@ * @param err_stream the stream to send errors to; * @param show_prompt true if prompts should be shown. */ -void repl( FILE* in_stream, FILE* out_stream, FILE* error_stream, - bool show_prompt) { +void +repl(FILE * in_stream, FILE * out_stream, FILE * error_stream, + bool show_prompt) +{ while (!feof(in_stream)) { if (show_prompt) { - fwprintf( out_stream, L"\n:: "); + fwprintf(out_stream, L"\n:: "); } - struct cons_pointer input = read( in_stream); - fwprintf( error_stream, L"\nread {%d,%d}=> ", input.page, input.offset); + struct cons_pointer input = read(in_stream); + fwprintf(error_stream, L"\nread {%d,%d}=> ", input.page, input.offset); if (show_prompt) { - fwprintf( out_stream, L"\n-> "); + fwprintf(out_stream, L"\n-> "); } -// 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); + // 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); } } - - diff --git a/src/repl.h b/src/repl.h index 7aff455..55a12d7 100644 --- a/src/repl.h +++ b/src/repl.h @@ -4,7 +4,7 @@ * and open the template in the editor. */ -/* +/* * File: repl.h * Author: simon * @@ -25,13 +25,10 @@ extern "C" { * @param err_stream the stream to send errors to; * @param show_prompt true if prompts should be shown. */ -void repl( FILE* in_stream, FILE* out_stream, FILE* error_stream, - bool show_prompt); - + void repl(FILE * in_stream, FILE * out_stream, + FILE * error_stream, bool show_prompt); #ifdef __cplusplus } #endif - -#endif /* REPL_H */ - +#endif /* REPL_H */ diff --git a/src/stack.c b/src/stack.c index 8894ff3..049f892 100644 --- a/src/stack.c +++ b/src/stack.c @@ -29,82 +29,95 @@ * Allocate a new stack frame with its previous pointer set to this value, * its arguments set up from these args, evaluated in this env. */ -struct stack_frame* make_stack_frame( struct stack_frame* previous, - struct cons_pointer args, - struct cons_pointer env) { - /* TODO: later, pop a frame off a free-list of stack frames */ - struct stack_frame* result = malloc( sizeof( struct stack_frame)); +struct stack_frame *make_stack_frame(struct stack_frame *previous, + struct cons_pointer args, + struct cons_pointer env) +{ + /* + * TODO: later, pop a frame off a free-list of stack frames + */ + struct stack_frame *result = malloc(sizeof(struct stack_frame)); - result->previous = previous; + result->previous = previous; - /* clearing the frame with memset would probably be slightly quicker, but - * this is clear. */ - result->more = NIL; - result->function = NIL; + /* + * clearing the frame with memset would probably be slightly quicker, but + * this is clear. + */ + result->more = NIL; + result->function = NIL; - for ( int i = 0; i < args_in_frame; i++) { - result->arg[i] = NIL; - } - - int i = 0; /* still an index into args, so same - * name will do */ - - while ( ! nilp( args)) { /* iterate down the arg list filling in - * the arg slots in the frame. When there - * are no more slots, if there are still - * args, stash them on more */ - struct cons_space_object cell = pointer2cell( args); - - if ( i < args_in_frame) { - /* TODO: if we were running on real massively parallel hardware, each - * arg except the first should be handed off to another processor to - * be evaled in parallel */ - result->arg[i] = lisp_eval( cell.payload.cons.car, env, result); - inc_ref( result->arg[i]); - - args = cell.payload.cons.cdr; - } else { - /* TODO: this isn't right. These args should also each be evaled. */ - result->more = args; - inc_ref( result->more); - - args = NIL; + for (int i = 0; i < args_in_frame; i++) { + result->arg[i] = NIL; } - } - return result; + int i = 0; /* still an index into args, so same name will + * do */ + + while (!nilp(args)) { /* iterate down the arg list filling in the + * arg slots in the frame. When there are no + * more slots, if there are still args, stash + * them on more */ + struct cons_space_object cell = pointer2cell(args); + + if (i < args_in_frame) { + /* + * TODO: if we were running on real massively parallel hardware, + * each arg except the first should be handed off to another + * processor to be evaled in parallel + */ + result->arg[i] = lisp_eval(cell.payload.cons.car, env, result); + inc_ref(result->arg[i]); + + args = cell.payload.cons.cdr; + } else { + /* + * TODO: this isn't right. These args should also each be evaled. + */ + result->more = args; + inc_ref(result->more); + + args = NIL; + } + } + + return result; } /** * Free this stack frame. */ -void free_stack_frame( struct stack_frame* frame) { - /* TODO: later, push it back on the stack-frame freelist */ - for ( int i = 0; i < args_in_frame; i++) { - dec_ref( frame->arg[ i]); - } - dec_ref( frame->more); - - free( frame); +void free_stack_frame(struct stack_frame *frame) +{ + /* + * TODO: later, push it back on the stack-frame freelist + */ + for (int i = 0; i < args_in_frame; i++) { + dec_ref(frame->arg[i]); + } + dec_ref(frame->more); + + free(frame); } /** * Fetch a pointer to the value of the local variable at this index. */ -struct cons_pointer fetch_arg( struct stack_frame* frame, unsigned int index) { - struct cons_pointer result = NIL; - - if ( index < args_in_frame) { - result = frame->arg[ index]; - } else { - struct cons_pointer p = frame->more; - - for ( int i = args_in_frame; i < index; i++) { - p = pointer2cell( p).payload.cons.cdr; +struct cons_pointer fetch_arg(struct stack_frame *frame, unsigned int index) +{ + struct cons_pointer result = NIL; + + if (index < args_in_frame) { + result = frame->arg[index]; + } else { + struct cons_pointer p = frame->more; + + for (int i = args_in_frame; i < index; i++) { + p = pointer2cell(p).payload.cons.cdr; + } + + result = pointer2cell(p).payload.cons.car; } - result = pointer2cell( p).payload.cons.car; - } - - return result; + return result; } diff --git a/src/stack.h b/src/stack.h index 9cb95a1..25ce84b 100644 --- a/src/stack.h +++ b/src/stack.h @@ -24,13 +24,15 @@ #ifndef __stack_h #define __stack_h -struct stack_frame* make_stack_frame( struct stack_frame* previous, - struct cons_pointer args, - struct cons_pointer env); -void free_stack_frame( struct stack_frame* frame); -struct cons_pointer fetch_arg( struct stack_frame* frame, unsigned int n); +struct stack_frame *make_stack_frame(struct stack_frame *previous, + struct cons_pointer args, + struct cons_pointer env); +void free_stack_frame(struct stack_frame *frame); +struct cons_pointer fetch_arg(struct stack_frame *frame, unsigned int n); -/* struct stack_frame is defined in consspaceobject.h to break circularity - * TODO: refactor. */ +/* + * struct stack_frame is defined in consspaceobject.h to break circularity + * TODO: refactor. + */ #endif diff --git a/src/version.h b/src/version.h index 3603e70..445229f 100644 --- a/src/version.h +++ b/src/version.h @@ -8,5 +8,4 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ - #define VERSION "0.0.0" From 2d5fe63b55ca0c8a7caf5fbb95c53d4d3bb402d8 Mon Sep 17 00:00:00 2001 From: simon Date: Wed, 16 Aug 2017 09:31:44 +0100 Subject: [PATCH 04/27] No backup files in RCS! --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitignore b/.gitignore index ecd8e8f..8ddda0d 100644 --- a/.gitignore +++ b/.gitignore @@ -6,3 +6,5 @@ target/ nbproject/ + +*~ From 784fdce49a63700266b8a09e3b4c72403e77efb7 Mon Sep 17 00:00:00 2001 From: simon Date: Tue, 12 Sep 2017 19:53:59 +0100 Subject: [PATCH 05/27] Ignore backup files. --- .gitignore | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/.gitignore b/.gitignore index ecd8e8f..056d7cb 100644 --- a/.gitignore +++ b/.gitignore @@ -6,3 +6,7 @@ target/ nbproject/ + +*.c~ + +*.h~ From 36d8431a91987664ca69a33ce3b18e4cd9789218 Mon Sep 17 00:00:00 2001 From: simon Date: Tue, 12 Sep 2017 22:14:11 +0100 Subject: [PATCH 06/27] 11 out of 12 unit tests passing, progress! I don't understand why it works, but it works. --- .gitignore | 4 +- Makefile | 6 +- README.md | 2 +- src/conspage.c | 113 +++++++++++------------ src/conspage.h | 8 +- src/consspaceobject.c | 157 +++++++++++++++----------------- src/consspaceobject.h | 48 +++++----- src/equal.c | 40 ++++----- src/equal.h | 4 +- src/init.c | 78 ++++++++-------- src/integer.c | 21 ++--- src/integer.h | 4 +- src/intern.c | 46 +++++----- src/intern.h | 21 ++--- src/lispops.c | 204 +++++++++++++++++++++--------------------- src/lispops.h | 52 +++++------ src/print.c | 81 ++++++++--------- src/print.h | 2 +- src/read.c | 139 ++++++++++++++-------------- src/read.h | 2 +- src/real.c | 7 +- src/real.h | 2 +- src/repl.c | 27 +++--- src/repl.h | 4 +- src/stack.c | 45 +++++----- src/stack.h | 10 +-- 26 files changed, 547 insertions(+), 580 deletions(-) diff --git a/.gitignore b/.gitignore index 056d7cb..8ddda0d 100644 --- a/.gitignore +++ b/.gitignore @@ -7,6 +7,4 @@ target/ nbproject/ -*.c~ - -*.h~ +*~ diff --git a/Makefile b/Makefile index 970f2b1..7916239 100644 --- a/Makefile +++ b/Makefile @@ -8,14 +8,14 @@ DEPS := $(OBJS:.o=.d) INC_DIRS := $(shell find $(SRC_DIRS) -type d) INC_FLAGS := $(addprefix -I,$(INC_DIRS)) -INDENT_FLAGS := -kr -nut -l79 -ts2 +INDENT_FLAGS := -kr -br -brf -brs -ce -cdw -npsl -nut -prs -l79 -ts2 VERSION := "0.0.0" -CPPFLAGS ?= $(INC_FLAGS) -MMD -MP +CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g LDFLAGS := -lm -$(TARGET): $(OBJS) +$(TARGET): $(OBJS) Makefile $(CC) $(LDFLAGS) $(OBJS) -DVERSION=$(VERSION) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS) format: diff --git a/README.md b/README.md index b1356e6..caa6375 100644 --- a/README.md +++ b/README.md @@ -20,5 +20,5 @@ Although I describe it as a 'Lisp environment', for reasons explained in Post Sc Copyright © 2017 [Simon Brooke](mailto:simon@journeyman.cc) -Distributed under the terms of the +Distributed under the terms of the [GNU General Public License v2](http://www.gnu.org/licenses/gpl-2.0.html) diff --git a/src/conspage.c b/src/conspage.c index 3e88b1e..3413091 100644 --- a/src/conspage.c +++ b/src/conspage.c @@ -45,43 +45,42 @@ struct cons_page *conspages[NCONSPAGES]; * Initialise all cells and prepend each to the freelist; if pageno is zero, do not prepend * cells 0 and 1 to the freelist but initialise them as NIL and T respectively. */ -void make_cons_page() -{ - struct cons_page *result = malloc(sizeof(struct cons_page)); +void make_cons_page( ) { + struct cons_page *result = malloc( sizeof( struct cons_page ) ); - if (result != NULL) { + if ( result != NULL ) { conspages[initialised_cons_pages] = result; - for (int i = 0; i < CONSPAGESIZE; i++) { + for ( int i = 0; i < CONSPAGESIZE; i++ ) { struct cons_space_object *cell = &conspages[initialised_cons_pages]->cell[i]; - if (initialised_cons_pages == 0 && i < 2) { - if (i == 0) { + if ( initialised_cons_pages == 0 && i < 2 ) { + if ( i == 0 ) { /* * initialise cell as NIL */ - strncpy(&cell->tag.bytes[0], NILTAG, TAGLENGTH); + strncpy( &cell->tag.bytes[0], NILTAG, TAGLENGTH ); cell->count = MAXREFERENCE; cell->payload.free.car = NIL; cell->payload.free.cdr = NIL; - fprintf(stderr, "Allocated special cell NIL\n"); - } else if (i == 1) { + fprintf( stderr, "Allocated special cell NIL\n" ); + } else if ( i == 1 ) { /* * initialise cell as T */ - strncpy(&cell->tag.bytes[0], TRUETAG, TAGLENGTH); + strncpy( &cell->tag.bytes[0], TRUETAG, TAGLENGTH ); cell->count = MAXREFERENCE; - cell->payload.free.car = (struct cons_pointer) { + cell->payload.free.car = ( struct cons_pointer ) { 0, 1}; - cell->payload.free.cdr = (struct cons_pointer) { + cell->payload.free.cdr = ( struct cons_pointer ) { 0, 1}; - fprintf(stderr, "Allocated special cell T\n"); + fprintf( stderr, "Allocated special cell T\n" ); } } else { /* * otherwise, standard initialisation */ - strncpy(&cell->tag.bytes[0], FREETAG, TAGLENGTH); + strncpy( &cell->tag.bytes[0], FREETAG, TAGLENGTH ); cell->payload.free.car = NIL; cell->payload.free.cdr = freelist; freelist.page = initialised_cons_pages; @@ -91,10 +90,10 @@ void make_cons_page() initialised_cons_pages++; } else { - fprintf(stderr, - "FATAL: Failed to allocate memory for cons page %d\n", - initialised_cons_pages); - exit(1); + fprintf( stderr, + "FATAL: Failed to allocate memory for cons page %d\n", + initialised_cons_pages ); + exit( 1 ); } } @@ -102,14 +101,13 @@ void make_cons_page() /** * dump the allocated pages to this output stream. */ -void dump_pages(FILE * output) -{ - for (int i = 0; i < initialised_cons_pages; i++) { - fprintf(output, "\nDUMPING PAGE %d\n", i); +void dump_pages( FILE * output ) { + for ( int i = 0; i < initialised_cons_pages; i++ ) { + fprintf( output, "\nDUMPING PAGE %d\n", i ); - for (int j = 0; j < CONSPAGESIZE; j++) { - dump_object(output, (struct cons_pointer) { - i, j}); + for ( int j = 0; j < CONSPAGESIZE; j++ ) { + dump_object( output, ( struct cons_pointer ) { + i, j} ); } } } @@ -120,25 +118,24 @@ void dump_pages(FILE * output) * * @pointer the cell to free */ -void free_cell(struct cons_pointer pointer) -{ - struct cons_space_object *cell = &pointer2cell(pointer); +void free_cell( struct cons_pointer pointer ) { + struct cons_space_object *cell = &pointer2cell( pointer ); - if (!check_tag(pointer, FREETAG)) { - if (cell->count == 0) { - strncpy(&cell->tag.bytes[0], FREETAG, 4); + if ( !check_tag( pointer, FREETAG ) ) { + if ( cell->count == 0 ) { + strncpy( &cell->tag.bytes[0], FREETAG, 4 ); cell->payload.free.car = NIL; cell->payload.free.cdr = freelist; freelist = pointer; } else { - fprintf(stderr, - "Attempt to free cell with %d dangling references at page %d, offset %d\n", - cell->count, pointer.page, pointer.offset); + fprintf( stderr, + "Attempt to free cell with %d dangling references at page %d, offset %d\n", + cell->count, pointer.page, pointer.offset ); } } else { - fprintf(stderr, - "Attempt to free cell which is already FREE at page %d, offset %d\n", - pointer.page, pointer.offset); + fprintf( stderr, + "Attempt to free cell which is already FREE at page %d, offset %d\n", + pointer.page, pointer.offset ); } } @@ -149,31 +146,30 @@ void free_cell(struct cons_pointer pointer) * @param tag the tag of the cell to allocate - must be a valid cons space tag. * @return the cons pointer which refers to the cell allocated. */ -struct cons_pointer allocate_cell(char *tag) -{ +struct cons_pointer allocate_cell( char *tag ) { struct cons_pointer result = freelist; - if (result.page == NIL.page && result.offset == NIL.offset) { - make_cons_page(); - result = allocate_cell(tag); + if ( result.page == NIL.page && result.offset == NIL.offset ) { + make_cons_page( ); + result = allocate_cell( tag ); } else { - struct cons_space_object *cell = &pointer2cell(result); + struct cons_space_object *cell = &pointer2cell( result ); - if (strncmp(&cell->tag.bytes[0], FREETAG, TAGLENGTH) == 0) { + if ( strncmp( &cell->tag.bytes[0], FREETAG, TAGLENGTH ) == 0 ) { freelist = cell->payload.free.cdr; - strncpy(&cell->tag.bytes[0], tag, 4); + strncpy( &cell->tag.bytes[0], tag, 4 ); cell->count = 0; cell->payload.cons.car = NIL; cell->payload.cons.cdr = NIL; - fprintf(stderr, - "Allocated cell of type '%s' at %d, %d \n", tag, - result.page, result.offset); - dump_object(stderr, result); + fprintf( stderr, + "Allocated cell of type '%s' at %d, %d \n", tag, + result.page, result.offset ); + dump_object( stderr, result ); } else { - fprintf(stderr, "WARNING: Allocating non-free cell!"); + fprintf( stderr, "WARNING: Allocating non-free cell!" ); } } @@ -183,17 +179,16 @@ struct cons_pointer allocate_cell(char *tag) /** * initialise the cons page system; to be called exactly once during startup. */ -void initialise_cons_pages() -{ - if (conspageinitihasbeencalled == false) { - for (int i = 0; i < NCONSPAGES; i++) { - conspages[i] = (struct cons_page *) NULL; +void initialise_cons_pages( ) { + if ( conspageinitihasbeencalled == false ) { + for ( int i = 0; i < NCONSPAGES; i++ ) { + conspages[i] = ( struct cons_page * ) NULL; } - make_cons_page(); + make_cons_page( ); conspageinitihasbeencalled = true; } else { - fprintf(stderr, - "WARNING: conspageinit() called a second or subsequent time\n"); + fprintf( stderr, + "WARNING: conspageinit() called a second or subsequent time\n" ); } } diff --git a/src/conspage.h b/src/conspage.h index 4dba5c8..0dfff8f 100644 --- a/src/conspage.h +++ b/src/conspage.h @@ -43,7 +43,7 @@ extern struct cons_page *conspages[NCONSPAGES]; * * @pointer the cell to free */ -void free_cell(struct cons_pointer pointer); +void free_cell( struct cons_pointer pointer ); /** * Allocates a cell with the specified tag. Dangerous, primitive, low @@ -52,16 +52,16 @@ void free_cell(struct cons_pointer pointer); * @param tag the tag of the cell to allocate - must be a valid cons space tag. * @return the cons pointer which refers to the cell allocated. */ -struct cons_pointer allocate_cell(char *tag); +struct cons_pointer allocate_cell( char *tag ); /** * initialise the cons page system; to be called exactly once during startup. */ -void initialise_cons_pages(); +void initialise_cons_pages( ); /** * dump the allocated pages to this output stream. */ -void dump_pages(FILE * output); +void dump_pages( FILE * output ); #endif diff --git a/src/consspaceobject.c b/src/consspaceobject.c index 7d0312b..a75dbd2 100644 --- a/src/consspaceobject.c +++ b/src/consspaceobject.c @@ -23,10 +23,9 @@ /** * Check that the tag on the cell at this pointer is this tag */ -int check_tag(struct cons_pointer pointer, char *tag) -{ - struct cons_space_object cell = pointer2cell(pointer); - return strncmp(&cell.tag.bytes[0], tag, TAGLENGTH) == 0; +int check_tag( struct cons_pointer pointer, char *tag ) { + struct cons_space_object cell = pointer2cell( pointer ); + return strncmp( &cell.tag.bytes[0], tag, TAGLENGTH ) == 0; } /** @@ -35,11 +34,10 @@ int check_tag(struct cons_pointer pointer, char *tag) * You can't roll over the reference count. Once it hits the maximum * value you cannot increment further. */ -void inc_ref(struct cons_pointer pointer) -{ - struct cons_space_object *cell = &pointer2cell(pointer); +void inc_ref( struct cons_pointer pointer ) { + struct cons_space_object *cell = &pointer2cell( pointer ); - if (cell->count < MAXREFERENCE) { + if ( cell->count < MAXREFERENCE ) { cell->count++; } } @@ -50,15 +48,14 @@ void inc_ref(struct cons_pointer pointer) * If a count has reached MAXREFERENCE it cannot be decremented. * If a count is decremented to zero the cell should be freed. */ -void dec_ref(struct cons_pointer pointer) -{ - struct cons_space_object *cell = &pointer2cell(pointer); +void dec_ref( struct cons_pointer pointer ) { + struct cons_space_object *cell = &pointer2cell( pointer ); - if (cell->count <= MAXREFERENCE) { + if ( cell->count <= MAXREFERENCE ) { cell->count--; - if (cell->count == 0) { - free_cell(pointer); + if ( cell->count == 0 ) { + free_cell( pointer ); } } } @@ -66,54 +63,55 @@ 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_space_object cell = pointer2cell(pointer); - fwprintf(output, - L"\tDumping %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); +void dump_object( FILE * output, struct cons_pointer pointer ) { + struct cons_space_object cell = pointer2cell( pointer ); + fwprintf( output, + L"\tDumping %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 ); - if (check_tag(pointer, CONSTAG)) { - 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)) { - fwprintf(output, - L"\t\tInteger cell: value %ld\n", cell.payload.integer.value); - } else if (check_tag(pointer, FREETAG)) { - 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)) { - fwprintf(output, L"\t\tReal cell: value %Lf\n", - cell.payload.real.value); - } else if (check_tag(pointer, STRINGTAG)) { - fwprintf(output, - L"String 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); + if ( check_tag( pointer, CONSTAG ) ) { + 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 ) ) { + fwprintf( output, + L"\t\tInteger cell: value %ld\n", + cell.payload.integer.value ); + } else if ( check_tag( pointer, FREETAG ) ) { + 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 ) ) { + fwprintf( output, L"\t\tReal cell: value %Lf\n", + cell.payload.real.value ); + } else if ( check_tag( pointer, STRINGTAG ) ) { + fwprintf( output, + L"String 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 ); } } /** * Construct a cons cell from this pair of pointers. */ -struct cons_pointer make_cons(struct cons_pointer car, struct cons_pointer cdr) -{ +struct cons_pointer make_cons( struct cons_pointer car, + struct cons_pointer cdr ) { struct cons_pointer pointer = NIL; - pointer = allocate_cell(CONSTAG); + pointer = allocate_cell( CONSTAG ); struct cons_space_object *cell = &conspages[pointer.page]->cell[pointer.offset]; - inc_ref(car); - inc_ref(cdr); + inc_ref( car ); + inc_ref( cdr ); cell->payload.cons.car = car; cell->payload.cons.cdr = cdr; @@ -124,11 +122,10 @@ struct cons_pointer make_cons(struct cons_pointer car, struct cons_pointer cdr) * Construct a cell which points to an executable Lisp special form. */ struct cons_pointer -make_function(struct cons_pointer src, struct cons_pointer (*executable) - (struct stack_frame *, struct cons_pointer)) -{ - struct cons_pointer pointer = allocate_cell(FUNCTIONTAG); - struct cons_space_object *cell = &pointer2cell(pointer); +make_function( struct cons_pointer src, struct cons_pointer ( *executable ) + ( struct stack_frame *, struct cons_pointer ) ) { + struct cons_pointer pointer = allocate_cell( FUNCTIONTAG ); + struct cons_space_object *cell = &pointer2cell( pointer ); cell->payload.function.source = src; cell->payload.function.executable = executable; @@ -143,22 +140,21 @@ make_function(struct cons_pointer src, struct cons_pointer (*executable) * pointer to next is NIL. */ struct cons_pointer -make_string_like_thing(wint_t c, struct cons_pointer tail, char *tag) -{ +make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) { struct cons_pointer pointer = NIL; - if (check_tag(tail, tag) || check_tag(tail, NILTAG)) { - pointer = allocate_cell(tag); - struct cons_space_object *cell = &pointer2cell(pointer); + if ( check_tag( tail, tag ) || check_tag( tail, NILTAG ) ) { + pointer = allocate_cell( tag ); + struct cons_space_object *cell = &pointer2cell( pointer ); - inc_ref(tail); + inc_ref( tail ); cell->payload.string.character = c; cell->payload.string.cdr.page = tail.page; cell->payload.string.cdr.offset = tail.offset; } else { - fwprintf(stderr, - L"Warning: only NIL and %s can be appended to %s\n", - tag, tag); + fwprintf( stderr, + L"Warning: only NIL and %s can be appended to %s\n", + tag, tag ); } return pointer; @@ -170,24 +166,22 @@ make_string_like_thing(wint_t c, struct cons_pointer tail, char *tag) * has one character and a pointer to the next; in the last cell the * pointer to next is NIL. */ -struct cons_pointer make_string(wint_t c, struct cons_pointer tail) -{ - return make_string_like_thing(c, tail, STRINGTAG); +struct cons_pointer make_string( wint_t c, struct cons_pointer tail ) { + return make_string_like_thing( c, tail, STRINGTAG ); } /** * Construct a symbol from this character and this tail. */ -struct cons_pointer make_symbol(wint_t c, struct cons_pointer tail) -{ - return make_string_like_thing(c, tail, SYMBOLTAG); +struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) { + return make_string_like_thing( c, tail, SYMBOLTAG ); } /** * Construct a cell which points to an executable Lisp special form. */ struct cons_pointer -make_special(struct cons_pointer src, struct cons_pointer (*executable) +make_special( struct cons_pointer src, struct cons_pointer ( *executable ) @@ -196,11 +190,10 @@ make_special(struct cons_pointer src, struct cons_pointer (*executable) - (struct cons_pointer s_expr, - struct cons_pointer env, struct stack_frame * frame)) -{ - struct cons_pointer pointer = allocate_cell(SPECIALTAG); - struct cons_space_object *cell = &pointer2cell(pointer); + ( struct cons_pointer s_expr, + struct cons_pointer env, struct stack_frame * frame ) ) { + struct cons_pointer pointer = allocate_cell( SPECIALTAG ); + struct cons_space_object *cell = &pointer2cell( pointer ); cell->payload.special.source = src; cell->payload.special.executable = executable; @@ -211,12 +204,11 @@ make_special(struct cons_pointer src, struct cons_pointer (*executable) /** * 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( char *string ) { struct cons_pointer result = NIL; - for (int i = strlen(string); i > 0; i--) { - result = make_string((wint_t) string[i - 1], result); + for ( int i = strlen( string ); i > 0; i-- ) { + result = make_string( ( wint_t ) string[i - 1], result ); } return result; @@ -225,12 +217,11 @@ struct cons_pointer c_string_to_lisp_string(char *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( char *symbol ) { struct cons_pointer result = NIL; - for (int i = strlen(symbol); i > 0; i--) { - result = make_symbol((wint_t) symbol[i - 1], result); + for ( int i = strlen( symbol ); i > 0; i-- ) { + result = make_symbol( ( wint_t ) symbol[i - 1], result ); } return result; diff --git a/src/consspaceobject.h b/src/consspaceobject.h index ccba8df..3b8c9fa 100644 --- a/src/consspaceobject.h +++ b/src/consspaceobject.h @@ -246,8 +246,8 @@ struct cons_payload { */ struct function_payload { struct cons_pointer source; - struct cons_pointer (*executable) (struct stack_frame *, - struct cons_pointer); + struct cons_pointer ( *executable ) ( struct stack_frame *, + struct cons_pointer ); }; /** @@ -290,9 +290,9 @@ struct real_payload { */ struct special_payload { struct cons_pointer source; - struct cons_pointer (*executable) (struct cons_pointer s_expr, - struct cons_pointer env, - struct stack_frame * frame); + struct cons_pointer ( *executable ) ( struct cons_pointer s_expr, + struct cons_pointer env, + struct stack_frame * frame ); }; /** @@ -393,31 +393,31 @@ struct cons_space_object { /** * Check that the tag on the cell at this pointer is this tag */ -int check_tag(struct cons_pointer pointer, char *tag); +int check_tag( struct cons_pointer pointer, char *tag ); /** * increment the reference count of the object at this cons pointer */ -void inc_ref(struct cons_pointer pointer); +void inc_ref( struct cons_pointer pointer ); /** * decrement the reference count of the object at this cons 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); +void dump_object( FILE * output, struct cons_pointer pointer ); -struct cons_pointer make_cons(struct cons_pointer car, - struct cons_pointer cdr); +struct cons_pointer make_cons( struct cons_pointer car, + struct cons_pointer cdr ); /** * Construct a cell which points to an executable Lisp special form. */ -struct cons_pointer make_function(struct cons_pointer src, - struct cons_pointer (*executable) +struct cons_pointer make_function( struct cons_pointer src, + struct cons_pointer ( *executable ) @@ -426,14 +426,14 @@ struct cons_pointer make_function(struct cons_pointer src, - (struct stack_frame *, - struct cons_pointer)); + ( struct stack_frame *, + struct cons_pointer ) ); /** * Construct a cell which points to an executable Lisp special form. */ -struct cons_pointer make_special(struct cons_pointer src, - struct cons_pointer (*executable) +struct cons_pointer make_special( struct cons_pointer src, + struct cons_pointer ( *executable ) @@ -442,31 +442,31 @@ struct cons_pointer make_special(struct cons_pointer src, - (struct cons_pointer s_expr, - struct cons_pointer env, - struct stack_frame * frame)); + ( struct cons_pointer s_expr, + struct cons_pointer env, + struct stack_frame * frame ) ); /** * Construct a string from this character and this tail. A string is * implemented as a flat list of cells each of which has one character and a * pointer to the next; in the last cell the pointer to next is NIL. */ -struct cons_pointer make_string(wint_t c, struct cons_pointer tail); +struct cons_pointer make_string( wint_t c, struct cons_pointer tail ); /** * Construct a symbol from this character and this tail. A symbol is identical * to a string except for having a different tag. */ -struct cons_pointer make_symbol(wint_t c, struct cons_pointer tail); +struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ); /** * 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( char *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( char *symbol ); #endif diff --git a/src/equal.c b/src/equal.c index 8814ea8..2a20d5e 100644 --- a/src/equal.c +++ b/src/equal.c @@ -18,27 +18,26 @@ * Shallow, and thus cheap, equality: true if these two objects are * the same object, else false. */ -bool eq(struct cons_pointer a, struct cons_pointer b) -{ - return ((a.page == b.page) && (a.offset == b.offset)); +bool eq( struct cons_pointer a, struct cons_pointer b ) { + return ( ( a.page == b.page ) && ( a.offset == b.offset ) ); } /** * Deep, and thus expensive, equality: true if these two objects have * identical structure, else false. */ -bool equal(struct cons_pointer a, struct cons_pointer b) -{ - bool result = eq(a, b); +bool equal( struct cons_pointer a, struct cons_pointer b ) { + bool result = eq( a, b ); - if (!result) { - struct cons_space_object *cell_a = &pointer2cell(a); - struct cons_space_object *cell_b = &pointer2cell(b); + if ( !result ) { + struct cons_space_object *cell_a = &pointer2cell( a ); + struct cons_space_object *cell_b = &pointer2cell( b ); - if (consp(a) && consp(b)) { - 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)) { + if ( consp( a ) && consp( b ) ) { + 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 ) ) { /* * 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 @@ -47,17 +46,18 @@ bool equal(struct cons_pointer a, struct cons_pointer b) result = cell_a->payload.string.character == 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); + && 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 ); /* * not more different than one part in a million - close enough */ - result = fabs(num_a - num_b) < (max / 1000000.0); + result = fabs( num_a - num_b ) < ( max / 1000000.0 ); } /* * there's only supposed ever to be one T and one NIL cell, so each diff --git a/src/equal.h b/src/equal.h index 796b983..1f27104 100644 --- a/src/equal.h +++ b/src/equal.h @@ -19,12 +19,12 @@ * Shallow, and thus cheap, equality: true if these two objects are * the same object, else false. */ -bool eq(struct cons_pointer a, struct cons_pointer b); +bool eq( struct cons_pointer a, struct cons_pointer b ); /** * Deep, and thus expensive, equality: true if these two objects have * identical structure, else false. */ -bool equal(struct cons_pointer a, struct cons_pointer b); +bool equal( struct cons_pointer a, struct cons_pointer b ); #endif diff --git a/src/init.c b/src/init.c index 38d03c8..3681e25 100644 --- a/src/init.c +++ b/src/init.c @@ -21,14 +21,13 @@ #include "lispops.h" #include "repl.h" -void bind_function(char *name, struct cons_pointer (*executable) - (struct stack_frame *, struct cons_pointer)) -{ - deep_bind(intern(c_string_to_lisp_symbol(name), oblist), - make_function(NIL, executable)); +void bind_function( char *name, struct cons_pointer ( *executable ) + ( struct stack_frame *, struct cons_pointer ) ) { + deep_bind( intern( c_string_to_lisp_symbol( name ), oblist ), + make_function( NIL, executable ) ); } -void bind_special(char *name, struct cons_pointer (*executable) +void bind_special( char *name, struct cons_pointer ( *executable ) @@ -37,27 +36,25 @@ void bind_special(char *name, struct cons_pointer (*executable) - (struct cons_pointer s_expr, struct cons_pointer env, - struct stack_frame * frame)) -{ - deep_bind(intern(c_string_to_lisp_symbol(name), oblist), - make_special(NIL, executable)); + ( struct cons_pointer s_expr, struct cons_pointer env, + struct stack_frame * frame ) ) { + deep_bind( intern( c_string_to_lisp_symbol( name ), oblist ), + make_special( NIL, executable ) ); } -int main(int argc, char *argv[]) -{ +int main( int argc, char *argv[] ) { /* * attempt to set wide character acceptance on all streams */ - fwide(stdin, 1); - fwide(stdout, 1); - fwide(stderr, 1); + fwide( stdin, 1 ); + fwide( stdout, 1 ); + fwide( stderr, 1 ); int option; bool dump_at_end = false; bool show_prompt = false; - while ((option = getopt(argc, argv, "pd")) != -1) { - switch (option) { + while ( ( option = getopt( argc, argv, "pd" ) ) != -1 ) { + switch ( option ) { case 'd': dump_at_end = true; break; @@ -65,49 +62,50 @@ int main(int argc, char *argv[]) show_prompt = true; break; default: - fprintf(stderr, "Unexpected option %c\n", option); + fprintf( stderr, "Unexpected option %c\n", option ); break; } } - if (show_prompt) { - fprintf(stdout, - "Post scarcity software environment version %s\n\n", VERSION); + if ( show_prompt ) { + fprintf( stdout, + "Post scarcity software environment version %s\n\n", + VERSION ); } - initialise_cons_pages(); + initialise_cons_pages( ); /* * 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); + deep_bind( intern( c_string_to_lisp_string( "nil" ), oblist ), NIL ); + deep_bind( intern( c_string_to_lisp_string( "t" ), oblist ), TRUE ); /* * primitive function operations */ - bind_function("assoc", &lisp_assoc); - bind_function("car", &lisp_car); - bind_function("cdr", &lisp_cdr); - bind_function("cons", &lisp_cons); - bind_function("eq", &lisp_eq); - bind_function("equal", &lisp_equal); - bind_function("read", &lisp_read); - bind_function("print", &lisp_print); + bind_function( "assoc", &lisp_assoc ); + bind_function( "car", &lisp_car ); + bind_function( "cdr", &lisp_cdr ); + bind_function( "cons", &lisp_cons ); + bind_function( "eq", &lisp_eq ); + 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); + bind_special( "apply", &lisp_apply ); + bind_special( "eval", &lisp_eval ); + bind_special( "quote", &lisp_quote ); - repl(stdin, stdout, stderr, show_prompt); + repl( stdin, stdout, stderr, show_prompt ); // print( stdout, lisp_eval( input, oblist, NULL)); - if (dump_at_end) { - dump_pages(stderr); + if ( dump_at_end ) { + dump_pages( stderr ); } - return (0); + return ( 0 ); } diff --git a/src/integer.c b/src/integer.c index b15541a..ad128ee 100644 --- a/src/integer.c +++ b/src/integer.c @@ -9,6 +9,7 @@ #define _GNU_SOURCE #include +#include #include "conspage.h" #include "consspaceobject.h" @@ -19,14 +20,13 @@ * as a cons-space object. Cell may in principle be any kind of number, * but only integers and reals are so far implemented. */ -double numeric_value(struct cons_pointer pointer) -{ +double numeric_value( struct cons_pointer pointer ) { double result = NAN; - struct cons_space_object *cell = &pointer2cell(pointer); + struct cons_space_object *cell = &pointer2cell( pointer ); - if (integerp(pointer)) { - result = (double) cell->payload.integer.value; - } else if (realp(pointer)) { + if ( integerp( pointer ) ) { + result = cell->payload.integer.value * 1.0; + } else if ( realp( pointer ) ) { result = cell->payload.real.value; } @@ -36,11 +36,12 @@ double numeric_value(struct cons_pointer pointer) /** * Allocate an integer cell representing this value and return a cons pointer to it. */ -struct cons_pointer make_integer(int value) -{ - struct cons_pointer result = allocate_cell(INTEGERTAG); - struct cons_space_object *cell = &pointer2cell(result); +struct cons_pointer make_integer( long int value ) { + struct cons_pointer result = allocate_cell( INTEGERTAG ); + struct cons_space_object *cell = &pointer2cell( result ); cell->payload.integer.value = value; + dump_object( stderr, result); + return result; } diff --git a/src/integer.h b/src/integer.h index a8cb101..e3e8c3b 100644 --- a/src/integer.h +++ b/src/integer.h @@ -11,11 +11,11 @@ #ifndef __integer_h #define __integer_h -double numeric_value(struct cons_pointer pointer); +double numeric_value( struct cons_pointer pointer ); /** * Allocate an integer cell representing this value and return a cons pointer to it. */ -struct cons_pointer make_integer(int value); +struct cons_pointer make_integer( long int value ); #endif diff --git a/src/intern.c b/src/intern.c index b71a4d1..31b7e2e 100644 --- a/src/intern.c +++ b/src/intern.c @@ -44,17 +44,16 @@ struct cons_pointer oblist = NIL; * will work); otherwise return NIL. */ struct cons_pointer -internedp(struct cons_pointer key, struct cons_pointer store) -{ +internedp( struct cons_pointer key, struct cons_pointer store ) { struct cons_pointer result = NIL; - for (struct cons_pointer next = store; - nilp(result) && consp(next); - next = pointer2cell(next).payload.cons.cdr) { + for ( struct cons_pointer next = store; + nilp( result ) && consp( next ); + next = pointer2cell( next ).payload.cons.cdr ) { struct cons_space_object entry = - pointer2cell(pointer2cell(next).payload.cons.car); + pointer2cell( pointer2cell( next ).payload.cons.car ); - if (equal(key, entry.payload.cons.car)) { + if ( equal( key, entry.payload.cons.car ) ) { result = entry.payload.cons.car; } } @@ -70,16 +69,16 @@ internedp(struct cons_pointer key, struct cons_pointer store) * If this key is lexically identical to a key in this store, return the value * of that key from the store; otherwise return NIL. */ -struct cons_pointer c_assoc(struct cons_pointer key, struct cons_pointer store) -{ +struct cons_pointer c_assoc( struct cons_pointer key, + struct cons_pointer store ) { struct cons_pointer result = NIL; - for (struct cons_pointer next = store; - consp(next); next = pointer2cell(next).payload.cons.cdr) { + for ( struct cons_pointer next = store; + consp( next ); next = pointer2cell( next ).payload.cons.cdr ) { struct cons_space_object entry = - pointer2cell(pointer2cell(next).payload.cons.car); + pointer2cell( pointer2cell( next ).payload.cons.car ); - if (equal(key, entry.payload.cons.car)) { + if ( equal( key, entry.payload.cons.car ) ) { result = entry.payload.cons.cdr; break; } @@ -93,10 +92,9 @@ struct cons_pointer c_assoc(struct cons_pointer key, struct cons_pointer store) * with this key/value pair added to the front. */ struct cons_pointer -bind(struct cons_pointer key, struct cons_pointer value, - struct cons_pointer store) -{ - return make_cons(make_cons(key, value), store); +bind( struct cons_pointer key, struct cons_pointer value, + struct cons_pointer store ) { + return make_cons( make_cons( key, value ), store ); } /** @@ -105,9 +103,8 @@ bind(struct cons_pointer key, struct cons_pointer value, * there it may not be especially useful). */ struct cons_pointer -deep_bind(struct cons_pointer key, struct cons_pointer value) -{ - oblist = bind(key, value, oblist); +deep_bind( struct cons_pointer key, struct cons_pointer value ) { + oblist = bind( key, value, oblist ); return oblist; } @@ -117,16 +114,15 @@ deep_bind(struct cons_pointer key, struct cons_pointer value) * with the value NIL. */ struct cons_pointer -intern(struct cons_pointer key, struct cons_pointer environment) -{ +intern( struct cons_pointer key, struct cons_pointer environment ) { struct cons_pointer result = environment; - struct cons_pointer canonical = internedp(key, environment); + struct cons_pointer canonical = internedp( key, environment ); - if (nilp(canonical)) { + if ( nilp( canonical ) ) { /* * not currently bound */ - result = bind(key, NIL, environment); + result = bind( key, NIL, environment ); } return result; diff --git a/src/intern.h b/src/intern.h index 98cc001..e940daa 100644 --- a/src/intern.h +++ b/src/intern.h @@ -27,37 +27,38 @@ extern struct cons_pointer oblist; * implementation a store is just an assoc list, but in future it might be a * namespace, a regularity or a homogeneity. */ -struct cons_pointer c_assoc(struct cons_pointer key, - struct cons_pointer store); +struct cons_pointer c_assoc( struct cons_pointer key, + struct cons_pointer store ); /** * Return true if this key is present as a key in this enviroment, defaulting to * the oblist if no environment is passed. */ -struct cons_pointer internedp(struct cons_pointer key, - struct cons_pointer environment); +struct cons_pointer internedp( struct cons_pointer key, + struct cons_pointer environment ); /** * 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 bind(struct cons_pointer key, - struct cons_pointer value, struct cons_pointer store); +struct cons_pointer bind( struct cons_pointer key, + struct cons_pointer value, + struct cons_pointer store ); /** * Binds this key to this value in the global oblist, but doesn't affect the * current environment. May not be useful except in bootstrapping (and even * there it may not be especially useful). */ -struct cons_pointer deep_bind(struct cons_pointer key, - struct cons_pointer value); +struct cons_pointer deep_bind( struct cons_pointer key, + struct cons_pointer value ); /** * Ensure that a canonical copy of this key is bound in this environment, and * return that canonical copy. If there is currently no such binding, create one * with the value NIL. */ -struct cons_pointer intern(struct cons_pointer key, - struct cons_pointer environment); +struct cons_pointer intern( struct cons_pointer key, + struct cons_pointer environment ); #endif diff --git a/src/lispops.c b/src/lispops.c index 9748797..85ec7eb 100644 --- a/src/lispops.c +++ b/src/lispops.c @@ -49,12 +49,11 @@ /** * Implementation of car in C. If arg is not a cons, does not error but returns nil. */ -struct cons_pointer c_car(struct cons_pointer arg) -{ +struct cons_pointer c_car( struct cons_pointer arg ) { struct cons_pointer result = NIL; - if (consp(arg)) { - result = pointer2cell(arg).payload.cons.car; + if ( consp( arg ) ) { + result = pointer2cell( arg ).payload.cons.car; } return result; @@ -63,12 +62,11 @@ struct cons_pointer c_car(struct cons_pointer arg) /** * Implementation of cdr in C. If arg is not a cons, does not error but returns nil. */ -struct cons_pointer c_cdr(struct cons_pointer arg) -{ +struct cons_pointer c_cdr( struct cons_pointer arg ) { struct cons_pointer result = NIL; - if (consp(arg)) { - result = pointer2cell(arg).payload.cons.cdr; + if ( consp( arg ) ) { + result = pointer2cell( arg ).payload.cons.cdr; } return result; @@ -81,33 +79,33 @@ struct cons_pointer c_cdr(struct cons_pointer arg) * and if so how it differs from eval. */ struct cons_pointer -lisp_apply(struct cons_pointer args, struct cons_pointer env, - struct stack_frame *frame) -{ +lisp_apply( struct cons_pointer args, struct cons_pointer env, + struct stack_frame *frame ) { struct cons_pointer result = args; - if (consp(args)) { - lisp_eval(args, env, frame); + if ( consp( args ) ) { + lisp_eval( args, env, frame ); } return result; } struct cons_pointer -eval_cons(struct cons_pointer s_expr, struct cons_pointer env, - struct stack_frame *my_frame) -{ +eval_cons( struct cons_pointer s_expr, struct cons_pointer env, + struct stack_frame *my_frame ) { struct cons_pointer result = NIL; - struct cons_pointer fn_pointer = lisp_eval(c_car(s_expr), env, my_frame); - struct cons_space_object fn_cell = pointer2cell(fn_pointer); - struct cons_pointer args = c_cdr(s_expr); + struct cons_pointer fn_pointer = + lisp_eval( c_car( s_expr ), env, my_frame ); + struct cons_space_object fn_cell = pointer2cell( fn_pointer ); + struct cons_pointer args = c_cdr( s_expr ); - switch (fn_cell.tag.value) { + switch ( fn_cell.tag.value ) { case SPECIALTV: { - struct cons_space_object special = pointer2cell(fn_pointer); + 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; @@ -116,30 +114,31 @@ eval_cons(struct cons_pointer s_expr, struct cons_pointer env, * actually, this is apply */ { - struct cons_space_object function = pointer2cell(fn_pointer); - struct stack_frame *frame = make_stack_frame(my_frame, args, env); + struct cons_space_object function = pointer2cell( fn_pointer ); + struct stack_frame *frame = + make_stack_frame( my_frame, args, env ); /* * the trick: pass the remaining arguments and environment to the * executable code which is the payload of the function object. */ - result = (*function.payload.function.executable) (frame, env); - free_stack_frame(frame); + result = ( *function.payload.function.executable ) ( frame, env ); + free_stack_frame( frame ); } break; default: { - char *buffer = malloc(1024); - memset(buffer, '\0', 1024); - sprintf(buffer, - "Unexpected cell with tag %d (%c%c%c%c) in function position", - fn_cell.tag.value, fn_cell.tag.bytes[0], - fn_cell.tag.bytes[1], fn_cell.tag.bytes[2], - fn_cell.tag.bytes[3]); - struct cons_pointer message = c_string_to_lisp_string(buffer); - free(buffer); - result = lisp_throw(message, my_frame); + char *buffer = malloc( 1024 ); + memset( buffer, '\0', 1024 ); + sprintf( buffer, + "Unexpected cell with tag %d (%c%c%c%c) in function position", + fn_cell.tag.value, fn_cell.tag.bytes[0], + fn_cell.tag.bytes[1], fn_cell.tag.bytes[2], + fn_cell.tag.bytes[3] ); + struct cons_pointer message = c_string_to_lisp_string( buffer ); + free( buffer ); + result = lisp_throw( message, my_frame ); } } @@ -160,29 +159,32 @@ eval_cons(struct cons_pointer s_expr, struct cons_pointer env, * If a special form, passes the cdr of s_expr to the special form as argument. */ struct cons_pointer -lisp_eval(struct cons_pointer s_expr, struct cons_pointer env, - struct stack_frame *previous) -{ +lisp_eval( struct cons_pointer s_expr, struct cons_pointer env, + struct stack_frame *previous ) { struct cons_pointer result = s_expr; - struct cons_space_object cell = pointer2cell(s_expr); - struct stack_frame *my_frame = - make_stack_frame(previous, make_cons(s_expr, NIL), env); + struct cons_space_object cell = pointer2cell( s_expr ); - switch (cell.tag.value) { + 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: - result = eval_cons(s_expr, env, my_frame); + result = eval_cons( s_expr, env, frame ); break; case SYMBOLTV: { - struct cons_pointer canonical = internedp(s_expr, env); - if (nilp(canonical)) { + struct cons_pointer canonical = internedp( s_expr, env ); + if ( nilp( canonical ) ) { struct cons_pointer message = c_string_to_lisp_string - ("Attempt to take value of unbound symbol."); - result = lisp_throw(message, my_frame); + ( "Attempt to take value of unbound symbol." ); + result = lisp_throw( message, frame ); } else { - result = c_assoc(canonical, env); + result = c_assoc( canonical, env ); } } break; @@ -195,7 +197,7 @@ lisp_eval(struct cons_pointer s_expr, struct cons_pointer env, */ } - free_stack_frame(my_frame); + free_stack_frame( frame ); return result; } @@ -208,10 +210,9 @@ lisp_eval(struct cons_pointer s_expr, struct cons_pointer env, * this isn't at this stage checked) unevaluated. */ struct cons_pointer -lisp_quote(struct cons_pointer args, struct cons_pointer env, - struct stack_frame *frame) -{ - return c_car(args); +lisp_quote( struct cons_pointer args, struct cons_pointer env, + struct stack_frame *frame ) { + return c_car( args ); } /** @@ -223,19 +224,19 @@ lisp_quote(struct cons_pointer args, struct cons_pointer env, * otherwise returns a new cons cell. */ struct cons_pointer -lisp_cons(struct stack_frame *frame, struct cons_pointer env) -{ +lisp_cons( struct stack_frame *frame, struct cons_pointer env ) { struct cons_pointer car = frame->arg[0]; struct cons_pointer cdr = frame->arg[1]; struct cons_pointer result; - if (nilp(car) && nilp(cdr)) { + if ( nilp( car ) && nilp( cdr ) ) { return NIL; - } else if (stringp(car) && stringp(cdr) && - nilp(pointer2cell(car).payload.string.cdr)) { - result = make_string(pointer2cell(car).payload.string.character, cdr); + } else if ( stringp( car ) && stringp( cdr ) && + nilp( pointer2cell( car ).payload.string.cdr ) ) { + result = + make_string( pointer2cell( car ).payload.string.character, cdr ); } else { - result = make_cons(car, cdr); + result = make_cons( car, cdr ); } return result; @@ -247,20 +248,20 @@ lisp_cons(struct stack_frame *frame, struct cons_pointer env) * strings, and TODO read streams and other things which can be considered as sequences. */ struct cons_pointer -lisp_car(struct stack_frame *frame, struct cons_pointer env) -{ +lisp_car( struct stack_frame *frame, struct cons_pointer env ) { struct cons_pointer result = NIL; - if (consp(frame->arg[0])) { - struct cons_space_object cell = pointer2cell(frame->arg[0]); + if ( consp( frame->arg[0] ) ) { + struct cons_space_object cell = pointer2cell( frame->arg[0] ); result = cell.payload.cons.car; - } else if (stringp(frame->arg[0])) { - struct cons_space_object cell = pointer2cell(frame->arg[0]); - result = make_string(cell.payload.string.character, NIL); + } else if ( stringp( frame->arg[0] ) ) { + struct cons_space_object cell = pointer2cell( frame->arg[0] ); + result = make_string( cell.payload.string.character, NIL ); } else { struct cons_pointer message = - c_string_to_lisp_string("Attempt to take CAR/CDR of non sequence"); - result = lisp_throw(message, frame); + c_string_to_lisp_string + ( "Attempt to take CAR/CDR of non sequence" ); + result = lisp_throw( message, frame ); } return result; @@ -272,20 +273,20 @@ lisp_car(struct stack_frame *frame, struct cons_pointer env) * strings, and TODO read streams and other things which can be considered as sequences. */ struct cons_pointer -lisp_cdr(struct stack_frame *frame, struct cons_pointer env) -{ +lisp_cdr( struct stack_frame *frame, struct cons_pointer env ) { struct cons_pointer result = NIL; - if (consp(frame->arg[0])) { - struct cons_space_object cell = pointer2cell(frame->arg[0]); + if ( consp( frame->arg[0] ) ) { + struct cons_space_object cell = pointer2cell( frame->arg[0] ); result = cell.payload.cons.car; - } else if (stringp(frame->arg[0])) { - struct cons_space_object cell = pointer2cell(frame->arg[0]); + } else if ( stringp( frame->arg[0] ) ) { + struct cons_space_object cell = pointer2cell( frame->arg[0] ); result = cell.payload.string.cdr; } else { struct cons_pointer message = - c_string_to_lisp_string("Attempt to take CAR/CDR of non sequence"); - result = lisp_throw(message, frame); + c_string_to_lisp_string + ( "Attempt to take CAR/CDR of non sequence" ); + result = lisp_throw( message, frame ); } return result; @@ -296,18 +297,17 @@ lisp_cdr(struct stack_frame *frame, struct cons_pointer env) * Returns the value associated with key in store, or NIL if not found. */ struct cons_pointer -lisp_assoc(struct stack_frame *frame, struct cons_pointer env) -{ - return c_assoc(frame->arg[0], frame->arg[1]); +lisp_assoc( struct stack_frame *frame, struct cons_pointer env ) { + return c_assoc( frame->arg[0], frame->arg[1] ); } /** * (eq a b) * Returns T if a and b are pointers to the same object, else NIL */ -struct cons_pointer lisp_eq(struct stack_frame *frame, struct cons_pointer env) -{ - return eq(frame->arg[0], frame->arg[1]) ? TRUE : NIL; +struct cons_pointer lisp_eq( struct stack_frame *frame, + struct cons_pointer env ) { + return eq( frame->arg[0], frame->arg[1] ) ? TRUE : NIL; } /** @@ -315,9 +315,8 @@ struct cons_pointer lisp_eq(struct stack_frame *frame, struct cons_pointer env) * Returns T if a and b are pointers to structurally identical objects, else NIL */ struct cons_pointer -lisp_equal(struct stack_frame *frame, struct cons_pointer env) -{ - return equal(frame->arg[0], frame->arg[1]) ? TRUE : NIL; +lisp_equal( struct stack_frame *frame, struct cons_pointer env ) { + return equal( frame->arg[0], frame->arg[1] ) ? TRUE : NIL; } /** @@ -327,15 +326,14 @@ lisp_equal(struct stack_frame *frame, struct cons_pointer env) * is a read stream, then read from that stream, else stdin. */ struct cons_pointer -lisp_read(struct stack_frame *frame, struct cons_pointer env) -{ +lisp_read( struct stack_frame *frame, struct cons_pointer env ) { FILE *input = stdin; - if (readp(frame->arg[0])) { - input = pointer2cell(frame->arg[0]).payload.stream.stream; + if ( readp( frame->arg[0] ) ) { + input = pointer2cell( frame->arg[0] ).payload.stream.stream; } - return read(input); + return read( input ); } /** @@ -345,15 +343,14 @@ lisp_read(struct stack_frame *frame, struct cons_pointer env) * is a write stream, then print to that stream, else stdout. */ struct cons_pointer -lisp_print(struct stack_frame *frame, struct cons_pointer env) -{ +lisp_print( struct stack_frame *frame, struct cons_pointer env ) { FILE *output = stdout; - if (writep(frame->arg[1])) { - output = pointer2cell(frame->arg[1]).payload.stream.stream; + if ( writep( frame->arg[1] ) ) { + output = pointer2cell( frame->arg[1] ).payload.stream.stream; } - print(output, frame->arg[0]); + print( output, frame->arg[0] ); return NIL; } @@ -362,12 +359,11 @@ lisp_print(struct stack_frame *frame, struct cons_pointer env) * TODO: make this do something sensible somehow. */ struct cons_pointer -lisp_throw(struct cons_pointer message, struct stack_frame *frame) -{ - fprintf(stderr, "\nERROR: "); - print(stderr, message); - fprintf(stderr, - "\n\nAn exception was thrown and I've no idea what to do now\n"); +lisp_throw( struct cons_pointer message, struct stack_frame *frame ) { + fprintf( stderr, "\nERROR: " ); + print( stderr, message ); + fprintf( stderr, + "\n\nAn exception was thrown and I've no idea what to do now\n" ); - exit(1); + exit( 1 ); } diff --git a/src/lispops.h b/src/lispops.h index de04134..f3e5200 100644 --- a/src/lispops.h +++ b/src/lispops.h @@ -22,38 +22,38 @@ /* * special forms */ -struct cons_pointer lisp_eval(struct cons_pointer args, - struct cons_pointer env, - struct stack_frame *frame); -struct cons_pointer lisp_apply(struct cons_pointer args, +struct cons_pointer lisp_eval( struct cons_pointer args, struct cons_pointer env, - struct stack_frame *frame); -struct cons_pointer lisp_quote(struct cons_pointer args, - struct cons_pointer env, - struct stack_frame *frame); + struct stack_frame *frame ); +struct cons_pointer lisp_apply( struct cons_pointer args, + struct cons_pointer env, + struct stack_frame *frame ); +struct cons_pointer lisp_quote( struct cons_pointer args, + struct cons_pointer env, + struct stack_frame *frame ); /* * functions */ -struct cons_pointer lisp_cons(struct stack_frame *frame, - struct cons_pointer env); -struct cons_pointer lisp_car(struct stack_frame *frame, - struct cons_pointer env); -struct cons_pointer lisp_cdr(struct stack_frame *frame, - struct cons_pointer env); -struct cons_pointer lisp_assoc(struct stack_frame *frame, - struct cons_pointer env); -struct cons_pointer lisp_eq(struct stack_frame *frame, - struct cons_pointer env); -struct cons_pointer lisp_equal(struct stack_frame *frame, - struct cons_pointer env); -struct cons_pointer lisp_read(struct stack_frame *frame, - struct cons_pointer env); -struct cons_pointer lisp_print(struct stack_frame *frame, - struct cons_pointer env); +struct cons_pointer lisp_cons( struct stack_frame *frame, + struct cons_pointer env ); +struct cons_pointer lisp_car( struct stack_frame *frame, + struct cons_pointer env ); +struct cons_pointer lisp_cdr( struct stack_frame *frame, + struct cons_pointer env ); +struct cons_pointer lisp_assoc( struct stack_frame *frame, + struct cons_pointer env ); +struct cons_pointer lisp_eq( struct stack_frame *frame, + struct cons_pointer env ); +struct cons_pointer lisp_equal( struct stack_frame *frame, + struct cons_pointer env ); +struct cons_pointer lisp_read( struct stack_frame *frame, + struct cons_pointer env ); +struct cons_pointer lisp_print( struct stack_frame *frame, + struct cons_pointer env ); /* * neither, at this stage, really */ -struct cons_pointer lisp_throw(struct cons_pointer message, - struct stack_frame *frame); +struct cons_pointer lisp_throw( struct cons_pointer message, + struct stack_frame *frame ); diff --git a/src/print.c b/src/print.c index f7c3ba3..abe7dda 100644 --- a/src/print.c +++ b/src/print.c @@ -22,94 +22,89 @@ #include "integer.h" #include "print.h" -void print_string_contents(FILE * output, struct cons_pointer pointer) -{ - if (stringp(pointer) || symbolp(pointer)) { - struct cons_space_object *cell = &pointer2cell(pointer); +void print_string_contents( FILE * output, struct cons_pointer pointer ) { + if ( stringp( pointer ) || symbolp( pointer ) ) { + struct cons_space_object *cell = &pointer2cell( pointer ); wint_t c = cell->payload.string.character; - if (c != '\0') { - fputwc(c, output); + if ( c != '\0' ) { + fputwc( c, output ); } - print_string_contents(output, cell->payload.string.cdr); + print_string_contents( output, cell->payload.string.cdr ); } } -void print_string(FILE * output, struct cons_pointer pointer) -{ - fputwc(btowc('"'), output); - print_string_contents(output, pointer); - fputwc(btowc('"'), output); +void print_string( FILE * output, struct cons_pointer pointer ) { + fputwc( btowc( '"' ), output ); + print_string_contents( output, pointer ); + fputwc( btowc( '"' ), output ); } /** * Print a single list cell (cons cell). TODO: does not handle dotted pairs. */ void -print_list_contents(FILE * output, struct cons_pointer pointer, - bool initial_space) -{ - struct cons_space_object *cell = &pointer2cell(pointer); +print_list_contents( FILE * output, struct cons_pointer pointer, + bool initial_space ) { + struct cons_space_object *cell = &pointer2cell( pointer ); - switch (cell->tag.value) { + switch ( cell->tag.value ) { case CONSTV: - if (initial_space) { - fputwc(btowc(' '), output); + if ( initial_space ) { + fputwc( btowc( ' ' ), output ); } - print(output, cell->payload.cons.car); + print( output, cell->payload.cons.car ); - print_list_contents(output, cell->payload.cons.cdr, true); + print_list_contents( output, cell->payload.cons.cdr, true ); break; case NILTV: break; default: - fwprintf(output, L" . "); - print(output, pointer); + fwprintf( output, L" . " ); + print( output, pointer ); } } -void print_list(FILE * output, struct cons_pointer pointer) -{ - fputwc(btowc('('), output); - print_list_contents(output, pointer, false); - fputwc(btowc(')'), output); +void print_list( FILE * output, struct cons_pointer pointer ) { + fputwc( btowc( '(' ), output ); + print_list_contents( output, pointer, false ); + fputwc( btowc( ')' ), output ); } -void print(FILE * output, struct cons_pointer pointer) -{ - struct cons_space_object cell = pointer2cell(pointer); +void print( FILE * output, struct cons_pointer pointer ) { + struct cons_space_object cell = pointer2cell( pointer ); /* * Because tags have values as well as bytes, this if ... else if * statement can ultimately be replaced by a switch, which will be neater. */ - switch (cell.tag.value) { + switch ( cell.tag.value ) { case CONSTV: - print_list(output, pointer); + print_list( output, pointer ); break; case INTEGERTV: - fwprintf(output, L"%ld", cell.payload.integer.value); + fwprintf( output, L"%ld", cell.payload.integer.value ); break; case NILTV: - fwprintf(output, L"nil"); + fwprintf( output, L"nil" ); break; case REALTV: - fwprintf(output, L"%lf", cell.payload.real.value); + fwprintf( output, L"%lf", cell.payload.real.value ); break; case STRINGTV: - print_string(output, pointer); + print_string( output, pointer ); break; case SYMBOLTV: - print_string_contents(output, pointer); + print_string_contents( output, pointer ); break; case TRUETV: - fwprintf(output, L"t"); + fwprintf( output, L"t" ); break; default: - fwprintf(stderr, - L"Error: Unrecognised tag value %d (%c%c%c%c)\n", - cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1], - cell.tag.bytes[2], cell.tag.bytes[3]); + fwprintf( stderr, + L"Error: Unrecognised tag value %d (%c%c%c%c)\n", + cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1], + cell.tag.bytes[2], cell.tag.bytes[3] ); break; } } diff --git a/src/print.h b/src/print.h index 6f5bf85..a3fb4ab 100644 --- a/src/print.h +++ b/src/print.h @@ -14,6 +14,6 @@ #ifndef __print_h #define __print_h -void print(FILE * output, struct cons_pointer pointer); +void print( FILE * output, struct cons_pointer pointer ); #endif diff --git a/src/read.c b/src/read.c index 240816e..26e0b9d 100644 --- a/src/read.c +++ b/src/read.c @@ -12,7 +12,7 @@ #include #include /* - * wide characters + * wide characters */ #include #include @@ -26,20 +26,20 @@ /* * for the time being things which may be read are: strings numbers - either * integer or real, but not yet including ratios or bignums lists Can't read - * 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(FILE * input, wint_t initial); -struct cons_pointer read_list(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_number( FILE * input, wint_t initial ); +struct cons_pointer read_list( 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 ); /** * quote reader macro in C (!) */ -struct cons_pointer c_quote(struct cons_pointer arg) -{ - return make_cons(c_string_to_lisp_symbol("quote"), make_cons(arg, NIL)); +struct cons_pointer c_quote( struct cons_pointer arg ) { + return make_cons( c_string_to_lisp_symbol( "quote" ), + make_cons( arg, NIL ) ); } /** @@ -47,32 +47,31 @@ struct cons_pointer c_quote(struct cons_pointer arg) * treating this initial character as the first character of the object * representation. */ -struct cons_pointer read_continuation(FILE * input, wint_t initial) -{ +struct cons_pointer read_continuation( FILE * input, wint_t initial ) { struct cons_pointer result = NIL; wint_t c; - for (c = initial; - c == '\0' || iswblank(c) || iswcntrl(c); c = fgetwc(input)); + for ( c = initial; + c == '\0' || iswblank( c ) || iswcntrl( c ); c = fgetwc( input ) ); - switch (c) { + switch ( c ) { case '\'': - result = c_quote(read_continuation(input, fgetwc(input))); + result = c_quote( read_continuation( input, fgetwc( input ) ) ); break; case '(': - result = read_list(input, fgetwc(input)); + result = read_list( input, fgetwc( input ) ); break; case '"': - result = read_string(input, fgetwc(input)); + result = read_string( input, fgetwc( input ) ); break; default: - if (iswdigit(c)) { - result = read_number(input, c); - } else if (iswprint(c)) { - result = read_symbol(input, c); + if ( iswdigit( c ) ) { + result = read_number( input, c ); + } else if ( iswprint( c ) ) { + result = read_symbol( input, c ); } else { - fprintf(stderr, "Unrecognised start of input character %c\n", c); + fprintf( stderr, "Unrecognised start of input character %c\n", c ); } } @@ -82,36 +81,38 @@ struct cons_pointer read_continuation(FILE * input, wint_t initial) /** * read a number from this input stream, given this initial character. */ -struct cons_pointer read_number(FILE * input, wint_t initial) -{ - int accumulator = 0; +struct cons_pointer read_number( FILE * input, wint_t initial ) { + long int accumulator = 0; int places_of_decimals = 0; bool seen_period = false; wint_t c; - fprintf(stderr, "read_number starting '%c' (%d)\n", initial, initial); + fprintf( stderr, "read_number starting '%c' (%d)\n", initial, initial ); - for (c = initial; iswdigit(c) || c == btowc('.'); c = fgetwc(input)) { - if (c == btowc('.')) { + for ( c = initial; iswdigit( c ) || c == btowc( '.' ); + c = fgetwc( input ) ) { + if ( c == btowc( '.' ) ) { seen_period = true; } else { - accumulator = accumulator * 10 + ((int) c - (int) '0'); + accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' ); - if (seen_period) { + fprintf( stderr, "Added character %c, accumulator now %ld\n", c, accumulator); + + if ( seen_period ) { places_of_decimals++; } } } /* - * push back the character read which was not a digit + * push back the character read which was not a digit */ - ungetwc(c, input); + ungetwc( c, input ); - if (seen_period) { - return make_real(accumulator / pow(10, places_of_decimals)); + if ( seen_period ) { + return make_real( accumulator / pow( 10, places_of_decimals ) ); } else { - return make_integer(accumulator); + return make_integer( accumulator ); } } @@ -119,86 +120,85 @@ struct cons_pointer read_number(FILE * input, wint_t initial) * Read a list from this input stream, which no longer contains the opening * left parenthesis. */ -struct cons_pointer read_list(FILE * input, wint_t initial) -{ +struct cons_pointer read_list( FILE * input, wint_t initial ) { struct cons_pointer result = NIL; - if (initial != ')') { - fwprintf(stderr, L"read_list starting '%C' (%d)\n", initial, initial); - struct cons_pointer car = read_continuation(input, initial); - result = make_cons(car, read_list(input, fgetwc(input))); + if ( initial != ')' ) { + fwprintf( stderr, L"read_list starting '%C' (%d)\n", initial, + initial ); + struct cons_pointer car = read_continuation( input, initial ); + result = make_cons( car, read_list( input, fgetwc( input ) ) ); } else { - fprintf(stderr, "End of list detected\n"); + fprintf( stderr, "End of list detected\n" ); } return result; } -/** - * Read a string. This means either a string delimited by double quotes +/** + * Read a string. This means either a string delimited by double quotes * (is_quoted == true), in which case it may contain whitespace but may * not contain a double quote character (unless escaped), or one not * so delimited in which case it may not contain whitespace (unless escaped) * but may contain a double quote character (probably not a good idea!) */ -struct cons_pointer read_string(FILE * input, wint_t initial) -{ +struct cons_pointer read_string( FILE * input, wint_t initial ) { struct cons_pointer cdr = NIL; struct cons_pointer result; - fwprintf(stderr, L"read_string starting '%C' (%d)\n", initial, initial); + fwprintf( stderr, L"read_string starting '%C' (%d)\n", initial, initial ); - switch (initial) { + switch ( initial ) { case '\0': - result = make_string(initial, NIL); + result = make_string( initial, NIL ); break; case '"': - result = make_string('\0', NIL); + result = make_string( '\0', NIL ); break; default: - result = make_string(initial, read_string(input, fgetwc(input))); + result = make_string( initial, read_string( input, fgetwc( input ) ) ); break; } return result; } -struct cons_pointer read_symbol(FILE * input, wint_t initial) -{ +struct cons_pointer read_symbol( FILE * input, wint_t initial ) { struct cons_pointer cdr = NIL; struct cons_pointer result; - fwprintf(stderr, L"read_symbol starting '%C' (%d)\n", initial, initial); + fwprintf( stderr, L"read_symbol starting '%C' (%d)\n", initial, initial ); - switch (initial) { + switch ( initial ) { case '\0': - result = make_symbol(initial, NIL); + result = make_symbol( initial, NIL ); break; case '"': /* - * THIS IS NOT A GOOD IDEA, but is legal + * THIS IS NOT A GOOD IDEA, but is legal */ - result = make_symbol(initial, read_symbol(input, fgetwc(input))); + result = make_symbol( initial, read_symbol( input, fgetwc( input ) ) ); break; case ')': /* - * unquoted strings may not include right-parenthesis + * unquoted strings may not include right-parenthesis */ - result = make_symbol('\0', NIL); + result = make_symbol( '\0', NIL ); /* - * push back the character read + * push back the character read */ - ungetwc(initial, input); + ungetwc( initial, input ); break; default: - if (iswblank(initial) || !iswprint(initial)) { - result = make_symbol('\0', NIL); + if ( iswblank( initial ) || !iswprint( initial ) ) { + result = make_symbol( '\0', NIL ); /* - * push back the character read + * push back the character read */ - ungetwc(initial, input); + ungetwc( initial, input ); } else { - result = make_symbol(initial, read_symbol(input, fgetwc(input))); + result = + make_symbol( initial, read_symbol( input, fgetwc( input ) ) ); } break; } @@ -209,7 +209,6 @@ struct cons_pointer read_symbol(FILE * input, wint_t initial) /** * Read the next object on this input stream and return a cons_pointer to it. */ -struct cons_pointer read(FILE * input) -{ - return read_continuation(input, fgetwc(input)); +struct cons_pointer read( FILE * input ) { + return read_continuation( input, fgetwc( input ) ); } diff --git a/src/read.h b/src/read.h index 123e743..5ed365a 100644 --- a/src/read.h +++ b/src/read.h @@ -14,6 +14,6 @@ /** * read the next object on this input stream and return a cons_pointer to it. */ -struct cons_pointer read(FILE * input); +struct cons_pointer read( FILE * input ); #endif diff --git a/src/real.c b/src/real.c index 0cd6803..5608b86 100644 --- a/src/real.c +++ b/src/real.c @@ -14,10 +14,9 @@ * @param value the value to wrap; * @return a real number cell wrapping this value. */ -struct cons_pointer make_real(long double value) -{ - struct cons_pointer result = allocate_cell(REALTAG); - struct cons_space_object *cell = &pointer2cell(result); +struct cons_pointer make_real( long double value ) { + struct cons_pointer result = allocate_cell( REALTAG ); + struct cons_space_object *cell = &pointer2cell( result ); cell->payload.real.value = value; return result; diff --git a/src/real.h b/src/real.h index 9c0e1b9..7e3601f 100644 --- a/src/real.h +++ b/src/real.h @@ -24,7 +24,7 @@ extern "C" { * @param value the value to wrap; * @return a real number cell wrapping this value. */ - struct cons_pointer make_real(double value); + struct cons_pointer make_real( double value ); #ifdef __cplusplus } diff --git a/src/repl.c b/src/repl.c index d49fad8..959104b 100644 --- a/src/repl.c +++ b/src/repl.c @@ -22,21 +22,22 @@ * @param show_prompt true if prompts should be shown. */ void -repl(FILE * in_stream, FILE * out_stream, FILE * error_stream, - bool show_prompt) -{ - while (!feof(in_stream)) { - if (show_prompt) { - fwprintf(out_stream, L"\n:: "); +repl( FILE * in_stream, FILE * out_stream, FILE * error_stream, + bool show_prompt ) { + while ( !feof( in_stream ) ) { + if ( show_prompt ) { + fwprintf( out_stream, L"\n:: " ); } - struct cons_pointer input = read(in_stream); - fwprintf(error_stream, L"\nread {%d,%d}=> ", input.page, input.offset); - if (show_prompt) { - fwprintf(out_stream, L"\n-> "); + struct cons_pointer input = read( in_stream ); + fwprintf( error_stream, L"\nread {%d,%d}=> ", input.page, + input.offset ); + if ( show_prompt ) { + fwprintf( out_stream, L"\n-> " ); } // 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); + print( out_stream, input ); + fwprintf( out_stream, L"\n" ); + fwprintf( error_stream, L"\neval {%d,%d}=> ", input.page, + input.offset ); } } diff --git a/src/repl.h b/src/repl.h index 55a12d7..1a7b0e9 100644 --- a/src/repl.h +++ b/src/repl.h @@ -25,8 +25,8 @@ extern "C" { * @param err_stream the stream to send errors to; * @param show_prompt true if prompts should be shown. */ - void repl(FILE * in_stream, FILE * out_stream, - FILE * error_stream, bool show_prompt); + void repl( FILE * in_stream, FILE * out_stream, + FILE * error_stream, bool show_prompt ); #ifdef __cplusplus } diff --git a/src/stack.c b/src/stack.c index 049f892..6581b02 100644 --- a/src/stack.c +++ b/src/stack.c @@ -29,14 +29,13 @@ * Allocate a new stack frame with its previous pointer set to this value, * its arguments set up from these args, evaluated in this env. */ -struct stack_frame *make_stack_frame(struct stack_frame *previous, - struct cons_pointer args, - struct cons_pointer env) -{ +struct stack_frame *make_stack_frame( struct stack_frame *previous, + struct cons_pointer args, + struct cons_pointer env ) { /* * TODO: later, pop a frame off a free-list of stack frames */ - struct stack_frame *result = malloc(sizeof(struct stack_frame)); + struct stack_frame *result = malloc( sizeof( struct stack_frame ) ); result->previous = previous; @@ -47,27 +46,27 @@ struct stack_frame *make_stack_frame(struct stack_frame *previous, result->more = NIL; result->function = NIL; - for (int i = 0; i < args_in_frame; i++) { + for ( int i = 0; i < args_in_frame; i++ ) { result->arg[i] = NIL; } int i = 0; /* still an index into args, so same name will * do */ - while (!nilp(args)) { /* iterate down the arg list filling in the + while ( !nilp( args ) ) { /* iterate down the arg list filling in the * arg slots in the frame. When there are no * more slots, if there are still args, stash * them on more */ - struct cons_space_object cell = pointer2cell(args); + struct cons_space_object cell = pointer2cell( args ); - if (i < args_in_frame) { + if ( i < args_in_frame ) { /* * TODO: if we were running on real massively parallel hardware, * each arg except the first should be handed off to another * processor to be evaled in parallel */ - result->arg[i] = lisp_eval(cell.payload.cons.car, env, result); - inc_ref(result->arg[i]); + result->arg[i] = lisp_eval( cell.payload.cons.car, env, result ); + inc_ref( result->arg[i] ); args = cell.payload.cons.cdr; } else { @@ -75,7 +74,7 @@ struct stack_frame *make_stack_frame(struct stack_frame *previous, * TODO: this isn't right. These args should also each be evaled. */ result->more = args; - inc_ref(result->more); + inc_ref( result->more ); args = NIL; } @@ -87,36 +86,34 @@ struct stack_frame *make_stack_frame(struct stack_frame *previous, /** * Free this stack frame. */ -void free_stack_frame(struct stack_frame *frame) -{ +void free_stack_frame( struct stack_frame *frame ) { /* * TODO: later, push it back on the stack-frame freelist */ - for (int i = 0; i < args_in_frame; i++) { - dec_ref(frame->arg[i]); + for ( int i = 0; i < args_in_frame; i++ ) { + dec_ref( frame->arg[i] ); } - dec_ref(frame->more); + dec_ref( frame->more ); - free(frame); + free( frame ); } /** * Fetch a pointer to the value of the local variable at this index. */ -struct cons_pointer fetch_arg(struct stack_frame *frame, unsigned int index) -{ +struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int index ) { struct cons_pointer result = NIL; - if (index < args_in_frame) { + if ( index < args_in_frame ) { result = frame->arg[index]; } else { struct cons_pointer p = frame->more; - for (int i = args_in_frame; i < index; i++) { - p = pointer2cell(p).payload.cons.cdr; + for ( int i = args_in_frame; i < index; i++ ) { + p = pointer2cell( p ).payload.cons.cdr; } - result = pointer2cell(p).payload.cons.car; + result = pointer2cell( p ).payload.cons.car; } return result; diff --git a/src/stack.h b/src/stack.h index 25ce84b..47d97e9 100644 --- a/src/stack.h +++ b/src/stack.h @@ -24,11 +24,11 @@ #ifndef __stack_h #define __stack_h -struct stack_frame *make_stack_frame(struct stack_frame *previous, - struct cons_pointer args, - struct cons_pointer env); -void free_stack_frame(struct stack_frame *frame); -struct cons_pointer fetch_arg(struct stack_frame *frame, unsigned int n); +struct stack_frame *make_stack_frame( struct stack_frame *previous, + struct cons_pointer args, + struct cons_pointer env ); +void free_stack_frame( struct stack_frame *frame ); +struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int n ); /* * struct stack_frame is defined in consspaceobject.h to break circularity From 306f520082cb84906d466cd960db981f1e1ee7e0 Mon Sep 17 00:00:00 2001 From: simon Date: Tue, 12 Sep 2017 22:30:15 +0100 Subject: [PATCH 07/27] 12/12 tests passed! Moving onward... --- src/consspaceobject.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/consspaceobject.c b/src/consspaceobject.c index a75dbd2..19171ad 100644 --- a/src/consspaceobject.c +++ b/src/consspaceobject.c @@ -151,6 +151,8 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) { cell->payload.string.character = c; cell->payload.string.cdr.page = tail.page; cell->payload.string.cdr.offset = tail.offset; + + dump_object( stderr, pointer); } else { fwprintf( stderr, L"Warning: only NIL and %s can be appended to %s\n", From 5dee093e651b4b08fb70add8c58417f3ce03170a Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 13 Sep 2017 00:25:11 +0100 Subject: [PATCH 08/27] All tests still pass and a lot of debugging junk is gone --- src/conspage.c | 2 +- src/consspaceobject.c | 14 +++----------- src/init.c | 11 +---------- src/repl.c | 6 ++++++ unit-tests/integer-allocation.sh | 2 +- unit-tests/string-allocation.sh | 2 +- 6 files changed, 13 insertions(+), 24 deletions(-) diff --git a/src/conspage.c b/src/conspage.c index 3413091..efb9f91 100644 --- a/src/conspage.c +++ b/src/conspage.c @@ -167,7 +167,7 @@ struct cons_pointer allocate_cell( char *tag ) { fprintf( stderr, "Allocated cell of type '%s' at %d, %d \n", tag, result.page, result.offset ); - dump_object( stderr, result ); + // dump_object( stderr, result ); } else { fprintf( stderr, "WARNING: Allocating non-free cell!" ); } diff --git a/src/consspaceobject.c b/src/consspaceobject.c index 19171ad..35b8e5f 100644 --- a/src/consspaceobject.c +++ b/src/consspaceobject.c @@ -91,7 +91,7 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { cell.payload.real.value ); } else if ( check_tag( pointer, STRINGTAG ) ) { fwprintf( output, - L"String cell: character '%1c' (%1d) next at page %2d offset %3d\n", + 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 ); @@ -150,9 +150,9 @@ 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 + * strings are quite massively off. */ cell->payload.string.cdr.offset = tail.offset; - - dump_object( stderr, pointer); } else { fwprintf( stderr, L"Warning: only NIL and %s can be appended to %s\n", @@ -184,14 +184,6 @@ struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) { */ struct cons_pointer make_special( struct cons_pointer src, struct cons_pointer ( *executable ) - - - - - - - - ( struct cons_pointer s_expr, struct cons_pointer env, struct stack_frame * frame ) ) { struct cons_pointer pointer = allocate_cell( SPECIALTAG ); diff --git a/src/init.c b/src/init.c index 3681e25..ff77551 100644 --- a/src/init.c +++ b/src/init.c @@ -28,14 +28,6 @@ void bind_function( char *name, struct cons_pointer ( *executable ) } void bind_special( char *name, struct cons_pointer ( *executable ) - - - - - - - - ( struct cons_pointer s_expr, struct cons_pointer env, struct stack_frame * frame ) ) { deep_bind( intern( c_string_to_lisp_symbol( name ), oblist ), @@ -101,10 +93,9 @@ int main( int argc, char *argv[] ) { bind_special( "quote", &lisp_quote ); repl( stdin, stdout, stderr, show_prompt ); - // print( stdout, lisp_eval( input, oblist, NULL)); if ( dump_at_end ) { - dump_pages( stderr ); + dump_pages( stdout ); } return ( 0 ); diff --git a/src/repl.c b/src/repl.c index 959104b..22c1571 100644 --- a/src/repl.c +++ b/src/repl.c @@ -34,6 +34,12 @@ repl( FILE * in_stream, FILE * out_stream, FILE * error_stream, if ( show_prompt ) { 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. + * 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 ); fwprintf( out_stream, L"\n" ); diff --git a/unit-tests/integer-allocation.sh b/unit-tests/integer-allocation.sh index cc811b8..5d07d90 100644 --- a/unit-tests/integer-allocation.sh +++ b/unit-tests/integer-allocation.sh @@ -2,7 +2,7 @@ value=354 expected="Integer cell: value ${value}" -echo ${value} | target/psse 2>&1 | grep "${expected}" > /dev/null +echo ${value} | target/psse -d 2>&1 | grep "${expected}" > /dev/null if [ $? -eq 0 ] then diff --git a/unit-tests/string-allocation.sh b/unit-tests/string-allocation.sh index 5f503fc..3039897 100644 --- a/unit-tests/string-allocation.sh +++ b/unit-tests/string-allocation.sh @@ -2,7 +2,7 @@ value='"Fred"' expected="String cell: character 'F'" -echo ${value} | target/psse 2>&1 | grep "${expected}" > /dev/null +echo ${value} | target/psse -d 2>&1 | grep "${expected}" > /dev/null if [ $? -eq 0 ] then From 9661ad339a5f75c248700e198859447e2f6c280a Mon Sep 17 00:00:00 2001 From: simon Date: Wed, 13 Sep 2017 12:50:20 +0100 Subject: [PATCH 09/27] 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 ); From 0826dcfdda110a12b6711daf3e2700405931b230 Mon Sep 17 00:00:00 2001 From: simon Date: Wed, 13 Sep 2017 15:58:59 +0100 Subject: [PATCH 10/27] Huge progress. Now actually working. --- src/consspaceobject.h | 16 -------- src/init.c | 35 ++++++++-------- src/integer.c | 2 +- src/integer.h | 2 +- src/intern.c | 4 +- src/intern.h | 2 +- src/lispops.c | 17 +++----- src/peano.c | 50 ++++++++++++++++++++--- src/peano.h | 35 ++++++++++++++++ src/read.c | 16 +++----- src/real.h | 2 +- src/repl.c | 12 ++---- src/stack.c | 82 +++++++++++++++++++++++++++++++++----- src/stack.h | 12 ++++++ unit-tests/complex-list.sh | 2 +- unit-tests/quote.sh | 2 +- unit-tests/quoted-list.sh | 2 +- unit-tests/simple-list.sh | 2 +- 18 files changed, 205 insertions(+), 90 deletions(-) create mode 100644 src/peano.h diff --git a/src/consspaceobject.h b/src/consspaceobject.h index d52a241..4e4dc9c 100644 --- a/src/consspaceobject.h +++ b/src/consspaceobject.h @@ -418,14 +418,6 @@ struct cons_pointer make_cons( struct cons_pointer car, */ struct cons_pointer make_function( struct cons_pointer src, struct cons_pointer ( *executable ) - - - - - - - - ( struct stack_frame *, struct cons_pointer ) ); @@ -434,14 +426,6 @@ struct cons_pointer make_function( struct cons_pointer src, */ struct cons_pointer make_special( struct cons_pointer src, struct cons_pointer ( *executable ) - - - - - - - - ( struct cons_pointer s_expr, struct cons_pointer env, struct stack_frame * frame ) ); diff --git a/src/init.c b/src/init.c index 1a85c22..b85b656 100644 --- a/src/init.c +++ b/src/init.c @@ -19,19 +19,21 @@ #include "consspaceobject.h" #include "intern.h" #include "lispops.h" +#include "peano.h" +#include "print.h" #include "repl.h" void bind_function( char *name, struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer ) ) { - deep_bind( intern( c_string_to_lisp_symbol( name ), oblist ), - make_function( NIL, executable ) ); + deep_bind( c_string_to_lisp_symbol( name ), + make_function( NIL, executable )); } void bind_special( char *name, struct cons_pointer ( *executable ) ( struct cons_pointer s_expr, struct cons_pointer env, struct stack_frame * frame ) ) { - deep_bind( intern( c_string_to_lisp_symbol( name ), oblist ), - make_special( NIL, executable ) ); + deep_bind( c_string_to_lisp_symbol( name ), + make_special( NIL, executable )); } int main( int argc, char *argv[] ) { @@ -70,17 +72,13 @@ 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); + + deep_bind( c_string_to_lisp_symbol( "nil" ), NIL ); + deep_bind( c_string_to_lisp_symbol( "t" ), TRUE ); /* * primitive function operations */ - /* bind_function( "assoc", &lisp_assoc ); bind_function( "car", &lisp_car ); bind_function( "cdr", &lisp_cdr ); @@ -89,19 +87,20 @@ int main( int argc, char *argv[] ) { bind_function( "equal", &lisp_equal ); bind_function( "read", &lisp_read ); bind_function( "print", &lisp_print ); -*/ + + bind_function( "plus", &lisp_plus); + /* * 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); - } + + + /* bind the oblist last, at this stage. Something clever needs to be done + * here and I'm not sure what it is. */ + deep_bind( c_string_to_lisp_symbol( "oblist"), oblist); repl( stdin, stdout, stderr, show_prompt ); diff --git a/src/integer.c b/src/integer.c index fa1327f..390594c 100644 --- a/src/integer.c +++ b/src/integer.c @@ -20,7 +20,7 @@ * as a cons-space object. Cell may in principle be any kind of number, * but only integers and reals are so far implemented. */ -double numeric_value( struct cons_pointer pointer ) { +long double numeric_value( struct cons_pointer pointer ) { double result = NAN; struct cons_space_object *cell = &pointer2cell( pointer ); diff --git a/src/integer.h b/src/integer.h index e3e8c3b..d44f34d 100644 --- a/src/integer.h +++ b/src/integer.h @@ -11,7 +11,7 @@ #ifndef __integer_h #define __integer_h -double numeric_value( struct cons_pointer pointer ); +long double numeric_value( struct cons_pointer pointer ); /** * Allocate an integer cell representing this value and return a cons pointer to it. diff --git a/src/intern.c b/src/intern.c index 8843945..fae0b7a 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 @@ -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 bd1656c..e940daa 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 3e20d52..073455f 100644 --- a/src/lispops.c +++ b/src/lispops.c @@ -102,9 +102,10 @@ eval_cons( struct cons_pointer s_expr, struct cons_pointer env, switch ( fn_cell.tag.value ) { case SPECIALTV: { - struct cons_space_object special = pointer2cell( fn_pointer ); + struct stack_frame *frame = + make_special_frame( my_frame, args, env ); result = - ( *special.payload.special.executable ) ( args, env, my_frame ); + ( *fn_cell.payload.special.executable ) ( args, env, frame ); } break; @@ -121,7 +122,7 @@ eval_cons( struct cons_pointer s_expr, struct cons_pointer env, * the trick: pass the remaining arguments and environment to the * executable code which is the payload of the function object. */ - result = ( *function.payload.function.executable ) ( frame, env ); + result = ( *fn_cell.payload.function.executable ) ( frame, env ); free_stack_frame( frame ); } break; @@ -165,13 +166,7 @@ lisp_eval( struct cons_pointer s_expr, struct cons_pointer env, 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 ); + result = eval_cons( s_expr, env, previous); break; case SYMBOLTV: @@ -181,7 +176,7 @@ lisp_eval( struct cons_pointer s_expr, struct cons_pointer env, struct cons_pointer message = c_string_to_lisp_string ( "Attempt to take value of unbound symbol." ); - result = lisp_throw( message, frame ); + result = lisp_throw( message, previous ); } else { result = c_assoc( canonical, env ); } diff --git a/src/peano.c b/src/peano.c index 67fc8c2..e39a58e 100644 --- a/src/peano.c +++ b/src/peano.c @@ -12,6 +12,7 @@ #include #include #include +#include #include "consspaceobject.h" #include "conspage.h" @@ -21,15 +22,52 @@ #include "lispops.h" #include "print.h" #include "read.h" +#include "real.h" #include "stack.h" -/* +/** + * Add an indefinite number of numbers together + * @param env the evaluation environment - ignored; + * @param frame the stack frame. + * @return a pointer to an integer or real. + */ 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; +lisp_plus(struct stack_frame *frame, struct cons_pointer env) { + struct cons_pointer result = NIL; + long int i_accumulator = 0; + long double d_accumulator = 0; + bool is_int = true; + for (int i = 0; i < args_in_frame && !nilp(frame->arg[i]); i++) { + struct cons_space_object arg = pointer2cell(frame->arg[i]); + + switch (arg.tag.value) { + case INTEGERTV: + i_accumulator += arg.payload.integer.value; + d_accumulator += numeric_value( frame->arg[i]); + break; + case REALTV: + d_accumulator += arg.payload.real.value; + is_int = false; + default: + lisp_throw( + c_string_to_lisp_string("Cannot add: not a number"), + frame); + } + + if (! nilp(frame->more)) { + lisp_throw( + c_string_to_lisp_string("Cannot yet add more than 8 numbers"), + frame); + } + + if ( is_int) { + result = make_integer( i_accumulator); + } else { + result = make_real( d_accumulator); + } + } + return result; } -*/ + diff --git a/src/peano.h b/src/peano.h new file mode 100644 index 0000000..b50f922 --- /dev/null +++ b/src/peano.h @@ -0,0 +1,35 @@ +/** + * peano.h + * + * Basic peano arithmetic + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include "consspaceobject.h" + +#ifndef PEANO_H +#define PEANO_H + +#ifdef __cplusplus +extern "C" { +#endif + +/** + * Add an indefinite number of numbers together + * @param env the evaluation environment - ignored; + * @param frame the stack frame. + * @return a pointer to an integer or real. + */ +struct cons_pointer +lisp_plus(struct stack_frame *frame, struct cons_pointer env); + + + +#ifdef __cplusplus +} +#endif + +#endif /* PEANO_H */ + diff --git a/src/read.c b/src/read.c index 85174ee..f2eeff5 100644 --- a/src/read.c +++ b/src/read.c @@ -147,8 +147,6 @@ struct cons_pointer read_string( FILE * input, wint_t initial ) { struct cons_pointer cdr = NIL; struct cons_pointer result; - fwprintf( stderr, L"read_string starting '%C' (%d)\n", initial, initial ); - switch ( initial ) { case '\0': result = make_string( initial, NIL ); @@ -168,8 +166,6 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) { struct cons_pointer cdr = NIL; struct cons_pointer result; - fwprintf( stderr, L"read_symbol starting '%C' (%d)\n", initial, initial ); - switch ( initial ) { case '\0': result = make_symbol( initial, NIL ); @@ -191,16 +187,16 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) { ungetwc( initial, input ); break; default: - if ( iswblank( initial ) || !iswprint( initial ) ) { - result = make_symbol( '\0', NIL ); + if ( iswalnum( initial ) ) { + result = + make_symbol( initial, read_symbol( input, fgetwc( input ) ) ); + } else { + result = NIL; /* * push back the character read */ ungetwc( initial, input ); - } else { - result = - make_symbol( initial, read_symbol( input, fgetwc( input ) ) ); - } + } break; } diff --git a/src/real.h b/src/real.h index 7e3601f..759a2bb 100644 --- a/src/real.h +++ b/src/real.h @@ -24,7 +24,7 @@ extern "C" { * @param value the value to wrap; * @return a real number cell wrapping this value. */ - struct cons_pointer make_real( double value ); +struct cons_pointer make_real( double value ); #ifdef __cplusplus } diff --git a/src/repl.c b/src/repl.c index acfb73c..2e9fb41 100644 --- a/src/repl.c +++ b/src/repl.c @@ -31,19 +31,13 @@ repl( FILE * in_stream, FILE * out_stream, FILE * error_stream, struct cons_pointer input = read( in_stream ); fwprintf( error_stream, L"\nread {%d,%d}=> ", input.page, input.offset ); - if ( show_prompt ) { - fwprintf( out_stream, L"\n-> " ); - } + print( error_stream, input); - /* 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 ) ); + struct cons_pointer value = 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 ); + print( out_stream, value); } } diff --git a/src/stack.c b/src/stack.c index 6581b02..25e9795 100644 --- a/src/stack.c +++ b/src/stack.c @@ -4,13 +4,13 @@ * The Lisp evaluation stack. * * Stack frames could be implemented in cons space; indeed, the stack - * could simply be an assoc list consed onto the front of the environment. - * But such a stack would be costly to search. The design sketched here, - * with stack frames as special objects, SHOULD be substantially more + * could simply be an assoc list consed onto the front of the environment. + * But such a stack would be costly to search. The design sketched here, + * with stack frames as special objects, SHOULD be substantially more * efficient, but does imply we need to generalise the idea of cons pages * with freelists to a more general 'equal sized object pages', so that * allocating/freeing stack frames can be more efficient. - * + * * Stack frames are not yet a first class object; they have no VECP pointer * in cons space. * @@ -23,6 +23,7 @@ #include "consspaceobject.h" #include "conspage.h" #include "lispops.h" +#include "print.h" #include "stack.h" /** @@ -33,7 +34,7 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous, struct cons_pointer args, struct cons_pointer env ) { /* - * TODO: later, pop a frame off a free-list of stack frames + * TODO: later, pop a frame off a free-list of stack frames */ struct stack_frame *result = malloc( sizeof( struct stack_frame ) ); @@ -41,7 +42,7 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous, /* * clearing the frame with memset would probably be slightly quicker, but - * this is clear. + * this is clear. */ result->more = NIL; result->function = NIL; @@ -50,7 +51,7 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous, result->arg[i] = NIL; } - int i = 0; /* still an index into args, so same name will + int i = 0; /* still an index into args, so same name will * do */ while ( !nilp( args ) ) { /* iterate down the arg list filling in the @@ -60,18 +61,79 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous, struct cons_space_object cell = pointer2cell( args ); if ( i < args_in_frame ) { + fwprintf(stderr, L"Making frame; arg %d: ", i); + print(stderr, cell.payload.cons.car); /* * TODO: if we were running on real massively parallel hardware, * each arg except the first should be handed off to another - * processor to be evaled in parallel + * processor to be evaled in parallel */ result->arg[i] = lisp_eval( cell.payload.cons.car, env, result ); inc_ref( result->arg[i] ); args = cell.payload.cons.cdr; + i++; } else { /* - * TODO: this isn't right. These args should also each be evaled. + * TODO: this isn't right. These args should also each be evaled. + */ + result->more = args; + inc_ref( result->more ); + + args = NIL; + } + } + + return result; +} + +/** + * 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 env ) { + /* + * TODO: later, pop a frame off a free-list of stack frames + */ + struct stack_frame *result = malloc( sizeof( struct stack_frame ) ); + + result->previous = previous; + + /* + * clearing the frame with memset would probably be slightly quicker, but + * this is clear. + */ + result->more = NIL; + result->function = NIL; + + for ( int i = 0; i < args_in_frame; i++ ) { + result->arg[i] = NIL; + } + + int i = 0; /* still an index into args, so same name will + * do */ + + while ( !nilp( args ) ) { /* iterate down the arg list filling in the + * arg slots in the frame. When there are no + * more slots, if there are still args, stash + * them on more */ + struct cons_space_object cell = pointer2cell( args ); + + if ( i < args_in_frame ) { + result->arg[i] = cell.payload.cons.car; + inc_ref( result->arg[i] ); + + args = cell.payload.cons.cdr; + i++; + } else { + /* + * TODO: this isn't right. These args should also each be evaled. */ result->more = args; inc_ref( result->more ); @@ -88,7 +150,7 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous, */ void free_stack_frame( struct stack_frame *frame ) { /* - * TODO: later, push it back on the stack-frame freelist + * TODO: later, push it back on the stack-frame freelist */ for ( int i = 0; i < args_in_frame; i++ ) { dec_ref( frame->arg[i] ); diff --git a/src/stack.h b/src/stack.h index 47d97e9..4eaa9e1 100644 --- a/src/stack.h +++ b/src/stack.h @@ -30,6 +30,18 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous, void free_stack_frame( struct stack_frame *frame ); struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int n ); +/** + * A 'special' frame is exactly like a normal stack frame except that the + * arguments are unevaluated. + * @param previous the previous stack frame; + * @param args a list of the arguments to be stored in this stack frame; + * @param env the execution environment; + * @return a new special frame. + */ +struct stack_frame *make_special_frame( struct stack_frame *previous, + struct cons_pointer args, + struct cons_pointer env ); + /* * struct stack_frame is defined in consspaceobject.h to break circularity * TODO: refactor. diff --git a/unit-tests/complex-list.sh b/unit-tests/complex-list.sh index c4c8e94..70ab629 100644 --- a/unit-tests/complex-list.sh +++ b/unit-tests/complex-list.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='(1 2 3 ("Fred") nil 77354)' -actual=`echo '(1 2 3 ("Fred") () 77354)' | target/psse 2> /dev/null | head -1` +actual=`echo "'(1 2 3 (\"Fred\") () 77354)" | target/psse 2> /dev/null | head -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/quote.sh b/unit-tests/quote.sh index f7bf353..6785966 100644 --- a/unit-tests/quote.sh +++ b/unit-tests/quote.sh @@ -1,6 +1,6 @@ #!/bin/bash -expected='(quote Fred)' +expected='Fred' actual=`echo "'Fred" | target/psse 2> /dev/null | head -1` if [ "${expected}" = "${actual}" ] diff --git a/unit-tests/quoted-list.sh b/unit-tests/quoted-list.sh index 1d18369..6ba50cc 100644 --- a/unit-tests/quoted-list.sh +++ b/unit-tests/quoted-list.sh @@ -1,6 +1,6 @@ #!/bin/bash -expected='(quote (123 (4 (5 nil)) Fred))' +expected='(123 (4 (5 nil)) Fred)' actual=`echo "'(123 (4 (5 ())) Fred)" | target/psse 2> /dev/null | head -1` if [ "${expected}" = "${actual}" ] diff --git a/unit-tests/simple-list.sh b/unit-tests/simple-list.sh index 8d0c758..35ed153 100644 --- a/unit-tests/simple-list.sh +++ b/unit-tests/simple-list.sh @@ -1,7 +1,7 @@ #!/bin/bash expected="(1 2 3)" -actual=`echo '(1 2 3)' | target/psse 2> /dev/null | head -1` +actual=`echo "'(1 2 3)" | target/psse 2> /dev/null | head -1` if [ "${expected}" = "${actual}" ] then From 648a4cd522f0a5420c5ad12a480cda8aeee8f0f0 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 13 Sep 2017 17:00:13 +0100 Subject: [PATCH 11/27] Add and multiply now work, but robustly. --- src/init.c | 3 ++- src/peano.c | 48 +++++++++++++++++++++++++++++++++++++++++++++++- src/peano.h | 10 +++++++++- 3 files changed, 58 insertions(+), 3 deletions(-) diff --git a/src/init.c b/src/init.c index b85b656..d5207f1 100644 --- a/src/init.c +++ b/src/init.c @@ -88,7 +88,8 @@ int main( int argc, char *argv[] ) { bind_function( "read", &lisp_read ); bind_function( "print", &lisp_print ); - bind_function( "plus", &lisp_plus); + bind_function( "add", &lisp_add); + bind_function( "multiply", &lisp_multiply); /* * primitive special forms diff --git a/src/peano.c b/src/peano.c index e39a58e..55da8ba 100644 --- a/src/peano.c +++ b/src/peano.c @@ -32,7 +32,7 @@ * @return a pointer to an integer or real. */ struct cons_pointer -lisp_plus(struct stack_frame *frame, struct cons_pointer env) { +lisp_add(struct stack_frame *frame, struct cons_pointer env) { struct cons_pointer result = NIL; long int i_accumulator = 0; long double d_accumulator = 0; @@ -71,3 +71,49 @@ lisp_plus(struct stack_frame *frame, struct cons_pointer env) { return result; } +/** + * Multiply an indefinite number of numbers together + * @param env the evaluation environment - ignored; + * @param frame the stack frame. + * @return a pointer to an integer or real. + */ +struct cons_pointer +lisp_multiply(struct stack_frame *frame, struct cons_pointer env) { + struct cons_pointer result = NIL; + long int i_accumulator = 1; + long double d_accumulator = 1; + bool is_int = true; + + for (int i = 0; i < args_in_frame && !nilp(frame->arg[i]); i++) { + struct cons_space_object arg = pointer2cell(frame->arg[i]); + + switch (arg.tag.value) { + case INTEGERTV: + i_accumulator *= arg.payload.integer.value; + d_accumulator *= numeric_value( frame->arg[i]); + break; + case REALTV: + d_accumulator *= arg.payload.real.value; + is_int = false; + default: + lisp_throw( + c_string_to_lisp_string("Cannot multiply: not a number"), + frame); + } + + if (! nilp(frame->more)) { + lisp_throw( + c_string_to_lisp_string("Cannot yet multiply more than 8 numbers"), + frame); + } + + if ( is_int) { + result = make_integer( i_accumulator); + } else { + result = make_real( d_accumulator); + } + } + + return result; +} + diff --git a/src/peano.h b/src/peano.h index b50f922..6c9c781 100644 --- a/src/peano.h +++ b/src/peano.h @@ -23,8 +23,16 @@ extern "C" { * @return a pointer to an integer or real. */ struct cons_pointer -lisp_plus(struct stack_frame *frame, struct cons_pointer env); +lisp_add(struct stack_frame *frame, struct cons_pointer env); +/** + * Multiply an indefinite number of numbers together + * @param env the evaluation environment - ignored; + * @param frame the stack frame. + * @return a pointer to an integer or real. + */ +struct cons_pointer +lisp_multiply(struct stack_frame *frame, struct cons_pointer env); #ifdef __cplusplus From 27f39e85eab19724201c0197e0d6712330f414bd Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 13 Sep 2017 18:01:35 +0100 Subject: [PATCH 12/27] Integer arithmetic works, real doesn't - yet. --- src/conspage.c | 9 +++++---- src/conspage.h | 22 +++++++++++++--------- src/init.c | 1 + src/peano.c | 30 +++++++++++++++++++++++++++++ src/peano.h | 8 ++++++++ src/print.c | 2 +- src/read.c | 13 ++++++++++--- src/stack.c | 51 ++++++++++++++------------------------------------ 8 files changed, 82 insertions(+), 54 deletions(-) diff --git a/src/conspage.c b/src/conspage.c index efb9f91..7221ffc 100644 --- a/src/conspage.c +++ b/src/conspage.c @@ -164,11 +164,12 @@ struct cons_pointer allocate_cell( char *tag ) { cell->payload.cons.car = NIL; cell->payload.cons.cdr = NIL; +#ifdef DEBUG fprintf( stderr, "Allocated cell of type '%s' at %d, %d \n", tag, result.page, result.offset ); - // dump_object( stderr, result ); - } else { +#endif + } else { fprintf( stderr, "WARNING: Allocating non-free cell!" ); } } @@ -188,7 +189,7 @@ void initialise_cons_pages( ) { make_cons_page( ); conspageinitihasbeencalled = true; } else { - fprintf( stderr, - "WARNING: conspageinit() called a second or subsequent time\n" ); + fwprintf( stderr, + L"WARNING: initialise_cons_pages() called a second or subsequent time\n" ); } } diff --git a/src/conspage.h b/src/conspage.h index 0dfff8f..3e8026e 100644 --- a/src/conspage.h +++ b/src/conspage.h @@ -4,23 +4,27 @@ #define __conspage_h /** - * the number of cons cells on a cons page. The maximum value this can be (and consequently, - * the size which, by version 1, it will default to) is the maximum value of an unsigned 32 - * bit integer, which is to say 4294967296. However, we'll start small. + * the number of cons cells on a cons page. The maximum value this can + * be (and consequently, the size which, by version 1, it will default + * to) is the maximum value of an unsigned 32 bit integer, which is to + * say 4294967296. However, we'll start small. */ #define CONSPAGESIZE 8 /** - * the number of cons pages we will initially allow for. For convenience we'll set up an array - * of cons pages this big; however, later we will want a mechanism for this to be able to grow - * dynamically to the maximum we can currently allow, which is 4294967296. + * the number of cons pages we will initially allow for. For + * convenience we'll set up an array of cons pages this big; however, + * later we will want a mechanism for this to be able to grow + * dynamically to the maximum we can currently allow, which is + * 4294967296. */ #define NCONSPAGES 8 /** - * a cons page is essentially just an array of cons space objects. It might later have a local - * free list (i.e. list of free cells on this page) and a pointer to the next cons page, but - * my current view is that that's probably unneccessary. + * a cons page is essentially just an array of cons space objects. It + * might later have a local free list (i.e. list of free cells on this + * page) and a pointer to the next cons page, but my current view is + * that that's probably unneccessary. */ struct cons_page { struct cons_space_object cell[CONSPAGESIZE]; diff --git a/src/init.c b/src/init.c index d5207f1..a51e827 100644 --- a/src/init.c +++ b/src/init.c @@ -90,6 +90,7 @@ int main( int argc, char *argv[] ) { bind_function( "add", &lisp_add); bind_function( "multiply", &lisp_multiply); + bind_function( "subtract", &lisp_subtract); /* * primitive special forms diff --git a/src/peano.c b/src/peano.c index 55da8ba..5f50280 100644 --- a/src/peano.c +++ b/src/peano.c @@ -117,3 +117,33 @@ lisp_multiply(struct stack_frame *frame, struct cons_pointer env) { return result; } +/** + * Subtract one number from another. + * @param env the evaluation environment - ignored; + * @param frame the stack frame. + * @return a pointer to an integer or real. + */ +struct cons_pointer +lisp_subtract(struct stack_frame *frame, struct cons_pointer env) { + struct cons_pointer result = NIL; + + struct cons_space_object arg0 = pointer2cell(frame->arg[0]); + struct cons_space_object arg1 = pointer2cell(frame->arg[1]); + + if ( integerp(frame->arg[0]) && integerp(frame->arg[1])) { + result = make_integer(arg0.payload.integer.value - arg1.payload.integer.value); + } else if ( realp(frame->arg[0]) && realp(frame->arg[1])) { + result = make_real(arg0.payload.real.value - arg1.payload.real.value); + } else if (integerp(frame->arg[0]) && realp(frame->arg[1])) { + result = make_real( numeric_value(frame->arg[0]) - arg1.payload.real.value); + } else if (realp(frame->arg[0]) && integerp(frame->arg[1])) { + result = make_real( arg0.payload.real.value - numeric_value(frame->arg[0])); + } // else we have an error! + + // and if not nilp[frame->arg[2]) we also have an error. + + return result; +} + + + diff --git a/src/peano.h b/src/peano.h index 6c9c781..36b64ea 100644 --- a/src/peano.h +++ b/src/peano.h @@ -34,6 +34,14 @@ lisp_add(struct stack_frame *frame, struct cons_pointer env); struct cons_pointer lisp_multiply(struct stack_frame *frame, struct cons_pointer env); +/** + * Subtract one number from another. + * @param env the evaluation environment - ignored; + * @param frame the stack frame. + * @return a pointer to an integer or real. + */ +struct cons_pointer +lisp_subtract(struct stack_frame *frame, struct cons_pointer env); #ifdef __cplusplus } diff --git a/src/print.c b/src/print.c index 1f93f59..ca866cf 100644 --- a/src/print.c +++ b/src/print.c @@ -89,7 +89,7 @@ void print( FILE * output, struct cons_pointer pointer ) { fwprintf( output, L"nil" ); break; case REALTV: - fwprintf( output, L"%lf", cell.payload.real.value ); + fwprintf( output, L"%Lf", cell.payload.real.value ); break; case STRINGTV: print_string( output, pointer ); diff --git a/src/read.c b/src/read.c index f2eeff5..abd76bb 100644 --- a/src/read.c +++ b/src/read.c @@ -82,6 +82,7 @@ struct cons_pointer read_continuation( FILE * input, wint_t initial ) { * read a number from this input stream, given this initial character. */ struct cons_pointer read_number( FILE * input, wint_t initial ) { + struct cons_pointer result = NIL; long int accumulator = 0; int places_of_decimals = 0; bool seen_period = false; @@ -96,7 +97,7 @@ 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, + fwprintf( stderr, L"Added character %c, accumulator now %ld\n", c, accumulator ); if ( seen_period ) { @@ -111,10 +112,16 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) { ungetwc( c, input ); if ( seen_period ) { - return make_real( accumulator / pow( 10, places_of_decimals ) ); + long double rv = (long double) + ( accumulator / pow(10, places_of_decimals) ); + + fwprintf( stderr, L"read_numer returning %Lf\n", rv); + result = make_real( rv); } else { - return make_integer( accumulator ); + result = make_integer( accumulator ); } + + return result; } /** diff --git a/src/stack.c b/src/stack.c index 25e9795..83ecf3a 100644 --- a/src/stack.c +++ b/src/stack.c @@ -51,18 +51,12 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous, result->arg[i] = NIL; } - int i = 0; /* still an index into args, so same name will - * do */ - - while ( !nilp( args ) ) { /* iterate down the arg list filling in the - * arg slots in the frame. When there are no - * more slots, if there are still args, stash - * them on more */ + for (int i = 0; i < args_in_frame && !nilp( args ); i++ ) { + /* iterate down the arg list filling in the arg slots in the + * frame. When there are no more slots, if there are still args, + * stash them on more */ struct cons_space_object cell = pointer2cell( args ); - if ( i < args_in_frame ) { - fwprintf(stderr, L"Making frame; arg %d: ", i); - print(stderr, cell.payload.cons.car); /* * TODO: if we were running on real massively parallel hardware, * each arg except the first should be handed off to another @@ -72,18 +66,13 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous, inc_ref( result->arg[i] ); args = cell.payload.cons.cdr; - i++; - } else { + } /* * TODO: this isn't right. These args should also each be evaled. */ result->more = args; inc_ref( result->more ); - args = NIL; - } - } - return result; } @@ -116,31 +105,19 @@ struct stack_frame *make_special_frame( struct stack_frame *previous, result->arg[i] = NIL; } - int i = 0; /* still an index into args, so same name will - * do */ - - while ( !nilp( args ) ) { /* iterate down the arg list filling in the - * arg slots in the frame. When there are no - * more slots, if there are still args, stash - * them on more */ + for (int i = 0; i < args_in_frame && !nilp( args ); i++ ) { + /* iterate down the arg list filling in the arg slots in the + * frame. When there are no more slots, if there are still args, + * stash them on more */ struct cons_space_object cell = pointer2cell( args ); - if ( i < args_in_frame ) { - result->arg[i] = cell.payload.cons.car; - inc_ref( result->arg[i] ); + result->arg[i] = cell.payload.cons.car; + inc_ref( result->arg[i] ); - args = cell.payload.cons.cdr; - i++; - } else { - /* - * TODO: this isn't right. These args should also each be evaled. - */ - result->more = args; - inc_ref( result->more ); - - args = NIL; - } + args = cell.payload.cons.cdr; } + result->more = args; + inc_ref(args); return result; } From e43c9a7b3345e2fc99da813114fd495e6510254c Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 14 Sep 2017 15:51:11 +0100 Subject: [PATCH 13/27] Documentation in conspage.h --- .gitignore | 2 ++ src/conspage.h | 7 +++++++ 2 files changed, 9 insertions(+) diff --git a/.gitignore b/.gitignore index 8ddda0d..a3d5bf6 100644 --- a/.gitignore +++ b/.gitignore @@ -8,3 +8,5 @@ target/ nbproject/ *~ + +src/\.#* diff --git a/src/conspage.h b/src/conspage.h index 3e8026e..7b8b930 100644 --- a/src/conspage.h +++ b/src/conspage.h @@ -17,6 +17,13 @@ * later we will want a mechanism for this to be able to grow * dynamically to the maximum we can currently allow, which is * 4294967296. + * + * Note that this means the total number of addressable cons cells is + * 1.8e19, each of 20 bytes; or 3e20 bytes in total; and there are + * up to a maximum of 4e9 of heap space objects, each of potentially + * 4e9 bytes. So we're talking about a potential total of 8e100 bytes + * of addressable memory, which is only slightly more than the + * number of atoms in the universe. */ #define NCONSPAGES 8 From 79f749239006042622b5936ba5e263fa008099d8 Mon Sep 17 00:00:00 2001 From: simon Date: Thu, 14 Sep 2017 19:02:03 +0100 Subject: [PATCH 14/27] Whitespace changes only - trying to keep the format regular --- src/conspage.c | 4 +- src/consspaceobject.c | 14 ++--- src/init.c | 28 +++++----- src/intern.c | 2 +- src/lispops.c | 4 +- src/peano.c | 118 +++++++++++++++++++++--------------------- src/peano.h | 16 +++--- src/print.c | 4 +- src/read.c | 14 ++--- src/real.h | 2 +- src/repl.c | 4 +- src/stack.c | 50 +++++++++--------- src/stack.h | 4 +- 13 files changed, 131 insertions(+), 133 deletions(-) diff --git a/src/conspage.c b/src/conspage.c index 7221ffc..0b03d53 100644 --- a/src/conspage.c +++ b/src/conspage.c @@ -169,7 +169,7 @@ struct cons_pointer allocate_cell( char *tag ) { "Allocated cell of type '%s' at %d, %d \n", tag, result.page, result.offset ); #endif - } else { + } else { fprintf( stderr, "WARNING: Allocating non-free cell!" ); } } @@ -190,6 +190,6 @@ void initialise_cons_pages( ) { conspageinitihasbeencalled = true; } else { fwprintf( stderr, - L"WARNING: initialise_cons_pages() called a second or subsequent time\n" ); + L"WARNING: initialise_cons_pages() called a second or subsequent time\n" ); } } diff --git a/src/consspaceobject.c b/src/consspaceobject.c index c7889ed..2c12621 100644 --- a/src/consspaceobject.c +++ b/src/consspaceobject.c @@ -74,7 +74,7 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { cell.tag.bytes[3], cell.tag.value, pointer.page, pointer.offset, cell.count ); - switch ( cell.tag.value) { + 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", @@ -101,9 +101,9 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { 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"); + fwprintf( output, L"\t\t value:" ); + print( output, pointer ); + fwprintf( output, L"\n" ); break; case SYMBOLTV: fwprintf( output, @@ -111,9 +111,9 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { 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"); + fwprintf( output, L"\t\t value:" ); + print( output, pointer ); + fwprintf( output, L"\n" ); break; } } diff --git a/src/init.c b/src/init.c index a51e827..33e0a29 100644 --- a/src/init.c +++ b/src/init.c @@ -25,15 +25,15 @@ void bind_function( char *name, struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer ) ) { - deep_bind( c_string_to_lisp_symbol( name ), - make_function( NIL, executable )); + deep_bind( c_string_to_lisp_symbol( name ), + make_function( NIL, executable ) ); } void bind_special( char *name, struct cons_pointer ( *executable ) ( struct cons_pointer s_expr, struct cons_pointer env, struct stack_frame * frame ) ) { deep_bind( c_string_to_lisp_symbol( name ), - make_special( NIL, executable )); + make_special( NIL, executable ) ); } int main( int argc, char *argv[] ) { @@ -63,8 +63,8 @@ int main( int argc, char *argv[] ) { if ( show_prompt ) { fwprintf( stdout, - L"Post scarcity software environment version %s\n\n", - VERSION ); + L"Post scarcity software environment version %s\n\n", + VERSION ); } initialise_cons_pages( ); @@ -72,7 +72,7 @@ int main( int argc, char *argv[] ) { /* * privileged variables (keywords) */ - + deep_bind( c_string_to_lisp_symbol( "nil" ), NIL ); deep_bind( c_string_to_lisp_symbol( "t" ), TRUE ); @@ -87,10 +87,10 @@ int main( int argc, char *argv[] ) { bind_function( "equal", &lisp_equal ); bind_function( "read", &lisp_read ); bind_function( "print", &lisp_print ); - - bind_function( "add", &lisp_add); - bind_function( "multiply", &lisp_multiply); - bind_function( "subtract", &lisp_subtract); + + bind_function( "add", &lisp_add ); + bind_function( "multiply", &lisp_multiply ); + bind_function( "subtract", &lisp_subtract ); /* * primitive special forms @@ -98,12 +98,12 @@ int main( int argc, char *argv[] ) { bind_special( "apply", &lisp_apply ); bind_special( "eval", &lisp_eval ); bind_special( "quote", &lisp_quote ); - - + + /* bind the oblist last, at this stage. Something clever needs to be done * here and I'm not sure what it is. */ - deep_bind( c_string_to_lisp_symbol( "oblist"), oblist); - + deep_bind( c_string_to_lisp_symbol( "oblist" ), oblist ); + repl( stdin, stdout, stderr, show_prompt ); if ( dump_at_end ) { diff --git a/src/intern.c b/src/intern.c index fae0b7a..31b7e2e 100644 --- a/src/intern.c +++ b/src/intern.c @@ -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 ); diff --git a/src/lispops.c b/src/lispops.c index 073455f..c73914c 100644 --- a/src/lispops.c +++ b/src/lispops.c @@ -166,7 +166,7 @@ lisp_eval( struct cons_pointer s_expr, struct cons_pointer env, switch ( cell.tag.value ) { case CONSTV: - result = eval_cons( s_expr, env, previous); + result = eval_cons( s_expr, env, previous ); break; case SYMBOLTV: @@ -355,7 +355,7 @@ lisp_throw( struct cons_pointer message, struct stack_frame *frame ) { fwprintf( stderr, L"\nERROR: " ); print( stderr, message ); fwprintf( stderr, - L"\n\nAn exception was thrown and I've no idea what to do now\n" ); + 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 index 5f50280..9e5b1e2 100644 --- a/src/peano.c +++ b/src/peano.c @@ -32,43 +32,41 @@ * @return a pointer to an integer or real. */ struct cons_pointer -lisp_add(struct stack_frame *frame, struct cons_pointer env) { +lisp_add( struct stack_frame *frame, struct cons_pointer env ) { struct cons_pointer result = NIL; long int i_accumulator = 0; long double d_accumulator = 0; bool is_int = true; - - for (int i = 0; i < args_in_frame && !nilp(frame->arg[i]); i++) { - struct cons_space_object arg = pointer2cell(frame->arg[i]); - - switch (arg.tag.value) { + + for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) { + struct cons_space_object arg = pointer2cell( frame->arg[i] ); + + switch ( arg.tag.value ) { case INTEGERTV: i_accumulator += arg.payload.integer.value; - d_accumulator += numeric_value( frame->arg[i]); + d_accumulator += numeric_value( frame->arg[i] ); break; case REALTV: d_accumulator += arg.payload.real.value; is_int = false; default: - lisp_throw( - c_string_to_lisp_string("Cannot add: not a number"), - frame); - } - - if (! nilp(frame->more)) { - lisp_throw( - c_string_to_lisp_string("Cannot yet add more than 8 numbers"), - frame); + lisp_throw( c_string_to_lisp_string( "Cannot add: not a number" ), + frame ); } - if ( is_int) { - result = make_integer( i_accumulator); + if ( !nilp( frame->more ) ) { + lisp_throw( c_string_to_lisp_string + ( "Cannot yet add more than 8 numbers" ), frame ); + } + + if ( is_int ) { + result = make_integer( i_accumulator ); } else { - result = make_real( d_accumulator); + result = make_real( d_accumulator ); } } - - return result; + + return result; } /** @@ -78,43 +76,41 @@ lisp_add(struct stack_frame *frame, struct cons_pointer env) { * @return a pointer to an integer or real. */ struct cons_pointer -lisp_multiply(struct stack_frame *frame, struct cons_pointer env) { +lisp_multiply( struct stack_frame *frame, struct cons_pointer env ) { struct cons_pointer result = NIL; long int i_accumulator = 1; long double d_accumulator = 1; bool is_int = true; - - for (int i = 0; i < args_in_frame && !nilp(frame->arg[i]); i++) { - struct cons_space_object arg = pointer2cell(frame->arg[i]); - - switch (arg.tag.value) { + + for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) { + struct cons_space_object arg = pointer2cell( frame->arg[i] ); + + switch ( arg.tag.value ) { case INTEGERTV: i_accumulator *= arg.payload.integer.value; - d_accumulator *= numeric_value( frame->arg[i]); + d_accumulator *= numeric_value( frame->arg[i] ); break; case REALTV: d_accumulator *= arg.payload.real.value; is_int = false; default: - lisp_throw( - c_string_to_lisp_string("Cannot multiply: not a number"), - frame); - } - - if (! nilp(frame->more)) { - lisp_throw( - c_string_to_lisp_string("Cannot yet multiply more than 8 numbers"), - frame); + lisp_throw( c_string_to_lisp_string + ( "Cannot multiply: not a number" ), frame ); } - if ( is_int) { - result = make_integer( i_accumulator); + if ( !nilp( frame->more ) ) { + lisp_throw( c_string_to_lisp_string + ( "Cannot yet multiply more than 8 numbers" ), frame ); + } + + if ( is_int ) { + result = make_integer( i_accumulator ); } else { - result = make_real( d_accumulator); + result = make_real( d_accumulator ); } } - - return result; + + return result; } /** @@ -124,26 +120,30 @@ lisp_multiply(struct stack_frame *frame, struct cons_pointer env) { * @return a pointer to an integer or real. */ struct cons_pointer -lisp_subtract(struct stack_frame *frame, struct cons_pointer env) { +lisp_subtract( struct stack_frame *frame, struct cons_pointer env ) { struct cons_pointer result = NIL; - - struct cons_space_object arg0 = pointer2cell(frame->arg[0]); - struct cons_space_object arg1 = pointer2cell(frame->arg[1]); - if ( integerp(frame->arg[0]) && integerp(frame->arg[1])) { - result = make_integer(arg0.payload.integer.value - arg1.payload.integer.value); - } else if ( realp(frame->arg[0]) && realp(frame->arg[1])) { - result = make_real(arg0.payload.real.value - arg1.payload.real.value); - } else if (integerp(frame->arg[0]) && realp(frame->arg[1])) { - result = make_real( numeric_value(frame->arg[0]) - arg1.payload.real.value); - } else if (realp(frame->arg[0]) && integerp(frame->arg[1])) { - result = make_real( arg0.payload.real.value - numeric_value(frame->arg[0])); - } // else we have an error! + struct cons_space_object arg0 = pointer2cell( frame->arg[0] ); + struct cons_space_object arg1 = pointer2cell( frame->arg[1] ); + + if ( integerp( frame->arg[0] ) && integerp( frame->arg[1] ) ) { + result = + make_integer( arg0.payload.integer.value - + arg1.payload.integer.value ); + } else if ( realp( frame->arg[0] ) && realp( frame->arg[1] ) ) { + result = + make_real( arg0.payload.real.value - arg1.payload.real.value ); + } else if ( integerp( frame->arg[0] ) && realp( frame->arg[1] ) ) { + result = + make_real( numeric_value( frame->arg[0] ) - + arg1.payload.real.value ); + } else if ( realp( frame->arg[0] ) && integerp( frame->arg[1] ) ) { + result = + make_real( arg0.payload.real.value - + numeric_value( frame->arg[0] ) ); + } // else we have an error! // and if not nilp[frame->arg[2]) we also have an error. - + return result; } - - - diff --git a/src/peano.h b/src/peano.h index 36b64ea..4650fe0 100644 --- a/src/peano.h +++ b/src/peano.h @@ -22,8 +22,8 @@ extern "C" { * @param frame the stack frame. * @return a pointer to an integer or real. */ -struct cons_pointer -lisp_add(struct stack_frame *frame, struct cons_pointer env); + struct cons_pointer + lisp_add( struct stack_frame *frame, struct cons_pointer env ); /** * Multiply an indefinite number of numbers together @@ -31,8 +31,8 @@ lisp_add(struct stack_frame *frame, struct cons_pointer env); * @param frame the stack frame. * @return a pointer to an integer or real. */ -struct cons_pointer -lisp_multiply(struct stack_frame *frame, struct cons_pointer env); + struct cons_pointer + lisp_multiply( struct stack_frame *frame, struct cons_pointer env ); /** * Subtract one number from another. @@ -40,12 +40,10 @@ lisp_multiply(struct stack_frame *frame, struct cons_pointer env); * @param frame the stack frame. * @return a pointer to an integer or real. */ -struct cons_pointer -lisp_subtract(struct stack_frame *frame, struct cons_pointer env); + struct cons_pointer + lisp_subtract( struct stack_frame *frame, struct cons_pointer env ); #ifdef __cplusplus } #endif - -#endif /* PEANO_H */ - +#endif /* PEANO_H */ diff --git a/src/print.c b/src/print.c index ca866cf..f66cf1b 100644 --- a/src/print.c +++ b/src/print.c @@ -101,10 +101,10 @@ void print( FILE * output, struct cons_pointer pointer ) { fwprintf( output, L"t" ); break; case FUNCTIONTV: - fwprintf( output, L"(Function)"); + fwprintf( output, L"(Function)" ); break; case SPECIALTV: - fwprintf( output, L"(Special form)"); + fwprintf( output, L"(Special form)" ); break; default: fwprintf( stderr, diff --git a/src/read.c b/src/read.c index abd76bb..fb3e6d3 100644 --- a/src/read.c +++ b/src/read.c @@ -82,7 +82,7 @@ struct cons_pointer read_continuation( FILE * input, wint_t initial ) { * read a number from this input stream, given this initial character. */ struct cons_pointer read_number( FILE * input, wint_t initial ) { - struct cons_pointer result = NIL; + struct cons_pointer result = NIL; long int accumulator = 0; int places_of_decimals = 0; bool seen_period = false; @@ -98,7 +98,7 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) { accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' ); fwprintf( stderr, L"Added character %c, accumulator now %ld\n", c, - accumulator ); + accumulator ); if ( seen_period ) { places_of_decimals++; @@ -112,11 +112,11 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) { ungetwc( c, input ); if ( seen_period ) { - long double rv = (long double) - ( accumulator / pow(10, places_of_decimals) ); + long double rv = ( long double ) + ( accumulator / pow( 10, places_of_decimals ) ); - fwprintf( stderr, L"read_numer returning %Lf\n", rv); - result = make_real( rv); + fwprintf( stderr, L"read_numer returning %Lf\n", rv ); + result = make_real( rv ); } else { result = make_integer( accumulator ); } @@ -203,7 +203,7 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) { * push back the character read */ ungetwc( initial, input ); - } + } break; } diff --git a/src/real.h b/src/real.h index 759a2bb..7e3601f 100644 --- a/src/real.h +++ b/src/real.h @@ -24,7 +24,7 @@ extern "C" { * @param value the value to wrap; * @return a real number cell wrapping this value. */ -struct cons_pointer make_real( double value ); + struct cons_pointer make_real( double value ); #ifdef __cplusplus } diff --git a/src/repl.c b/src/repl.c index 2e9fb41..6cedc8e 100644 --- a/src/repl.c +++ b/src/repl.c @@ -31,13 +31,13 @@ repl( FILE * in_stream, FILE * out_stream, FILE * error_stream, struct cons_pointer input = read( in_stream ); fwprintf( error_stream, L"\nread {%d,%d}=> ", input.page, input.offset ); - print( error_stream, input); + print( error_stream, input ); struct cons_pointer value = 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 ); - print( out_stream, value); + print( out_stream, value ); } } diff --git a/src/stack.c b/src/stack.c index 83ecf3a..c47adbd 100644 --- a/src/stack.c +++ b/src/stack.c @@ -51,27 +51,27 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous, result->arg[i] = NIL; } - for (int i = 0; i < args_in_frame && !nilp( args ); i++ ) { - /* iterate down the arg list filling in the arg slots in the - * frame. When there are no more slots, if there are still args, - * stash them on more */ + for ( int i = 0; i < args_in_frame && !nilp( args ); i++ ) { + /* iterate down the arg list filling in the arg slots in the + * frame. When there are no more slots, if there are still args, + * stash them on more */ struct cons_space_object cell = pointer2cell( args ); - /* - * TODO: if we were running on real massively parallel hardware, - * each arg except the first should be handed off to another - * processor to be evaled in parallel - */ - result->arg[i] = lisp_eval( cell.payload.cons.car, env, result ); - inc_ref( result->arg[i] ); + /* + * TODO: if we were running on real massively parallel hardware, + * each arg except the first should be handed off to another + * processor to be evaled in parallel + */ + result->arg[i] = lisp_eval( cell.payload.cons.car, env, result ); + inc_ref( result->arg[i] ); - args = cell.payload.cons.cdr; - } - /* - * TODO: this isn't right. These args should also each be evaled. - */ - result->more = args; - inc_ref( result->more ); + args = cell.payload.cons.cdr; + } + /* + * TODO: this isn't right. These args should also each be evaled. + */ + result->more = args; + inc_ref( result->more ); return result; } @@ -85,8 +85,8 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous, * @return a new special frame. */ struct stack_frame *make_special_frame( struct stack_frame *previous, - struct cons_pointer args, - struct cons_pointer env ) { + struct cons_pointer args, + struct cons_pointer env ) { /* * TODO: later, pop a frame off a free-list of stack frames */ @@ -105,10 +105,10 @@ struct stack_frame *make_special_frame( struct stack_frame *previous, result->arg[i] = NIL; } - for (int i = 0; i < args_in_frame && !nilp( args ); i++ ) { - /* iterate down the arg list filling in the arg slots in the - * frame. When there are no more slots, if there are still args, - * stash them on more */ + for ( int i = 0; i < args_in_frame && !nilp( args ); i++ ) { + /* iterate down the arg list filling in the arg slots in the + * frame. When there are no more slots, if there are still args, + * stash them on more */ struct cons_space_object cell = pointer2cell( args ); result->arg[i] = cell.payload.cons.car; @@ -117,7 +117,7 @@ struct stack_frame *make_special_frame( struct stack_frame *previous, args = cell.payload.cons.cdr; } result->more = args; - inc_ref(args); + inc_ref( args ); return result; } diff --git a/src/stack.h b/src/stack.h index 4eaa9e1..a7fc82b 100644 --- a/src/stack.h +++ b/src/stack.h @@ -39,8 +39,8 @@ struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int n ); * @return a new special frame. */ struct stack_frame *make_special_frame( struct stack_frame *previous, - struct cons_pointer args, - struct cons_pointer env ); + struct cons_pointer args, + struct cons_pointer env ); /* * struct stack_frame is defined in consspaceobject.h to break circularity From cf1b09c62a5d5c8e1fb1d88d859c9c1cc3bf49e4 Mon Sep 17 00:00:00 2001 From: simon Date: Sun, 17 Sep 2017 11:29:49 +0100 Subject: [PATCH 15/27] Bug in reading reals. --- src/peano.c | 8 ++++---- src/real.h | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/peano.c b/src/peano.c index 9e5b1e2..b01a951 100644 --- a/src/peano.c +++ b/src/peano.c @@ -39,15 +39,15 @@ lisp_add( struct stack_frame *frame, struct cons_pointer env ) { bool is_int = true; for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) { - struct cons_space_object arg = pointer2cell( frame->arg[i] ); + struct cons_space_object current = pointer2cell( frame->arg[i] ); - switch ( arg.tag.value ) { + switch ( current.tag.value ) { case INTEGERTV: - i_accumulator += arg.payload.integer.value; + i_accumulator += current.payload.integer.value; d_accumulator += numeric_value( frame->arg[i] ); break; case REALTV: - d_accumulator += arg.payload.real.value; + d_accumulator += current.payload.real.value; is_int = false; default: lisp_throw( c_string_to_lisp_string( "Cannot add: not a number" ), diff --git a/src/real.h b/src/real.h index 7e3601f..6e4ed53 100644 --- a/src/real.h +++ b/src/real.h @@ -24,7 +24,7 @@ extern "C" { * @param value the value to wrap; * @return a real number cell wrapping this value. */ - struct cons_pointer make_real( double value ); + struct cons_pointer make_real( long double value ); #ifdef __cplusplus } From b713c1822dd015a86b38c2acd571431c84c6c3c9 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 17 Sep 2017 20:18:15 +0100 Subject: [PATCH 16/27] WArning! this doesn't even build! Half way through reworking eval. --- src/consspaceobject.c | 4 +- src/consspaceobject.h | 5 +-- src/lispops.c | 95 +++++++++++++++++++++++-------------------- src/lispops.h | 15 +++---- src/peano.c | 2 + src/read.c | 2 +- src/repl.c | 5 ++- src/stack.c | 54 +++++++++++++----------- src/stack.h | 9 ++++ 9 files changed, 106 insertions(+), 85 deletions(-) diff --git a/src/consspaceobject.c b/src/consspaceobject.c index 2c12621..da0be0b 100644 --- a/src/consspaceobject.c +++ b/src/consspaceobject.c @@ -204,8 +204,8 @@ struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) { */ struct cons_pointer make_special( struct cons_pointer src, struct cons_pointer ( *executable ) - ( struct cons_pointer s_expr, - struct cons_pointer env, struct stack_frame * frame ) ) { + ( struct struct stack_frame * frame, + struct cons_pointer env ) ) { struct cons_pointer pointer = allocate_cell( SPECIALTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); diff --git a/src/consspaceobject.h b/src/consspaceobject.h index 4e4dc9c..e87255a 100644 --- a/src/consspaceobject.h +++ b/src/consspaceobject.h @@ -290,9 +290,8 @@ struct real_payload { */ struct special_payload { struct cons_pointer source; - struct cons_pointer ( *executable ) ( struct cons_pointer s_expr, - struct cons_pointer env, - struct stack_frame * frame ); + struct cons_pointer ( *executable ) ( struct stack_frame *, + struct cons_pointer ); }; /** diff --git a/src/lispops.c b/src/lispops.c index c73914c..725fd31 100644 --- a/src/lispops.c +++ b/src/lispops.c @@ -72,40 +72,26 @@ struct cons_pointer c_cdr( struct cons_pointer arg ) { return result; } -/** - * (apply fn args...) - * - * I'm now confused about whether at this stage I actually need an apply special form, - * and if so how it differs from eval. - */ -struct cons_pointer -lisp_apply( struct cons_pointer args, struct cons_pointer env, - struct stack_frame *frame ) { - struct cons_pointer result = args; - if ( consp( args ) ) { - lisp_eval( args, env, frame ); - } - - return result; -} struct cons_pointer -eval_cons( struct cons_pointer s_expr, struct cons_pointer env, - struct stack_frame *my_frame ) { +eval_cons( struct stack_frame *frame, struct cons_pointer env ) { struct cons_pointer result = NIL; - struct cons_pointer fn_pointer = - lisp_eval( c_car( s_expr ), env, my_frame ); + + struct stack_frame *fn_frame = make_empty_frame( frame, env ); + fn_frame->arg[0] = c_car( frame->arg[0] ); + struct cons_pointer fn_pointer = lisp_eval( fn_frame, env ); + free_stack_frame( fn_frame ); + struct cons_space_object fn_cell = pointer2cell( fn_pointer ); - struct cons_pointer args = c_cdr( s_expr ); + struct cons_pointer args = c_cdr( frame->arg[0] ); switch ( fn_cell.tag.value ) { case SPECIALTV: { - struct stack_frame *frame = - make_special_frame( my_frame, args, env ); - result = - ( *fn_cell.payload.special.executable ) ( args, env, frame ); + struct stack_frame *next = make_special_frame( frame, args, env ); + result = ( *fn_cell.payload.special.executable ) ( next, env ); + free_stack_frame( next ); } break; @@ -114,16 +100,9 @@ eval_cons( struct cons_pointer s_expr, struct cons_pointer env, * actually, this is apply */ { - struct cons_space_object function = pointer2cell( fn_pointer ); - struct stack_frame *frame = - make_stack_frame( my_frame, args, env ); - - /* - * the trick: pass the remaining arguments and environment to the - * executable code which is the payload of the function object. - */ - result = ( *fn_cell.payload.function.executable ) ( frame, env ); - free_stack_frame( frame ); + struct stack_frame *next = make_stack_frame( frame, args, env ); + result = ( *fn_cell.payload.special.executable ) ( next, env ); + free_stack_frame( next ); } break; @@ -138,7 +117,7 @@ eval_cons( struct cons_pointer s_expr, struct cons_pointer env, fn_cell.tag.bytes[3] ); struct cons_pointer message = c_string_to_lisp_string( buffer ); free( buffer ); - result = lisp_throw( message, my_frame ); + result = lisp_throw( message, frame ); } } @@ -159,24 +138,23 @@ eval_cons( struct cons_pointer s_expr, struct cons_pointer env, * If a special form, passes the cdr of s_expr to the special form as argument. */ struct cons_pointer -lisp_eval( struct cons_pointer s_expr, struct cons_pointer env, - struct stack_frame *previous ) { - struct cons_pointer result = s_expr; - struct cons_space_object cell = pointer2cell( s_expr ); +lisp_eval( struct stack_frame *frame, struct cons_pointer env ) { + struct cons_pointer result = frame->arg[0]; + struct cons_space_object cell = pointer2cell( frame->arg[0] ); switch ( cell.tag.value ) { case CONSTV: - result = eval_cons( s_expr, env, previous ); + result = eval_cons( frame, env ); break; case SYMBOLTV: { - struct cons_pointer canonical = internedp( s_expr, env ); + struct cons_pointer canonical = internedp( frame->arg[0], env ); if ( nilp( canonical ) ) { struct cons_pointer message = c_string_to_lisp_string ( "Attempt to take value of unbound symbol." ); - result = lisp_throw( message, previous ); + result = lisp_throw( message, frame ); } else { result = c_assoc( canonical, env ); } @@ -194,6 +172,34 @@ lisp_eval( struct cons_pointer s_expr, struct cons_pointer env, return result; } +/** + * (apply fn args) + */ +struct cons_pointer +lisp_apply( struct stack_frame *frame, struct cons_pointer env ) { + struct cons_pointer result = NIL; + + if ( nilp( frame->arg[1] ) || !nilp( frame->arg[2] ) ) { + result = + lisp_throw( c_string_to_lisp_string( "(apply " ), + frame ); + } + + struct stack_frame *fn_frame = make_empty_frame( frame, env ); + fn_frame->arg[0] = frame->arg[0]; + struct cons_pointer fn_pointer = lisp_eval( fn_frame, env ); + free_stack_frame( fn_frame ); + + struct stack_frame *next_frame = + make_special_frame( frame, make_cons( fn_pointer, frame->arg[1] ), + env ); + result = eval_cons( next_frame, env ); + free_stack_frame( next_frame ); + + return result; +} + + /** * (quote a) * @@ -202,8 +208,7 @@ lisp_eval( struct cons_pointer s_expr, struct cons_pointer env, * this isn't at this stage checked) unevaluated. */ struct cons_pointer -lisp_quote( struct cons_pointer args, struct cons_pointer env, - struct stack_frame *frame ) { +lisp_quote( struct stack_frame *frame, struct cons_pointer env ) { return frame->arg[0]; } diff --git a/src/lispops.h b/src/lispops.h index f3e5200..e808a1a 100644 --- a/src/lispops.h +++ b/src/lispops.h @@ -22,15 +22,12 @@ /* * special forms */ -struct cons_pointer lisp_eval( struct cons_pointer args, - struct cons_pointer env, - struct stack_frame *frame ); -struct cons_pointer lisp_apply( struct cons_pointer args, - struct cons_pointer env, - struct stack_frame *frame ); -struct cons_pointer lisp_quote( struct cons_pointer args, - struct cons_pointer env, - struct stack_frame *frame ); +struct cons_pointer lisp_eval( struct stack_frame *frame, + struct cons_pointer env ); +struct cons_pointer lisp_apply( struct stack_frame *frame, + struct cons_pointer env ); +struct cons_pointer lisp_quote( struct stack_frame *frame, + struct cons_pointer env ); /* * functions diff --git a/src/peano.c b/src/peano.c index b01a951..409abf9 100644 --- a/src/peano.c +++ b/src/peano.c @@ -49,6 +49,7 @@ lisp_add( struct stack_frame *frame, struct cons_pointer env ) { case REALTV: d_accumulator += current.payload.real.value; is_int = false; + break; default: lisp_throw( c_string_to_lisp_string( "Cannot add: not a number" ), frame ); @@ -93,6 +94,7 @@ lisp_multiply( struct stack_frame *frame, struct cons_pointer env ) { case REALTV: d_accumulator *= arg.payload.real.value; is_int = false; + break; default: lisp_throw( c_string_to_lisp_string ( "Cannot multiply: not a number" ), frame ); diff --git a/src/read.c b/src/read.c index fb3e6d3..24d7ece 100644 --- a/src/read.c +++ b/src/read.c @@ -66,7 +66,7 @@ struct cons_pointer read_continuation( FILE * input, wint_t initial ) { result = read_string( input, fgetwc( input ) ); break; default: - if ( iswdigit( c ) ) { + if ( iswdigit( c ) || c == '.' ) { result = read_number( input, c ); } else if ( iswprint( c ) ) { result = read_symbol( input, c ); diff --git a/src/repl.c b/src/repl.c index 6cedc8e..968306d 100644 --- a/src/repl.c +++ b/src/repl.c @@ -33,7 +33,10 @@ repl( FILE * in_stream, FILE * out_stream, FILE * error_stream, input.offset ); print( error_stream, input ); - struct cons_pointer value = lisp_eval( input, oblist, NULL ); + struct stack_frame *frame = make_empty_frame( NIL, oblist ); + frame->arg[0] = input; + struct cons_pointer value = lisp_eval( frame, oblist ); + free_stack_frame( frame ); // print( out_stream, input ); fwprintf( out_stream, L"\n" ); fwprintf( error_stream, L"\neval {%d,%d}=> ", input.page, diff --git a/src/stack.c b/src/stack.c index c47adbd..bed6307 100644 --- a/src/stack.c +++ b/src/stack.c @@ -27,16 +27,17 @@ #include "stack.h" /** - * Allocate a new stack frame with its previous pointer set to this value, - * its arguments set up from these args, evaluated in this env. + * Make an empty stack frame, and return it. + * @param previous the current top-of-stack; + * @param env the environment in which evaluation happens. + * @return the new frame. */ -struct stack_frame *make_stack_frame( struct stack_frame *previous, - struct cons_pointer args, +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 *result = malloc( sizeof( struct stack_frame ) ); result->previous = previous; @@ -51,6 +52,23 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous, result->arg[i] = NIL; } + return result; +} + + +/** + * Allocate a new stack frame with its previous pointer set to this value, + * its arguments set up from these args, evaluated in this env. + * @param previous the current top-of-stack; + * @args the arguments to load into this frame; + * @param env the environment in which evaluation happens. + * @return the new frame. + */ +struct stack_frame *make_stack_frame( struct stack_frame *previous, + struct cons_pointer args, + struct cons_pointer env ) { + struct stack_frame *result = make_empty_frame( previous, env ); + for ( int i = 0; i < args_in_frame && !nilp( args ); i++ ) { /* iterate down the arg list filling in the arg slots in the * frame. When there are no more slots, if there are still args, @@ -60,9 +78,13 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous, /* * TODO: if we were running on real massively parallel hardware, * each arg except the first should be handed off to another - * processor to be evaled in parallel + * processor to be evaled in parallel; but see notes here: + * https://github.com/simon-brooke/post-scarcity/wiki/parallelism */ - result->arg[i] = lisp_eval( cell.payload.cons.car, env, result ); + struct stack_frame *arg_frame = make_empty_frame( previous, env ); + arg_frame->arg[0] = cell.payload.cons.car; + result->arg[i] = lisp_eval( arg_frame, env ); + free_stack_frame( arg_frame ); inc_ref( result->arg[i] ); args = cell.payload.cons.cdr; @@ -87,23 +109,7 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous, struct stack_frame *make_special_frame( struct stack_frame *previous, struct cons_pointer args, struct cons_pointer env ) { - /* - * TODO: later, pop a frame off a free-list of stack frames - */ - struct stack_frame *result = malloc( sizeof( struct stack_frame ) ); - - result->previous = previous; - - /* - * clearing the frame with memset would probably be slightly quicker, but - * this is clear. - */ - result->more = NIL; - result->function = NIL; - - for ( int i = 0; i < args_in_frame; i++ ) { - result->arg[i] = NIL; - } + struct stack_frame *result = make_empty_frame( previous, env ); for ( int i = 0; i < args_in_frame && !nilp( args ); i++ ) { /* iterate down the arg list filling in the arg slots in the diff --git a/src/stack.h b/src/stack.h index a7fc82b..f227ac3 100644 --- a/src/stack.h +++ b/src/stack.h @@ -24,6 +24,15 @@ #ifndef __stack_h #define __stack_h +/** + * Make an empty stack frame, and return it. + * @param previous the current top-of-stack; + * @param env the environment in which evaluation happens. + * @return the new frame. + */ +struct stack_frame *make_empty_frame( struct stack_frame *previous, + struct cons_pointer env ); + struct stack_frame *make_stack_frame( struct stack_frame *previous, struct cons_pointer args, struct cons_pointer env ); From 832ae3be0dcd4d6c1581a2aa1186d491767529c5 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 25 Sep 2017 10:01:25 +0100 Subject: [PATCH 17/27] New unit tests. --- unit-tests/add.sh | 26 ++++++++++++++++++++++++++ unit-tests/apply.sh | 13 +++++++++++++ 2 files changed, 39 insertions(+) create mode 100644 unit-tests/add.sh create mode 100644 unit-tests/apply.sh diff --git a/unit-tests/add.sh b/unit-tests/add.sh new file mode 100644 index 0000000..0dabb4c --- /dev/null +++ b/unit-tests/add.sh @@ -0,0 +1,26 @@ +#!/bin/bash + +expected='5' +actual=`echo "(add 2 3)" | target/psse 2> /dev/null | head -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" + exit 0 +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +expected='5.5000' +actual=`echo "(add 2.5 3)" | target/psse 2> /dev/null | head -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" + exit 0 +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + diff --git a/unit-tests/apply.sh b/unit-tests/apply.sh new file mode 100644 index 0000000..1ee19b0 --- /dev/null +++ b/unit-tests/apply.sh @@ -0,0 +1,13 @@ +#!/bin/bash + +expected='1' +actual=`echo "(apply 'add '(1))"| target/psse 2> /dev/null | head -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" + exit 0 +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi From 77393b70adcb0b220c216af4cc04d4bba952aea8 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 25 Sep 2017 13:34:46 +0100 Subject: [PATCH 18/27] Fix build bugs --- src/consspaceobject.c | 2 +- src/consspaceobject.h | 5 ++--- src/repl.c | 3 ++- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/consspaceobject.c b/src/consspaceobject.c index da0be0b..d3628e6 100644 --- a/src/consspaceobject.c +++ b/src/consspaceobject.c @@ -204,7 +204,7 @@ struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) { */ struct cons_pointer make_special( struct cons_pointer src, struct cons_pointer ( *executable ) - ( struct struct stack_frame * frame, + ( struct stack_frame * frame, struct cons_pointer env ) ) { struct cons_pointer pointer = allocate_cell( SPECIALTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); diff --git a/src/consspaceobject.h b/src/consspaceobject.h index e87255a..f5f1e25 100644 --- a/src/consspaceobject.h +++ b/src/consspaceobject.h @@ -425,9 +425,8 @@ struct cons_pointer make_function( struct cons_pointer src, */ struct cons_pointer make_special( struct cons_pointer src, struct cons_pointer ( *executable ) - ( struct cons_pointer s_expr, - struct cons_pointer env, - struct stack_frame * frame ) ); + ( struct stack_frame * frame, + struct cons_pointer env ) ); /** * Construct a string from this character and this tail. A string is diff --git a/src/repl.c b/src/repl.c index 968306d..476aebe 100644 --- a/src/repl.c +++ b/src/repl.c @@ -13,6 +13,7 @@ #include "lispops.h" #include "read.h" #include "print.h" +#include "stack.h" /** * The read/eval/print loop @@ -33,7 +34,7 @@ repl( FILE * in_stream, FILE * out_stream, FILE * error_stream, input.offset ); print( error_stream, input ); - struct stack_frame *frame = make_empty_frame( NIL, oblist ); + struct stack_frame *frame = make_empty_frame( NULL, oblist ); frame->arg[0] = input; struct cons_pointer value = lisp_eval( frame, oblist ); free_stack_frame( frame ); From 0e224e551bdd624946a0a49a9ec96a3fe69f3d03 Mon Sep 17 00:00:00 2001 From: simon Date: Fri, 6 Oct 2017 18:27:01 +0100 Subject: [PATCH 19/27] EVAL on arithmetic operations still not working --- src/conspage.c | 1 + src/consspaceobject.c | 28 ++++++++++++++++------------ src/consspaceobject.h | 5 ++--- src/lispops.c | 6 +++--- 4 files changed, 22 insertions(+), 18 deletions(-) diff --git a/src/conspage.c b/src/conspage.c index 0b03d53..2e4d90a 100644 --- a/src/conspage.c +++ b/src/conspage.c @@ -149,6 +149,7 @@ void free_cell( struct cons_pointer pointer ) { struct cons_pointer allocate_cell( char *tag ) { struct cons_pointer result = freelist; + if ( result.page == NIL.page && result.offset == NIL.offset ) { make_cons_page( ); result = allocate_cell( tag ); diff --git a/src/consspaceobject.c b/src/consspaceobject.c index da0be0b..8a5371d 100644 --- a/src/consspaceobject.c +++ b/src/consspaceobject.c @@ -77,40 +77,44 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { switch ( cell.tag.value ) { case CONSTV: fwprintf( output, - L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d\n", + 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.payload.cons.cdr.page, + cell.payload.cons.cdr.offset, + cell.count); break; case INTEGERTV: fwprintf( output, - L"\t\tInteger cell: value %ld\n", - cell.payload.integer.value ); + L"\t\tInteger cell: value %ld, count %u\n", + cell.payload.integer.value, cell.count ); 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 REALTV: - fwprintf( output, L"\t\tReal cell: value %Lf\n", - cell.payload.real.value ); + fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n", + cell.payload.real.value, cell.count ); break; case STRINGTV: fwprintf( output, - L"\t\tString cell: character '%1c' (%1d) next at page %2d offset %3d\n", + L"\t\tString cell: character '%1c' (%1d) next at page %2d offset %3d, count %u\n", cell.payload.string.character, cell.payload.string.cdr.page, - cell.payload.string.cdr.offset ); - fwprintf( output, L"\t\t value:" ); + cell.payload.string.cdr.offset, + cell.count ); + 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", + L"\t\tSymbol cell: character '%1c' (%1d) next at page %2d offset %3d, count %u\n", cell.payload.string.character, cell.payload.string.cdr.page, - cell.payload.string.cdr.offset ); + cell.payload.string.cdr.offset, + cell.count ); fwprintf( output, L"\t\t value:" ); print( output, pointer ); fwprintf( output, L"\n" ); @@ -204,7 +208,7 @@ struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) { */ struct cons_pointer make_special( struct cons_pointer src, struct cons_pointer ( *executable ) - ( struct struct stack_frame * frame, + ( struct stack_frame * frame, struct cons_pointer env ) ) { struct cons_pointer pointer = allocate_cell( SPECIALTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); diff --git a/src/consspaceobject.h b/src/consspaceobject.h index e87255a..649ec4b 100644 --- a/src/consspaceobject.h +++ b/src/consspaceobject.h @@ -425,9 +425,8 @@ struct cons_pointer make_function( struct cons_pointer src, */ struct cons_pointer make_special( struct cons_pointer src, struct cons_pointer ( *executable ) - ( struct cons_pointer s_expr, - struct cons_pointer env, - struct stack_frame * frame ) ); + ( struct stack_frame *, + struct cons_pointer ) ); /** * Construct a string from this character and this tail. A string is diff --git a/src/lispops.c b/src/lispops.c index 725fd31..dc33db3 100644 --- a/src/lispops.c +++ b/src/lispops.c @@ -257,7 +257,7 @@ lisp_car( struct stack_frame *frame, struct cons_pointer env ) { } else { struct cons_pointer message = c_string_to_lisp_string - ( "Attempt to take CAR/CDR of non sequence" ); + ( "Attempt to take CAR of non sequence" ); result = lisp_throw( message, frame ); } @@ -275,14 +275,14 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer env ) { if ( consp( frame->arg[0] ) ) { struct cons_space_object cell = pointer2cell( frame->arg[0] ); - result = cell.payload.cons.car; + result = cell.payload.cons.cdr; } else if ( stringp( frame->arg[0] ) ) { struct cons_space_object cell = pointer2cell( frame->arg[0] ); result = cell.payload.string.cdr; } else { struct cons_pointer message = c_string_to_lisp_string - ( "Attempt to take CAR/CDR of non sequence" ); + ( "Attempt to take CDR of non sequence" ); result = lisp_throw( message, frame ); } From c396370e51e38c6277abfad4cacdd3ee34142eca Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 7 Oct 2017 15:11:07 +0100 Subject: [PATCH 20/27] Fixed a number of unit tests (problems were output format, not actual bugs) --- unit-tests/add.sh | 2 +- unit-tests/complex-list.sh | 2 +- unit-tests/empty-list.sh.bash | 2 +- unit-tests/empty-string.sh | 2 +- unit-tests/fred.sh | 2 +- unit-tests/integer.sh | 2 +- unit-tests/nil.sh | 2 +- unit-tests/quote.sh | 2 +- unit-tests/quoted-list.sh | 2 +- unit-tests/simple-list.sh | 2 +- unit-tests/string-with-spaces.sh | 2 +- 11 files changed, 11 insertions(+), 11 deletions(-) diff --git a/unit-tests/add.sh b/unit-tests/add.sh index 0dabb4c..552ea8d 100644 --- a/unit-tests/add.sh +++ b/unit-tests/add.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='5' -actual=`echo "(add 2 3)" | target/psse 2> /dev/null | head -1` +actual=`echo "(add 2 3)" | target/psse 2> /dev/null | head -2 | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/complex-list.sh b/unit-tests/complex-list.sh index 70ab629..d3728d8 100644 --- a/unit-tests/complex-list.sh +++ b/unit-tests/complex-list.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='(1 2 3 ("Fred") nil 77354)' -actual=`echo "'(1 2 3 (\"Fred\") () 77354)" | target/psse 2> /dev/null | head -1` +actual=`echo "'(1 2 3 (\"Fred\") () 77354)" | target/psse 2> /dev/null | head -2 | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/empty-list.sh.bash b/unit-tests/empty-list.sh.bash index 8e5d0b0..1e24452 100644 --- a/unit-tests/empty-list.sh.bash +++ b/unit-tests/empty-list.sh.bash @@ -7,7 +7,7 @@ # expected=nil -actual=`echo '()' | target/psse 2> /dev/null | head -1` +actual=`echo "'()" | target/psse 2> /dev/null | head -2 | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/empty-string.sh b/unit-tests/empty-string.sh index 24bcd7a..340fd1b 100644 --- a/unit-tests/empty-string.sh +++ b/unit-tests/empty-string.sh @@ -1,7 +1,7 @@ #!/bin/bash expected="\"\"" -actual=`echo '""' | target/psse 2> /dev/null | head -1` +actual=`echo '""' | target/psse 2> /dev/null | head -2 | tail -1` if [ "$expected" = "$actual" ] then diff --git a/unit-tests/fred.sh b/unit-tests/fred.sh index 62af33f..427c60d 100644 --- a/unit-tests/fred.sh +++ b/unit-tests/fred.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='"Fred"' -actual=`echo ${expected} | target/psse 2> /dev/null | head -1` +actual=`echo ${expected} | target/psse 2> /dev/null | head -2 | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/integer.sh b/unit-tests/integer.sh index 828eace..41b2da3 100644 --- a/unit-tests/integer.sh +++ b/unit-tests/integer.sh @@ -1,7 +1,7 @@ #!/bin/bash expected="354" -actual=`echo ${expected} | target/psse 2> /dev/null | head -1` +actual=`echo ${expected} | target/psse 2> /dev/null | head -2 | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/nil.sh b/unit-tests/nil.sh index 8e9aea6..de4ef57 100644 --- a/unit-tests/nil.sh +++ b/unit-tests/nil.sh @@ -1,7 +1,7 @@ #!/bin/bash expected=nil -actual=`echo 'nil' | target/psse 2> /dev/null | head -1` +actual=`echo 'nil' | target/psse 2> /dev/null | head -2 | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/quote.sh b/unit-tests/quote.sh index 6785966..bded011 100644 --- a/unit-tests/quote.sh +++ b/unit-tests/quote.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='Fred' -actual=`echo "'Fred" | target/psse 2> /dev/null | head -1` +actual=`echo "'Fred" | target/psse 2> /dev/null | head -2 | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/quoted-list.sh b/unit-tests/quoted-list.sh index 6ba50cc..24480c6 100644 --- a/unit-tests/quoted-list.sh +++ b/unit-tests/quoted-list.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='(123 (4 (5 nil)) Fred)' -actual=`echo "'(123 (4 (5 ())) Fred)" | target/psse 2> /dev/null | head -1` +actual=`echo "'(123 (4 (5 ())) Fred)" | target/psse 2> /dev/null | head -2 | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/simple-list.sh b/unit-tests/simple-list.sh index 35ed153..60492b9 100644 --- a/unit-tests/simple-list.sh +++ b/unit-tests/simple-list.sh @@ -1,7 +1,7 @@ #!/bin/bash expected="(1 2 3)" -actual=`echo "'(1 2 3)" | target/psse 2> /dev/null | head -1` +actual=`echo "'(1 2 3)" | target/psse 2> /dev/null | head -2 | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/string-with-spaces.sh b/unit-tests/string-with-spaces.sh index 53e00c0..384cc9f 100644 --- a/unit-tests/string-with-spaces.sh +++ b/unit-tests/string-with-spaces.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='"Strings should be able to include spaces (and other stuff)!"' -actual=`echo ${expected} | target/psse 2> /dev/null | head -1` +actual=`echo ${expected} | target/psse 2> /dev/null | head -2 | tail -1` if [ "${expected}" = "${actual}" ] then From f988147bb28c424f7be3a8ce90767ff1646a2a90 Mon Sep 17 00:00:00 2001 From: simon Date: Sat, 7 Oct 2017 17:13:53 +0100 Subject: [PATCH 21/27] Added 'make repl', just because it's an easy way to launch. --- .gitignore | 2 ++ Makefile | 4 ++++ 2 files changed, 6 insertions(+) diff --git a/.gitignore b/.gitignore index a3d5bf6..9bbbb3d 100644 --- a/.gitignore +++ b/.gitignore @@ -10,3 +10,5 @@ nbproject/ *~ src/\.#* + +*.log diff --git a/Makefile b/Makefile index 7916239..35c4627 100644 --- a/Makefile +++ b/Makefile @@ -28,4 +28,8 @@ test: clean: $(RM) $(TARGET) $(OBJS) $(DEPS) +repl: + $(TARGET) -p 2> psse.log + + -include $(DEPS) From ba4a31c25aca735fdd2f0ac34c47542b89891efc Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 15 Oct 2017 14:17:54 +0100 Subject: [PATCH 22/27] All tests passing except 'apply', which is genuinely broken; I'm not yet sure what's wrong. --- src/conspage.c | 30 ++++++++++++++++-------------- src/consspaceobject.c | 14 +++++--------- src/init.c | 4 ++-- src/lispops.c | 30 ++++++++++++++++++++++++++---- src/lispops.h | 8 ++++++++ src/stack.c | 2 +- unit-tests/apply.sh | 2 +- 7 files changed, 59 insertions(+), 31 deletions(-) diff --git a/src/conspage.c b/src/conspage.c index 2e4d90a..0805ee3 100644 --- a/src/conspage.c +++ b/src/conspage.c @@ -90,9 +90,9 @@ void make_cons_page( ) { initialised_cons_pages++; } else { - fprintf( stderr, - "FATAL: Failed to allocate memory for cons page %d\n", - initialised_cons_pages ); + fwprintf( stderr, + L"FATAL: Failed to allocate memory for cons page %d\n", + initialised_cons_pages ); exit( 1 ); } @@ -103,7 +103,7 @@ void make_cons_page( ) { */ void dump_pages( FILE * output ) { for ( int i = 0; i < initialised_cons_pages; i++ ) { - fprintf( output, "\nDUMPING PAGE %d\n", i ); + fwprintf( output, L"\nDUMPING PAGE %d\n", i ); for ( int j = 0; j < CONSPAGESIZE; j++ ) { dump_object( output, ( struct cons_pointer ) { @@ -123,19 +123,21 @@ void free_cell( struct cons_pointer pointer ) { if ( !check_tag( pointer, FREETAG ) ) { if ( cell->count == 0 ) { + fwprintf( stderr, L"Freeing cell\n" ); + dump_object( stderr, pointer ); strncpy( &cell->tag.bytes[0], FREETAG, 4 ); cell->payload.free.car = NIL; cell->payload.free.cdr = freelist; freelist = pointer; } else { - fprintf( stderr, - "Attempt to free cell with %d dangling references at page %d, offset %d\n", - cell->count, pointer.page, pointer.offset ); + fwprintf( stderr, + L"Attempt to free cell with %d dangling references at page %d, offset %d\n", + cell->count, pointer.page, pointer.offset ); } } else { - fprintf( stderr, - "Attempt to free cell which is already FREE at page %d, offset %d\n", - pointer.page, pointer.offset ); + fwprintf( stderr, + L"Attempt to free cell which is already FREE at page %d, offset %d\n", + pointer.page, pointer.offset ); } } @@ -166,12 +168,12 @@ struct cons_pointer allocate_cell( char *tag ) { cell->payload.cons.cdr = NIL; #ifdef DEBUG - fprintf( stderr, - "Allocated cell of type '%s' at %d, %d \n", tag, - result.page, result.offset ); + fwprintf( stderr, + L"Allocated cell of type '%s' at %d, %d \n", tag, + result.page, result.offset ); #endif } else { - fprintf( stderr, "WARNING: Allocating non-free cell!" ); + fwprintf( stderr, L"WARNING: Allocating non-free cell!" ); } } diff --git a/src/consspaceobject.c b/src/consspaceobject.c index 8a5371d..84c39f5 100644 --- a/src/consspaceobject.c +++ b/src/consspaceobject.c @@ -80,9 +80,8 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { 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); + cell.payload.cons.cdr.page, + cell.payload.cons.cdr.offset, cell.count ); break; case INTEGERTV: fwprintf( output, @@ -102,8 +101,7 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { L"\t\tString cell: character '%1c' (%1d) next at page %2d offset %3d, count %u\n", cell.payload.string.character, cell.payload.string.cdr.page, - cell.payload.string.cdr.offset, - cell.count ); + cell.payload.string.cdr.offset, cell.count ); fwprintf( output, L"\t\t value: " ); print( output, pointer ); fwprintf( output, L"\n" ); @@ -113,8 +111,7 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { L"\t\tSymbol cell: character '%1c' (%1d) next at page %2d offset %3d, count %u\n", cell.payload.string.character, cell.payload.string.cdr.page, - cell.payload.string.cdr.offset, - cell.count ); + cell.payload.string.cdr.offset, cell.count ); fwprintf( output, L"\t\t value:" ); print( output, pointer ); fwprintf( output, L"\n" ); @@ -208,8 +205,7 @@ struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) { */ struct cons_pointer make_special( struct cons_pointer src, struct cons_pointer ( *executable ) - ( struct stack_frame * frame, - struct cons_pointer env ) ) { + ( struct stack_frame * frame, struct cons_pointer env ) ) { struct cons_pointer pointer = allocate_cell( SPECIALTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); diff --git a/src/init.c b/src/init.c index 33e0a29..d39e707 100644 --- a/src/init.c +++ b/src/init.c @@ -30,8 +30,7 @@ void bind_function( char *name, struct cons_pointer ( *executable ) } void bind_special( char *name, struct cons_pointer ( *executable ) - ( struct cons_pointer s_expr, struct cons_pointer env, - struct stack_frame * frame ) ) { + ( struct stack_frame * frame, struct cons_pointer env ) ) { deep_bind( c_string_to_lisp_symbol( name ), make_special( NIL, executable ) ); } @@ -87,6 +86,7 @@ int main( int argc, char *argv[] ) { bind_function( "equal", &lisp_equal ); bind_function( "read", &lisp_read ); bind_function( "print", &lisp_print ); + bind_function( "type", &lisp_type ); bind_function( "add", &lisp_add ); bind_function( "multiply", &lisp_multiply ); diff --git a/src/lispops.c b/src/lispops.c index dc33db3..783432f 100644 --- a/src/lispops.c +++ b/src/lispops.c @@ -80,6 +80,7 @@ eval_cons( struct stack_frame *frame, struct cons_pointer env ) { struct stack_frame *fn_frame = make_empty_frame( frame, env ); fn_frame->arg[0] = c_car( frame->arg[0] ); + inc_ref( fn_frame->arg[0] ); struct cons_pointer fn_pointer = lisp_eval( fn_frame, env ); free_stack_frame( fn_frame ); @@ -187,6 +188,7 @@ lisp_apply( struct stack_frame *frame, struct cons_pointer env ) { struct stack_frame *fn_frame = make_empty_frame( frame, env ); fn_frame->arg[0] = frame->arg[0]; + inc_ref( fn_frame->arg[0] ); struct cons_pointer fn_pointer = lisp_eval( fn_frame, env ); free_stack_frame( fn_frame ); @@ -256,8 +258,7 @@ lisp_car( struct stack_frame *frame, struct cons_pointer env ) { result = make_string( cell.payload.string.character, NIL ); } else { struct cons_pointer message = - c_string_to_lisp_string - ( "Attempt to take CAR of non sequence" ); + c_string_to_lisp_string( "Attempt to take CAR of non sequence" ); result = lisp_throw( message, frame ); } @@ -281,8 +282,7 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer env ) { result = cell.payload.string.cdr; } else { struct cons_pointer message = - c_string_to_lisp_string - ( "Attempt to take CDR of non sequence" ); + c_string_to_lisp_string( "Attempt to take CDR of non sequence" ); result = lisp_throw( message, frame ); } @@ -333,6 +333,7 @@ lisp_read( struct stack_frame *frame, struct cons_pointer env ) { return read( input ); } + /** * (print expr) * (print expr write-stream) @@ -352,6 +353,27 @@ lisp_print( struct stack_frame *frame, struct cons_pointer env ) { return NIL; } + +/** + * Get the Lisp type of the single argument. + * @param frame My stack frame. + * @param env My environment (ignored). + * @return As a Lisp string, the tag of the object which is the argument. + */ +struct cons_pointer +lisp_type( struct stack_frame *frame, struct cons_pointer env ) { + char *buffer = malloc( TAGLENGTH + 1 ); + memset( buffer, 0, TAGLENGTH + 1 ); + struct cons_space_object cell = pointer2cell( frame->arg[0] ); + strncpy( buffer, cell.tag.bytes, TAGLENGTH ); + + struct cons_pointer result = c_string_to_lisp_string( buffer ); + free( buffer ); + + return result; +} + + /** * TODO: make this do something sensible somehow. */ diff --git a/src/lispops.h b/src/lispops.h index e808a1a..716fdf6 100644 --- a/src/lispops.h +++ b/src/lispops.h @@ -48,6 +48,14 @@ struct cons_pointer lisp_read( struct stack_frame *frame, struct cons_pointer env ); struct cons_pointer lisp_print( struct stack_frame *frame, struct cons_pointer env ); +/** + * Get the Lisp type of the single argument. + * @param frame My stack frame. + * @param env My environment (ignored). + * @return As a Lisp string, the tag of the object which is the argument. + */ +struct cons_pointer +lisp_type( struct stack_frame *frame, struct cons_pointer env ); /* * neither, at this stage, really diff --git a/src/stack.c b/src/stack.c index bed6307..1b887b1 100644 --- a/src/stack.c +++ b/src/stack.c @@ -84,8 +84,8 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous, struct stack_frame *arg_frame = make_empty_frame( previous, env ); arg_frame->arg[0] = cell.payload.cons.car; result->arg[i] = lisp_eval( arg_frame, env ); - free_stack_frame( arg_frame ); inc_ref( result->arg[i] ); + free_stack_frame( arg_frame ); args = cell.payload.cons.cdr; } diff --git a/unit-tests/apply.sh b/unit-tests/apply.sh index 1ee19b0..ea90436 100644 --- a/unit-tests/apply.sh +++ b/unit-tests/apply.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='1' -actual=`echo "(apply 'add '(1))"| target/psse 2> /dev/null | head -1` +actual=`echo "(apply add '(1))"| target/psse 2> /dev/null | head -1` if [ "${expected}" = "${actual}" ] then From 0685442e1a6b4098c572fba4b1fdeae38c9e8d9b Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 15 Oct 2017 14:31:57 +0100 Subject: [PATCH 23/27] Tidied up 'wide' printing. --- Makefile | 2 +- src/conspage.c | 4 ++-- src/read.c | 6 +++--- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/Makefile b/Makefile index 35c4627..c15c1e2 100644 --- a/Makefile +++ b/Makefile @@ -26,7 +26,7 @@ test: .PHONY: clean clean: - $(RM) $(TARGET) $(OBJS) $(DEPS) + $(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ repl: $(TARGET) -p 2> psse.log diff --git a/src/conspage.c b/src/conspage.c index 0805ee3..2d31cf6 100644 --- a/src/conspage.c +++ b/src/conspage.c @@ -63,7 +63,7 @@ void make_cons_page( ) { cell->count = MAXREFERENCE; cell->payload.free.car = NIL; cell->payload.free.cdr = NIL; - fprintf( stderr, "Allocated special cell NIL\n" ); + fwprintf( stderr, L"Allocated special cell NIL\n" ); } else if ( i == 1 ) { /* * initialise cell as T @@ -74,7 +74,7 @@ void make_cons_page( ) { 0, 1}; cell->payload.free.cdr = ( struct cons_pointer ) { 0, 1}; - fprintf( stderr, "Allocated special cell T\n" ); + fwprintf( stderr, L"Allocated special cell T\n" ); } } else { /* diff --git a/src/read.c b/src/read.c index 24d7ece..92f9f52 100644 --- a/src/read.c +++ b/src/read.c @@ -71,7 +71,7 @@ struct cons_pointer read_continuation( FILE * input, wint_t initial ) { } else if ( iswprint( c ) ) { result = read_symbol( input, c ); } else { - fprintf( stderr, "Unrecognised start of input character %c\n", c ); + fwprintf( stderr, L"Unrecognised start of input character %c\n", c ); } } @@ -88,7 +88,7 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) { bool seen_period = false; wint_t c; - fprintf( stderr, "read_number starting '%c' (%d)\n", initial, initial ); + fwprintf( stderr, L"read_number starting '%c' (%d)\n", initial, initial ); for ( c = initial; iswdigit( c ) || c == btowc( '.' ); c = fgetwc( input ) ) { @@ -137,7 +137,7 @@ struct cons_pointer read_list( FILE * input, wint_t initial ) { struct cons_pointer car = read_continuation( input, initial ); result = make_cons( car, read_list( input, fgetwc( input ) ) ); } else { - fprintf( stderr, "End of list detected\n" ); + fwprintf( stderr, L"End of list detected\n" ); } return result; From 89b4f093f98040f311f9581560d7254b14faa091 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 15 Oct 2017 15:14:34 +0100 Subject: [PATCH 24/27] Fixed bug which caused reader to infinite loop if symbol contained non-alnum. --- src/init.c | 3 +++ src/read.c | 7 ++++++- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/src/init.c b/src/init.c index d39e707..ac811c3 100644 --- a/src/init.c +++ b/src/init.c @@ -89,8 +89,11 @@ int main( int argc, char *argv[] ) { bind_function( "type", &lisp_type ); bind_function( "add", &lisp_add ); + bind_function( "+", &lisp_add ); bind_function( "multiply", &lisp_multiply ); + bind_function( "*", &lisp_multiply ); bind_function( "subtract", &lisp_subtract ); + bind_function( "-", &lisp_subtract ); /* * primitive special forms diff --git a/src/read.c b/src/read.c index 92f9f52..08e37f1 100644 --- a/src/read.c +++ b/src/read.c @@ -20,6 +20,7 @@ #include "consspaceobject.h" #include "integer.h" #include "intern.h" +#include "print.h" #include "read.h" #include "real.h" @@ -194,7 +195,7 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) { ungetwc( initial, input ); break; default: - if ( iswalnum( initial ) ) { + if ( iswprint( initial ) && ! iswblank( initial ) ) { result = make_symbol( initial, read_symbol( input, fgetwc( input ) ) ); } else { @@ -206,6 +207,10 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) { } break; } + + fputws(L"Read symbol '", stderr); + print(stderr, result); + fputws(L"'\n", stderr); return result; } From 8e7d1ab9138ba1153a884690690eb6c4fb663396 Mon Sep 17 00:00:00 2001 From: simon Date: Sun, 15 Oct 2017 17:01:03 +0100 Subject: [PATCH 25/27] More work on apply, also trying to read dotted pairs. --- src/lispops.c | 4 ++++ src/print.c | 2 +- src/read.c | 13 ++++++++++++- unit-tests/apply.sh | 2 +- 4 files changed, 18 insertions(+), 3 deletions(-) diff --git a/src/lispops.c b/src/lispops.c index 783432f..ff2e738 100644 --- a/src/lispops.c +++ b/src/lispops.c @@ -175,6 +175,10 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) { /** * (apply fn args) + * + * Special form. Apply the function which is the result of evaluating the + * first argoment to the list of arguments which is the result of evaluating + * the second argument */ struct cons_pointer lisp_apply( struct stack_frame *frame, struct cons_pointer env ) { diff --git a/src/print.c b/src/print.c index f66cf1b..d978bf0 100644 --- a/src/print.c +++ b/src/print.c @@ -41,7 +41,7 @@ void print_string( FILE * output, struct cons_pointer pointer ) { } /** - * Print a single list cell (cons cell). TODO: does not handle dotted pairs. + * Print a single list cell (cons cell). */ void print_list_contents( FILE * output, struct cons_pointer pointer, diff --git a/src/read.c b/src/read.c index 08e37f1..64cd547 100644 --- a/src/read.c +++ b/src/read.c @@ -67,7 +67,18 @@ struct cons_pointer read_continuation( FILE * input, wint_t initial ) { result = read_string( input, fgetwc( input ) ); break; default: - if ( iswdigit( c ) || c == '.' ) { + if ( c == '.' ) { + wint_t next = fgetwc( input ); + if ( iswdigit( next) ) { + ungetwc( next, input ); + result = read_number( input, c ); + } else if ( iswblank( next ) ) { + result = read_continuation(input, fgetwc( input)); + } else { + read_symbol( input, c ); + } + } + else if ( iswdigit( c ) ) { result = read_number( input, c ); } else if ( iswprint( c ) ) { result = read_symbol( input, c ); diff --git a/unit-tests/apply.sh b/unit-tests/apply.sh index ea90436..3483fb0 100644 --- a/unit-tests/apply.sh +++ b/unit-tests/apply.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='1' -actual=`echo "(apply add '(1))"| target/psse 2> /dev/null | head -1` +actual=`echo "(apply 'add '(1))"| target/psse 2> /dev/null | head -2 | tail -1` if [ "${expected}" = "${actual}" ] then From 685790df43f8edce2951c50c94307db87e7da701 Mon Sep 17 00:00:00 2001 From: simon Date: Sun, 15 Oct 2017 18:27:55 +0100 Subject: [PATCH 26/27] Apply works; all unit tests pass. --- src/init.c | 2 +- src/lispops.c | 47 +++++++++++++++++++++++++++-------------------- src/read.c | 24 +++++++++++++----------- src/stack.c | 17 +++++++++++++++++ src/stack.h | 8 ++++++++ 5 files changed, 66 insertions(+), 32 deletions(-) diff --git a/src/init.c b/src/init.c index ac811c3..f2a78e3 100644 --- a/src/init.c +++ b/src/init.c @@ -94,11 +94,11 @@ int main( int argc, char *argv[] ) { bind_function( "*", &lisp_multiply ); bind_function( "subtract", &lisp_subtract ); bind_function( "-", &lisp_subtract ); + bind_function( "apply", &lisp_apply ); /* * primitive special forms */ - bind_special( "apply", &lisp_apply ); bind_special( "eval", &lisp_eval ); bind_special( "quote", &lisp_quote ); diff --git a/src/lispops.c b/src/lispops.c index ff2e738..1c20529 100644 --- a/src/lispops.c +++ b/src/lispops.c @@ -73,9 +73,15 @@ struct cons_pointer c_cdr( struct cons_pointer arg ) { } - +/** + * Internal guts of apply. + * @param frame the stack frame, expected to have only one argument, a list + * comprising something that evaluates to a function and its arguments. + * @param env The evaluation environment. + * @return the result of evaluating the function with its arguments. + */ struct cons_pointer -eval_cons( struct stack_frame *frame, struct cons_pointer env ) { +c_apply( struct stack_frame *frame, struct cons_pointer env ) { struct cons_pointer result = NIL; struct stack_frame *fn_frame = make_empty_frame( frame, env ); @@ -143,9 +149,12 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) { struct cons_pointer result = frame->arg[0]; struct cons_space_object cell = pointer2cell( frame->arg[0] ); + fputws( L"Eval: ", stderr ); + dump_frame( stderr, frame ); + switch ( cell.tag.value ) { case CONSTV: - result = eval_cons( frame, env ); + result = c_apply( frame, env ); break; case SYMBOLTV: @@ -170,37 +179,35 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) { */ } + fputws( L"Eval returning ", stderr ); + print( stderr, result ); + fputws( L"\n", stderr ); + return result; } + /** * (apply fn args) * - * Special form. Apply the function which is the result of evaluating the + * function. Apply the function which is the result of evaluating the * first argoment to the list of arguments which is the result of evaluating * the second argument */ struct cons_pointer lisp_apply( struct stack_frame *frame, struct cons_pointer env ) { - struct cons_pointer result = NIL; + fputws( L"Apply: ", stderr ); + dump_frame( stderr, frame ); - if ( nilp( frame->arg[1] ) || !nilp( frame->arg[2] ) ) { - result = - lisp_throw( c_string_to_lisp_string( "(apply " ), - frame ); - } + frame->arg[0] = make_cons( frame->arg[0], frame->arg[1] ); + inc_ref( frame->arg[0] ); + frame->arg[1] = NIL; - struct stack_frame *fn_frame = make_empty_frame( frame, env ); - fn_frame->arg[0] = frame->arg[0]; - inc_ref( fn_frame->arg[0] ); - struct cons_pointer fn_pointer = lisp_eval( fn_frame, env ); - free_stack_frame( fn_frame ); + struct cons_pointer result = c_apply( frame, env ); - struct stack_frame *next_frame = - make_special_frame( frame, make_cons( fn_pointer, frame->arg[1] ), - env ); - result = eval_cons( next_frame, env ); - free_stack_frame( next_frame ); + fputws( L"Apply returning ", stderr ); + print( stderr, result ); + fputws( L"\n", stderr ); return result; } diff --git a/src/read.c b/src/read.c index 64cd547..b6cf93a 100644 --- a/src/read.c +++ b/src/read.c @@ -67,23 +67,25 @@ struct cons_pointer read_continuation( FILE * input, wint_t initial ) { result = read_string( input, fgetwc( input ) ); break; default: - if ( c == '.' ) { + if ( c == '.' ) { wint_t next = fgetwc( input ); - if ( iswdigit( next) ) { + if ( iswdigit( next ) ) { ungetwc( next, input ); result = read_number( input, c ); } else if ( iswblank( next ) ) { - result = read_continuation(input, fgetwc( input)); + /* dotted pair. TODO: this isn't right, we + * really need to backtrack up a level. */ + result = read_continuation( input, fgetwc( input ) ); } else { read_symbol( input, c ); } - } - else if ( iswdigit( c ) ) { + } else if ( iswdigit( c ) ) { result = read_number( input, c ); } else if ( iswprint( c ) ) { result = read_symbol( input, c ); } else { - fwprintf( stderr, L"Unrecognised start of input character %c\n", c ); + fwprintf( stderr, L"Unrecognised start of input character %c\n", + c ); } } @@ -206,7 +208,7 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) { ungetwc( initial, input ); break; default: - if ( iswprint( initial ) && ! iswblank( initial ) ) { + if ( iswprint( initial ) && !iswblank( initial ) ) { result = make_symbol( initial, read_symbol( input, fgetwc( input ) ) ); } else { @@ -218,10 +220,10 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) { } break; } - - fputws(L"Read symbol '", stderr); - print(stderr, result); - fputws(L"'\n", stderr); + + fputws( L"Read symbol '", stderr ); + print( stderr, result ); + fputws( L"'\n", stderr ); return result; } diff --git a/src/stack.c b/src/stack.c index 1b887b1..a5a301c 100644 --- a/src/stack.c +++ b/src/stack.c @@ -83,6 +83,7 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous, */ struct stack_frame *arg_frame = make_empty_frame( previous, env ); arg_frame->arg[0] = cell.payload.cons.car; + inc_ref( arg_frame->arg[0] ); result->arg[i] = lisp_eval( arg_frame, env ); inc_ref( result->arg[i] ); free_stack_frame( arg_frame ); @@ -143,6 +144,22 @@ void free_stack_frame( struct stack_frame *frame ) { free( frame ); } + +/** + * Dump a stackframe to this stream for debugging + * @param output the stream + * @param frame the frame + */ +void dump_frame( FILE * output, struct stack_frame *frame ) { + fputws( L"Dumping stack frame\n", output ); + for ( int arg = 0; arg < args_in_frame; arg++ ) { + fwprintf( output, L"Arg %d:", arg ); + print( output, frame->arg[arg] ); + fputws( L"\n", output ); + } +} + + /** * Fetch a pointer to the value of the local variable at this index. */ diff --git a/src/stack.h b/src/stack.h index f227ac3..3a7f0ad 100644 --- a/src/stack.h +++ b/src/stack.h @@ -37,6 +37,14 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous, struct cons_pointer args, struct cons_pointer env ); void free_stack_frame( struct stack_frame *frame ); + +/** + * Dump a stackframe to this stream for debugging + * @param output the stream + * @param frame the frame + */ +void dump_frame( FILE * output, struct stack_frame *frame ); + struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int n ); /** From 05854725c8af2a32d8757a8f46948a551d7d9399 Mon Sep 17 00:00:00 2001 From: simon Date: Sun, 15 Oct 2017 18:31:10 +0100 Subject: [PATCH 27/27] Upversion to 0.0.1 --- src/version.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/version.h b/src/version.h index 445229f..a629647 100644 --- a/src/version.h +++ b/src/version.h @@ -8,4 +8,4 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ -#define VERSION "0.0.0" +#define VERSION "0.0.1"