diff --git a/.gitignore b/.gitignore index 72eaddc..9bbbb3d 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,14 @@ -*.o - *.d +*.o + target/ + +nbproject/ + +*~ + +src/\.#* + +*.log diff --git a/Makefile b/Makefile index 144dbf5..c15c1e2 100644 --- a/Makefile +++ b/Makefile @@ -8,16 +8,28 @@ DEPS := $(OBJS:.o=.d) INC_DIRS := $(shell find $(SRC_DIRS) -type d) INC_FLAGS := $(addprefix -I,$(INC_DIRS)) +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) - $(CC) $(LDFLAGS) $(OBJS) -DVERSION=$(VERSION) -o $@ $(LOADLIBES) $(LDLIBS) +$(TARGET): $(OBJS) Makefile + $(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) + $(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ + +repl: + $(TARGET) -p 2> psse.log + -include $(DEPS) 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/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/conspage.c b/src/conspage.c index 22a53e3..2d31cf6 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,109 @@ 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; + fwprintf( stderr, L"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}; + fwprintf( stderr, L"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 { + fwprintf( stderr, + L"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++ ) { + fwprintf( output, L"\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 ) { + 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 { + 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 ); + } } - /** * Allocates a cell with the specified tag. Dangerous, primitive, low * level. @@ -140,48 +148,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; + +#ifdef DEBUG + fwprintf( stderr, + L"Allocated cell of type '%s' at %d, %d \n", tag, + result.page, result.offset ); +#endif + } else { + fwprintf( stderr, L"WARNING: Allocating non-free cell!" ); + } } - } - 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 { + 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 db7b13e..7b8b930 100644 --- a/src/conspage.h +++ b/src/conspage.h @@ -3,31 +3,40 @@ #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 - * 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. + * + * 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 /** - * 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]; + struct cons_space_object cell[CONSPAGESIZE]; }; - /** * The (global) pointer to the (global) freelist. Not sure whether this ultimately * belongs in this file. @@ -37,8 +46,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 @@ -46,8 +54,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 @@ -56,17 +63,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 f9420d6..84c39f5 100644 --- a/src/consspaceobject.c +++ b/src/consspaceobject.c @@ -11,150 +11,176 @@ #include #include #include -/* wide characters */ +/* + * wide characters + */ #include #include #include "conspage.h" #include "consspaceobject.h" +#include "print.h" /** * 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); - fprintf( output, - "\tDumping object at page %d, offset %d with tag %c%c%c%c (%d), count %u\n", - pointer.page, - pointer.offset, - cell.tag.bytes[0], - cell.tag.bytes[1], - cell.tag.bytes[2], - cell.tag.bytes[3], - cell.tag.value, - 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)) { - fprintf( output, - "\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); - } else if ( check_tag( pointer, FREETAG)) { - fprintf( output, "\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); - } 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); - }; + switch ( cell.tag.value ) { + case CONSTV: + fwprintf( output, + L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u\n", + cell.payload.cons.car.page, + cell.payload.cons.car.offset, + cell.payload.cons.cdr.page, + cell.payload.cons.cdr.offset, cell.count ); + break; + case INTEGERTV: + fwprintf( output, + 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, 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, count %u\n", + cell.payload.string.character, + cell.payload.string.cdr.page, + cell.payload.string.cdr.offset, cell.count ); + fwprintf( output, L"\t\t value: " ); + print( output, pointer ); + fwprintf( output, L"\n" ); + break; + case SYMBOLTV: + fwprintf( output, + 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 ); + fwprintf( output, L"\t\t value:" ); + print( output, pointer ); + fwprintf( output, L"\n" ); + break; + } } - /** * 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 { - fprintf( stderr, "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; + /* TODO: There's a problem here. Sometimes the offsets on + * strings are quite massively off. */ + 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; } /** @@ -163,56 +189,54 @@ 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 ) + ( struct stack_frame * frame, struct cons_pointer env ) ) { + 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; + 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 4729061..649ec4b 100644 --- a/src/consspaceobject.h +++ b/src/consspaceobject.h @@ -11,7 +11,9 @@ #include #include #include -/* wide characters */ +/* + * wide characters + */ #include #include @@ -67,6 +69,7 @@ * A real number. */ #define REALTAG "REAL" +#define REALTV 1279346002 /** * A special form - one whose arguments are not pre-evaluated but passed as a @@ -153,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)) @@ -200,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 /** @@ -212,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; }; /** @@ -236,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 ); }; /** @@ -247,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; }; /** @@ -257,7 +265,7 @@ struct free_payload { * optional bignum object. */ struct integer_payload { - long int value; + long int value; }; /** @@ -265,7 +273,7 @@ struct integer_payload { * precision, but I'm not sure of the detail. */ struct real_payload { - long double value; + long double value; }; /** @@ -279,19 +287,18 @@ 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 stack_frame *, + struct cons_pointer ); }; /** * payload of a read or write stream cell. */ struct stream_payload { - FILE * stream; + FILE *stream; }; /** @@ -301,124 +308,147 @@ 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 ( *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 ( *executable ) + ( struct stack_frame *, + struct cons_pointer ) ); /** * 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..23de51c 100644 --- a/src/equal.c +++ b/src/equal.c @@ -18,45 +18,83 @@ * 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 ) ); } +/** + * 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. */ -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 && 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)) { - 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); + 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 ); + 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 + * 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 ); + 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 + * 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..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 1cee833..f2a78e3 100644 --- a/src/init.c +++ b/src/init.c @@ -9,60 +9,109 @@ * 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 "peano.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)) { - 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( 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)); +void bind_special( char *name, struct cons_pointer ( *executable ) + ( struct stack_frame * frame, struct cons_pointer env ) ) { + deep_bind( c_string_to_lisp_symbol( name ), + make_special( NIL, executable ) ); } -int main (int argc, char *argv[]) { - fprintf( stderr, "Post scarcity software environment version %s\n", VERSION); - initialise_cons_pages(); +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; - /* 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); + while ( ( option = getopt( argc, argv, "pd" ) ) != -1 ) { + switch ( option ) { + case 'd': + dump_at_end = true; + break; + case 'p': + show_prompt = true; + break; + default: + fwprintf( stderr, L"Unexpected option %c\n", option ); + break; + } + } - /* 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); + if ( show_prompt ) { + fwprintf( stdout, + L"Post scarcity software environment version %s\n\n", + VERSION ); + } - /* primitive special forms */ - bind_special( "apply", &lisp_apply); - bind_special( "eval", &lisp_eval); - bind_special( "quote", &lisp_quote); + initialise_cons_pages( ); - 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)); + /* + * privileged variables (keywords) + */ - dump_pages(stderr); - - return(0); + 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 ); + 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( "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 ); + bind_function( "apply", &lisp_apply ); + + /* + * primitive special forms + */ + 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 ); + + repl( stdin, stdout, stderr, show_prompt ); + + if ( dump_at_end ) { + dump_pages( stdout ); + } + + return ( 0 ); } diff --git a/src/integer.c b/src/integer.c index 8f7b044..390594c 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,28 +20,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); +long 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 = cell->payload.integer.value * 1.0; + } 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( long int value ) { + struct cons_pointer result = allocate_cell( INTEGERTAG ); + struct cons_space_object *cell = &pointer2cell( result ); + cell->payload.integer.value = value; - return result; + dump_object( stderr, result ); + + return result; } - diff --git a/src/integer.h b/src/integer.h index 5d1df67..d44f34d 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); +long 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 3cc9379..31b7e2e 100644 --- a/src/intern.c +++ b/src/intern.c @@ -43,21 +43,22 @@ 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 +69,61 @@ 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..e940daa 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,28 +27,31 @@ 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 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 @@ -57,6 +59,6 @@ struct cons_pointer deep_bind( struct cons_pointer key, struct cons_pointer valu * with the value NIL. */ struct cons_pointer intern( struct cons_pointer key, - struct cons_pointer environment); + struct cons_pointer environment ); #endif diff --git a/src/lispops.c b/src/lispops.c index d85d9ac..1c20529 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,90 +49,86 @@ /** * 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; } + /** - * (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. + * 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 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 +c_apply( struct stack_frame *frame, struct cons_pointer env ) { + struct cons_pointer result = NIL; - return result; -} + 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 ); -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_space_object fn_cell = pointer2cell( fn_pointer ); + struct cons_pointer args = c_cdr( frame->arg[0] ); - 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 stack_frame *next = make_special_frame( frame, args, env ); + result = ( *fn_cell.payload.special.executable ) ( next, env ); + free_stack_frame( next ); + } + break; + + case FUNCTIONTV: + /* + * actually, this is apply + */ + { + struct stack_frame *next = make_stack_frame( frame, args, env ); + result = ( *fn_cell.payload.special.executable ) ( next, env ); + free_stack_frame( next ); + } + 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, 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,42 +144,75 @@ 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 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, my_frame); - break; + fputws( L"Eval: ", stderr ); + dump_frame( stderr, frame ); - 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); - } + switch ( cell.tag.value ) { + case CONSTV: + result = c_apply( frame, env ); + break; + + case SYMBOLTV: + { + 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, 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; + fputws( L"Eval returning ", stderr ); + print( stderr, result ); + fputws( L"\n", stderr ); + + return result; } + +/** + * (apply fn args) + * + * 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 ) { + fputws( L"Apply: ", stderr ); + dump_frame( stderr, frame ); + + frame->arg[0] = make_cons( frame->arg[0], frame->arg[1] ); + inc_ref( frame->arg[0] ); + frame->arg[1] = NIL; + + struct cons_pointer result = c_apply( frame, env ); + + fputws( L"Apply returning ", stderr ); + print( stderr, result ); + fputws( L"\n", stderr ); + + return result; +} + + /** * (quote a) * @@ -191,9 +220,9 @@ 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 stack_frame *frame, struct cons_pointer env ) { + return frame->arg[0]; } /** @@ -203,22 +232,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 +257,74 @@ 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 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.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 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,43 +333,67 @@ 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 ); } + /** * (print expr) * (print expr write-stream) * 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; +} + + +/** + * 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. */ -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 ) { + 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" ); - exit( 1); + exit( 1 ); } - diff --git a/src/lispops.h b/src/lispops.h index 597d67f..716fdf6 100644 --- a/src/lispops.h +++ b/src/lispops.h @@ -19,23 +19,46 @@ * 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 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 */ -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 ); +/** + * 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 */ -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/peano.c b/src/peano.c new file mode 100644 index 0000000..409abf9 --- /dev/null +++ b/src/peano.c @@ -0,0 +1,151 @@ +/** + * 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 + +#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 "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_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 current = pointer2cell( frame->arg[i] ); + + switch ( current.tag.value ) { + case INTEGERTV: + i_accumulator += current.payload.integer.value; + d_accumulator += numeric_value( frame->arg[i] ); + break; + 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 ); + } + + 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; +} + +/** + * 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; + break; + 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; +} + +/** + * 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 new file mode 100644 index 0000000..4650fe0 --- /dev/null +++ b/src/peano.h @@ -0,0 +1,49 @@ +/** + * 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_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 ); + +/** + * 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 +} +#endif +#endif /* PEANO_H */ diff --git a/src/print.c b/src/print.c index 36e0fa9..d978bf0 100644 --- a/src/print.c +++ b/src/print.c @@ -11,7 +11,9 @@ #include #include #include -/* wide characters */ +/* + * wide characters + */ #include #include @@ -20,84 +22,95 @@ #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) { - fputc( '"', output); - print_string_contents( output, pointer); - fputc( '"', 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. + * Print a single list cell (cons cell). */ -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) { - fputc( ' ', 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: - fprintf( output, " . "); - 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) { - fputc( '(', output); - print_list_contents( output, pointer, false); - fputc( ')', 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 : - 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]); - } + /* + * 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; + 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", + 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..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 d45b628..b6cf93a 100644 --- a/src/read.c +++ b/src/read.c @@ -8,34 +8,39 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#include #include #include -/* wide characters */ +/* + * wide characters + */ #include #include #include "consspaceobject.h" #include "integer.h" #include "intern.h" +#include "print.h" #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 ) ); } /** @@ -43,162 +48,189 @@ 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 ( c == '.' ) { + wint_t next = fgetwc( input ); + if ( iswdigit( next ) ) { + ungetwc( next, input ); + result = read_number( input, c ); + } else if ( iswblank( next ) ) { + /* 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 ) ) { + 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 ); + } } - } - 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 ) { + struct cons_pointer result = NIL; + 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); - - for (c = initial; iswdigit( c); c = fgetwc( input)) { - if ( c == '.') { - seen_period = true; - } else { - accumulator = accumulator * 10 + ((int)c - (int)'0'); + fwprintf( stderr, L"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' ); + + fwprintf( stderr, L"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 */ - ungetwc( c, input); + /* + * push back the character read which was not a digit + */ + ungetwc( c, input ); - return make_integer( accumulator); + if ( seen_period ) { + 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 { + result = make_integer( accumulator ); + } + + return result; } - /** * 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 { + fwprintf( stderr, L"End of list detected\n" ); + } - return result; + 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 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); - - 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; + + 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 ( iswprint( initial ) && !iswblank( initial ) ) { + result = + make_symbol( initial, read_symbol( input, fgetwc( input ) ) ); + } else { + result = NIL; + /* + * push back the character read + */ + ungetwc( initial, input ); + } + break; + } + + fputws( L"Read symbol '", stderr ); + print( stderr, result ); + fputws( L"'\n", stderr ); + + 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..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 new file mode 100644 index 0000000..5608b86 --- /dev/null +++ b/src/real.c @@ -0,0 +1,23 @@ +/* + * 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..6e4ed53 --- /dev/null +++ b/src/real.h @@ -0,0 +1,32 @@ +/* + * 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( long double value ); + +#ifdef __cplusplus +} +#endif +#endif /* REAL_H */ diff --git a/src/repl.c b/src/repl.c new file mode 100644 index 0000000..476aebe --- /dev/null +++ b/src/repl.c @@ -0,0 +1,47 @@ +/* + * 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" +#include "stack.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 ); + print( error_stream, input ); + + 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 ); + // 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/repl.h b/src/repl.h new file mode 100644 index 0000000..1a7b0e9 --- /dev/null +++ b/src/repl.h @@ -0,0 +1,34 @@ +/* + * 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/src/stack.c b/src/stack.c index 8894ff3..a5a301c 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,88 +23,160 @@ #include "consspaceobject.h" #include "conspage.h" #include "lispops.h" +#include "print.h" #include "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 *result = malloc( sizeof( struct stack_frame ) ); + /* + * TODO: later, pop a frame off a free-list of stack frames + */ + + 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; + } + + 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) { - /* 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 ) { + struct stack_frame *result = make_empty_frame( previous, env ); - result->previous = previous; + 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 ); - /* clearing the frame with memset would probably be slightly quicker, but - * this is clear. */ - result->more = NIL; - result->function = NIL; + /* + * TODO: if we were running on real massively parallel hardware, + * each arg except the first should be handed off to another + * processor to be evaled in parallel; but see notes here: + * https://github.com/simon-brooke/post-scarcity/wiki/parallelism + */ + struct stack_frame *arg_frame = make_empty_frame( 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 ); - 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; + 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; + 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 ) { + 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, + * stash them on more */ + struct cons_space_object cell = pointer2cell( args ); + + result->arg[i] = cell.payload.cons.car; + inc_ref( result->arg[i] ); + + args = cell.payload.cons.cdr; + } + result->more = args; + inc_ref( args ); + + 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 ); } + +/** + * 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. */ -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..3a7f0ad 100644 --- a/src/stack.h +++ b/src/stack.h @@ -24,13 +24,44 @@ #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); +/** + * 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 is defined in consspaceobject.h to break circularity - * TODO: refactor. */ +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 ); + +/** + * 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. + */ #endif diff --git a/src/version.h b/src/version.h index 3603e70..a629647 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" +#define VERSION "0.0.1" diff --git a/unit-tests/add.sh b/unit-tests/add.sh new file mode 100644 index 0000000..552ea8d --- /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 -2 | tail -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..3483fb0 --- /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 -2 | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" + exit 0 +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi diff --git a/unit-tests/complex-list.sh b/unit-tests/complex-list.sh index 6376fd6..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` +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 new file mode 100644 index 0000000..1e24452 --- /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 -2 | tail -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..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` +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 ebb03ac..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` +actual=`echo ${expected} | target/psse 2> /dev/null | head -2 | tail -1` if [ "${expected}" = "${actual}" ] then 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/integer.sh b/unit-tests/integer.sh index e2d41f1..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` +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 5449330..de4ef57 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 -2 | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/quote.sh b/unit-tests/quote.sh index 624bdfb..bded011 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` +expected='Fred' +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 eb4e7f3..24480c6 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` +expected='(123 (4 (5 nil)) Fred)' +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 9ee9719..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` +actual=`echo "'(1 2 3)" | target/psse 2> /dev/null | head -2 | tail -1` if [ "${expected}" = "${actual}" ] 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 diff --git a/unit-tests/string-with-spaces.sh b/unit-tests/string-with-spaces.sh index fb78b81..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` +actual=`echo ${expected} | target/psse 2> /dev/null | head -2 | tail -1` if [ "${expected}" = "${actual}" ] then