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

Standardised formatting.

Browse source
This commit is contained in:
simon 2017-08-14 20:18:13 +01:00
parent 31176e1f39
commit d7886550a6
25 changed files with 1131 additions and 949 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

9
Makefile
View file

@ -8,15 +8,22 @@ DEPS := $(OBJS:.o=.d)
INC_DIRS := $(shell find $(SRC_DIRS) -type d) INC_DIRS := $(shell find $(SRC_DIRS) -type d)
INC_FLAGS := $(addprefix -I,$(INC_DIRS)) INC_FLAGS := $(addprefix -I,$(INC_DIRS))
INDENT_FLAGS := -kr -nut -l79 -ts2
VERSION := "0.0.0" VERSION := "0.0.0"
CPPFLAGS ?= $(INC_FLAGS) -MMD -MP CPPFLAGS ?= $(INC_FLAGS) -MMD -MP
LDFLAGS := -lm LDFLAGS := -lm
$(TARGET): $(OBJS) $(TARGET): $(OBJS)
$(CC) $(LDFLAGS) $(OBJS) -DVERSION=$(VERSION) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS) $(CC) $(LDFLAGS) $(OBJS) -DVERSION=$(VERSION) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS)
format:
indent $(INDENT_FLAGS) $(SRCS) src/*.h
test:
bash ./unit-tests.sh
.PHONY: clean .PHONY: clean
clean: clean:
$(RM) $(TARGET) $(OBJS) $(DEPS) $(RM) $(TARGET) $(OBJS) $(DEPS)

210
src/conspage.c
View file

@ -19,8 +19,6 @@
#include "consspaceobject.h" #include "consspaceobject.h"
#include "conspage.h" #include "conspage.h"
/** /**
* Flag indicating whether conspage initialisation has been done. * Flag indicating whether conspage initialisation has been done.
*/ */
@ -40,99 +38,110 @@ struct cons_pointer freelist = NIL;
/** /**
* An array of pointers to cons pages. * 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. * 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 * 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. * cells 0 and 1 to the freelist but initialise them as NIL and T respectively.
*/ */
void make_cons_page() { void make_cons_page()
struct cons_page* result = malloc( sizeof( struct cons_page)); {
struct cons_page *result = malloc(sizeof(struct cons_page));
if ( result != NULL) { if (result != NULL) {
conspages[initialised_cons_pages] = result; conspages[initialised_cons_pages] = result;
for (int i = 0; i < CONSPAGESIZE; i++) { for (int i = 0; i < CONSPAGESIZE; i++) {
struct cons_space_object * cell = &conspages[initialised_cons_pages]->cell[i]; struct cons_space_object *cell =
if ( initialised_cons_pages == 0 && i < 2) { &conspages[initialised_cons_pages]->cell[i];
if ( i == 0) { if (initialised_cons_pages == 0 && i < 2) {
/* initialise cell as NIL */ if (i == 0) {
strncpy( &cell->tag.bytes[0], NILTAG, TAGLENGTH); /*
cell->count = MAXREFERENCE; * initialise cell as NIL
cell->payload.free.car = NIL; */
cell->payload.free.cdr = NIL; strncpy(&cell->tag.bytes[0], NILTAG, TAGLENGTH);
fprintf( stderr, "Allocated special cell NIL\n"); cell->count = MAXREFERENCE;
} else if ( i == 1) { cell->payload.free.car = NIL;
/* initialise cell as T */ cell->payload.free.cdr = NIL;
strncpy( &cell->tag.bytes[0], TRUETAG, TAGLENGTH); fprintf(stderr, "Allocated special cell NIL\n");
cell->count = MAXREFERENCE; } else if (i == 1) {
cell->payload.free.car = (struct cons_pointer){ 0, 1}; /*
cell->payload.free.cdr = (struct cons_pointer){ 0, 1}; * initialise cell as T
fprintf( stderr, "Allocated special cell T\n"); */
strncpy(&cell->tag.bytes[0], TRUETAG, TAGLENGTH);
cell->count = MAXREFERENCE;
cell->payload.free.car = (struct cons_pointer) {
0, 1};
cell->payload.free.cdr = (struct cons_pointer) {
0, 1};
fprintf(stderr, "Allocated special cell T\n");
}
} else {
/*
* otherwise, standard initialisation
*/
strncpy(&cell->tag.bytes[0], FREETAG, TAGLENGTH);
cell->payload.free.car = NIL;
cell->payload.free.cdr = freelist;
freelist.page = initialised_cons_pages;
freelist.offset = i;
}
} }
} else {
/* otherwise, standard initialisation */ initialised_cons_pages++;
strncpy( &cell->tag.bytes[0], FREETAG, TAGLENGTH); } else {
cell->payload.free.car = NIL; fprintf(stderr,
cell->payload.free.cdr = freelist; "FATAL: Failed to allocate memory for cons page %d\n",
freelist.page = initialised_cons_pages; initialised_cons_pages);
freelist.offset = i; 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. * dump the allocated pages to this output stream.
*/ */
void dump_pages( FILE* output) { void dump_pages(FILE * output)
for ( int i = 0; i < initialised_cons_pages; i++) { {
fprintf( output, "\nDUMPING PAGE %d\n", i); for (int i = 0; i < initialised_cons_pages; i++) {
fprintf(output, "\nDUMPING PAGE %d\n", i);
for ( int j = 0; j < CONSPAGESIZE; j++) { for (int j = 0; j < CONSPAGESIZE; j++) {
dump_object( output, (struct cons_pointer){i, j}); dump_object(output, (struct cons_pointer) {
i, j});
}
} }
}
} }
/** /**
* Frees the cell at the specified pointer. Dangerous, primitive, low * Frees the cell at the specified pointer. Dangerous, primitive, low
* level. * level.
* *
* @pointer the cell to free * @pointer the cell to free
*/ */
void free_cell(struct cons_pointer pointer) { void free_cell(struct cons_pointer pointer)
struct cons_space_object* cell = &pointer2cell( pointer); {
struct cons_space_object *cell = &pointer2cell(pointer);
if ( !check_tag(pointer, FREETAG)) { if (!check_tag(pointer, FREETAG)) {
if ( cell->count == 0) { if (cell->count == 0) {
strncpy( &cell->tag.bytes[0], FREETAG, 4); strncpy(&cell->tag.bytes[0], FREETAG, 4);
cell->payload.free.car = NIL; cell->payload.free.car = NIL;
cell->payload.free.cdr = freelist; cell->payload.free.cdr = freelist;
freelist = pointer; freelist = pointer;
} else { } else {
fprintf( stderr, fprintf(stderr,
"Attempt to free cell with %d dangling references at page %d, offset %d\n", "Attempt to free cell with %d dangling references at page %d, offset %d\n",
cell->count, pointer.page, pointer.offset); cell->count, pointer.page, pointer.offset);
} }
} else { } else {
fprintf( stderr, fprintf(stderr,
"Attempt to free cell which is already FREE at page %d, offset %d\n", "Attempt to free cell which is already FREE at page %d, offset %d\n",
pointer.page, pointer.offset); pointer.page, pointer.offset);
} }
} }
/** /**
* Allocates a cell with the specified tag. Dangerous, primitive, low * Allocates a cell with the specified tag. Dangerous, primitive, low
* level. * level.
@ -140,48 +149,51 @@ void free_cell(struct cons_pointer pointer) {
* @param tag the tag of the cell to allocate - must be a valid cons space tag. * @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. * @return the cons pointer which refers to the cell allocated.
*/ */
struct cons_pointer allocate_cell( char* tag) { struct cons_pointer allocate_cell(char *tag)
struct cons_pointer result = freelist; {
struct cons_pointer result = freelist;
if ( result.page == NIL.page && result.offset == NIL.offset) { if (result.page == NIL.page && result.offset == NIL.offset) {
make_cons_page(); make_cons_page();
result = allocate_cell( tag); 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);
} else { } else {
fprintf( stderr, "WARNING: Allocating non-free cell!"); struct cons_space_object *cell = &pointer2cell(result);
if (strncmp(&cell->tag.bytes[0], FREETAG, TAGLENGTH) == 0) {
freelist = cell->payload.free.cdr;
strncpy(&cell->tag.bytes[0], tag, 4);
cell->count = 0;
cell->payload.cons.car = NIL;
cell->payload.cons.cdr = NIL;
fprintf(stderr,
"Allocated cell of type '%s' at %d, %d \n", tag,
result.page, result.offset);
dump_object(stderr, result);
} else {
fprintf(stderr, "WARNING: Allocating non-free cell!");
}
} }
}
return result; return result;
} }
/** /**
* initialise the cons page system; to be called exactly once during startup. * initialise the cons page system; to be called exactly once during startup.
*/ */
void initialise_cons_pages() { void initialise_cons_pages()
if ( conspageinitihasbeencalled == false) { {
for (int i = 0; i < NCONSPAGES; i++) { if (conspageinitihasbeencalled == false) {
conspages[i] = (struct cons_page *) NULL; for (int i = 0; i < NCONSPAGES; i++) {
} conspages[i] = (struct cons_page *) NULL;
}
make_cons_page(); make_cons_page();
conspageinitihasbeencalled = true; conspageinitihasbeencalled = true;
} else { } else {
fprintf( stderr, "WARNING: conspageinit() called a second or subsequent time\n"); fprintf(stderr,
} "WARNING: conspageinit() called a second or subsequent time\n");
}
} }

13
src/conspage.h
View file

@ -3,7 +3,6 @@
#ifndef __conspage_h #ifndef __conspage_h
#define __conspage_h #define __conspage_h
/** /**
* the number of cons cells on a cons page. The maximum value this can be (and consequently, * 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 * the size which, by version 1, it will default to) is the maximum value of an unsigned 32
@ -24,10 +23,9 @@
* my current view is that that's probably unneccessary. * my current view is that that's probably unneccessary.
*/ */
struct cons_page { 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 * The (global) pointer to the (global) freelist. Not sure whether this ultimately
* belongs in this file. * belongs in this file.
@ -37,8 +35,7 @@ extern struct cons_pointer freelist;
/** /**
* An array of pointers to cons pages. * 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 * Frees the cell at the specified pointer. Dangerous, primitive, low
@ -48,7 +45,6 @@ extern struct cons_page* conspages[NCONSPAGES];
*/ */
void free_cell(struct cons_pointer pointer); void free_cell(struct cons_pointer pointer);
/** /**
* Allocates a cell with the specified tag. Dangerous, primitive, low * Allocates a cell with the specified tag. Dangerous, primitive, low
* level. * level.
@ -56,8 +52,7 @@ void free_cell(struct cons_pointer pointer);
* @param tag the tag of the cell to allocate - must be a valid cons space tag. * @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. * @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. * initialise the cons page system; to be called exactly once during startup.
@ -67,6 +62,6 @@ void initialise_cons_pages();
/** /**
* dump the allocated pages to this output stream. * dump the allocated pages to this output stream.
*/ */
void dump_pages( FILE* output); void dump_pages(FILE * output);
#endif #endif

246
src/consspaceobject.c
View file

@ -11,7 +11,9 @@
#include <stdint.h> #include <stdint.h>
#include <stdlib.h> #include <stdlib.h>
#include <string.h> #include <string.h>
/* wide characters */ /*
* wide characters
*/
#include <wchar.h> #include <wchar.h>
#include <wctype.h> #include <wctype.h>
@ -21,143 +23,145 @@
/** /**
* Check that the tag on the cell at this pointer is this tag * 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)
struct cons_space_object cell = pointer2cell(pointer); {
return strncmp( &cell.tag.bytes[0], tag, TAGLENGTH) == 0; 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. * increment the reference count of the object at this cons pointer.
* *
* You can't roll over the reference count. Once it hits the maximum * You can't roll over the reference count. Once it hits the maximum
* value you cannot increment further. * value you cannot increment further.
*/ */
void inc_ref( struct cons_pointer pointer) { void inc_ref(struct cons_pointer pointer)
struct cons_space_object* cell = &pointer2cell( pointer); {
struct cons_space_object *cell = &pointer2cell(pointer);
if (cell->count < MAXREFERENCE) { if (cell->count < MAXREFERENCE) {
cell->count ++; cell->count++;
} }
} }
/** /**
* Decrement the reference count of the object at this cons pointer. * Decrement the reference count of the object at this cons pointer.
* *
* If a count has reached MAXREFERENCE it cannot be decremented. * If a count has reached MAXREFERENCE it cannot be decremented.
* If a count is decremented to zero the cell should be freed. * If a count is decremented to zero the cell should be freed.
*/ */
void dec_ref( struct cons_pointer pointer) { void dec_ref(struct cons_pointer pointer)
struct cons_space_object* cell = &pointer2cell( pointer); {
struct cons_space_object *cell = &pointer2cell(pointer);
if (cell->count <= MAXREFERENCE) { if (cell->count <= MAXREFERENCE) {
cell->count --; cell->count--;
if (cell->count == 0) { if (cell->count == 0) {
free_cell( pointer); free_cell(pointer);
}
} }
}
} }
/** /**
* dump the object at this cons_pointer to this output stream. * 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_space_object cell = pointer2cell(pointer); {
fwprintf( output, struct cons_space_object cell = pointer2cell(pointer);
L"\tDumping %c%c%c%c (%d) at page %d, offset %d count %u\n", fwprintf(output,
cell.tag.bytes[0], L"\tDumping %c%c%c%c (%d) at page %d, offset %d count %u\n",
cell.tag.bytes[1], cell.tag.bytes[0],
cell.tag.bytes[2], cell.tag.bytes[1],
cell.tag.bytes[3], cell.tag.bytes[2],
cell.tag.value, cell.tag.bytes[3],
pointer.page, cell.tag.value, pointer.page, pointer.offset, cell.count);
pointer.offset,
cell.count);
if ( check_tag(pointer, CONSTAG)) { if (check_tag(pointer, CONSTAG)) {
fwprintf( output, fwprintf(output,
L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d\n", L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d\n",
cell.payload.cons.car.page, cell.payload.cons.car.offset, cell.payload.cons.car.page,
cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset); cell.payload.cons.car.offset,
} else if ( check_tag(pointer, INTEGERTAG)) { cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset);
fwprintf( output, } else if (check_tag(pointer, INTEGERTAG)) {
L"\t\tInteger cell: value %ld\n", fwprintf(output,
cell.payload.integer.value); L"\t\tInteger cell: value %ld\n", cell.payload.integer.value);
} else if ( check_tag( pointer, FREETAG)) { } else if (check_tag(pointer, FREETAG)) {
fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n", fwprintf(output, L"\t\tFree cell: next at page %d offset %d\n",
cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset); cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset);
} else if ( check_tag(pointer, REALTAG)) { } else if (check_tag(pointer, REALTAG)) {
fwprintf( output, L"\t\tReal cell: value %Lf\n", cell.payload.real.value); fwprintf(output, L"\t\tReal cell: value %Lf\n",
} else if ( check_tag( pointer, STRINGTAG)) { cell.payload.real.value);
fwprintf( output, } else if (check_tag(pointer, STRINGTAG)) {
L"String cell: character '%1c' (%1d) next at page %2d offset %3d\n", fwprintf(output,
cell.payload.string.character, cell.payload.string.cdr.page, L"String cell: character '%1c' (%1d) next at page %2d offset %3d\n",
cell.payload.string.cdr.offset); cell.payload.string.character,
} cell.payload.string.cdr.page, cell.payload.string.cdr.offset);
}
} }
/** /**
* Construct a cons cell from this pair of pointers. * Construct a cons cell from this pair of pointers.
*/ */
struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer cdr) { struct cons_pointer make_cons(struct cons_pointer car, struct cons_pointer cdr)
struct cons_pointer pointer = NIL; {
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(car);
inc_ref(cdr); inc_ref(cdr);
cell->payload.cons.car = car; cell->payload.cons.car = car;
cell->payload.cons.cdr = cdr; cell->payload.cons.cdr = cdr;
return pointer; return pointer;
} }
/** /**
* Construct a cell which points to an executable Lisp special form. * Construct a cell which points to an executable Lisp special form.
*/ */
struct cons_pointer make_function( struct cons_pointer src, struct cons_pointer
struct cons_pointer (*executable) make_function(struct cons_pointer src, struct cons_pointer (*executable)
(struct stack_frame*, struct cons_pointer)) { (struct stack_frame *, struct cons_pointer))
struct cons_pointer pointer = allocate_cell( FUNCTIONTAG); {
struct cons_space_object* cell = &pointer2cell(pointer); struct cons_pointer pointer = allocate_cell(FUNCTIONTAG);
struct cons_space_object *cell = &pointer2cell(pointer);
cell->payload.function.source = src; cell->payload.function.source = src;
cell->payload.function.executable = executable; cell->payload.function.executable = executable;
return pointer; return pointer;
} }
/** /**
* Construct a string from this character (which later will be UTF) and * 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 * 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 * has one character and a pointer to the next; in the last cell the
* pointer to next is NIL. * pointer to next is NIL.
*/ */
struct cons_pointer make_string_like_thing( wint_t c, struct cons_pointer
struct cons_pointer tail, make_string_like_thing(wint_t c, struct cons_pointer tail, char *tag)
char* tag) { {
struct cons_pointer pointer = NIL; 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);
inc_ref(tail); if (check_tag(tail, tag) || check_tag(tail, NILTAG)) {
cell->payload.string.character = c; pointer = allocate_cell(tag);
cell->payload.string.cdr.page = tail.page; struct cons_space_object *cell = &pointer2cell(pointer);
cell->payload.string.cdr.offset = tail.offset;
} else { inc_ref(tail);
fwprintf( stderr, L"Warning: only NIL and %s can be appended to %s\n", cell->payload.string.character = c;
tag, tag); cell->payload.string.cdr.page = tail.page;
} cell->payload.string.cdr.offset = tail.offset;
} else {
return pointer; fwprintf(stderr,
L"Warning: only NIL and %s can be appended to %s\n",
tag, tag);
}
return pointer;
} }
/** /**
@ -166,56 +170,68 @@ struct cons_pointer make_string_like_thing( wint_t c,
* has one character and a pointer to the next; in the last cell the * has one character and a pointer to the next; in the last cell the
* pointer to next is NIL. * 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)
return make_string_like_thing( c, tail, STRINGTAG); {
return make_string_like_thing(c, tail, STRINGTAG);
} }
/** /**
* Construct a symbol from this character and this tail. * Construct a symbol from this character and this tail.
*/ */
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 make_string_like_thing( c, tail, SYMBOLTAG); {
return make_string_like_thing(c, tail, SYMBOLTAG);
} }
/** /**
* Construct a cell which points to an executable Lisp special form. * Construct a cell which points to an executable Lisp special form.
*/ */
struct cons_pointer make_special( struct cons_pointer src, struct cons_pointer
struct cons_pointer (*executable) 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);
cell->payload.special.source = src;
cell->payload.special.executable = executable;
return pointer;
(struct cons_pointer s_expr,
struct cons_pointer env, struct stack_frame * frame))
{
struct cons_pointer pointer = allocate_cell(SPECIALTAG);
struct cons_space_object *cell = &pointer2cell(pointer);
cell->payload.special.source = src;
cell->payload.special.executable = executable;
return pointer;
} }
/** /**
* Return a lisp string representation of this old skool ASCII string. * Return a lisp string representation of this old skool ASCII string.
*/ */
struct cons_pointer c_string_to_lisp_string( char* string) { struct cons_pointer c_string_to_lisp_string(char *string)
struct cons_pointer result = NIL; {
struct cons_pointer result = NIL;
for ( int i = strlen( string); i > 0; i--) { for (int i = strlen(string); i > 0; i--) {
result = make_string( (wint_t)string[ i - 1], result); result = make_string((wint_t) string[i - 1], result);
} }
return result; return result;
} }
/** /**
* Return a lisp symbol representation of this old skool ASCII string. * Return a lisp symbol representation of this old skool ASCII string.
*/ */
struct cons_pointer c_string_to_lisp_symbol( char* symbol) { struct cons_pointer c_string_to_lisp_symbol(char *symbol)
struct cons_pointer result = NIL; {
struct cons_pointer result = NIL;
for ( int i = strlen( symbol); i > 0; i--) { for (int i = strlen(symbol); i > 0; i--) {
result = make_symbol( (wint_t)symbol[ i - 1], result); result = make_symbol((wint_t) symbol[i - 1], result);
} }
return result; return result;
} }

227
src/consspaceobject.h
View file

@ -11,7 +11,9 @@
#include <stdbool.h> #include <stdbool.h>
#include <stdint.h> #include <stdint.h>
#include <stdio.h> #include <stdio.h>
/* wide characters */ /*
* wide characters
*/
#include <wchar.h> #include <wchar.h>
#include <wctype.h> #include <wctype.h>
@ -201,11 +203,14 @@
* An indirect pointer to a cons cell * An indirect pointer to a cons cell
*/ */
struct cons_pointer { struct cons_pointer {
uint32_t page; /* the index of the page on which this cell resides */ uint32_t page; /* the index of the page on which this cell
uint32_t offset; /* the index of the cell within the page */ * 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 #define args_in_frame 8
/** /**
@ -213,20 +218,21 @@ struct cons_pointer {
* here to avoid circularity. TODO: refactor. * here to avoid circularity. TODO: refactor.
*/ */
struct stack_frame { struct stack_frame {
struct stack_frame* previous; /* the previous frame */ struct stack_frame *previous; /* the previous frame */
struct cons_pointer arg[args_in_frame]; struct cons_pointer arg[args_in_frame];
/* first 8 arument bindings */ /*
struct cons_pointer more; /* list of any further argument * first 8 arument bindings
* bindings */ */
struct cons_pointer function; /* the function to be called */ struct cons_pointer more; /* list of any further argument bindings */
struct cons_pointer function; /* the function to be called */
}; };
/** /**
* payload of a cons cell. * payload of a cons cell.
*/ */
struct cons_payload { struct cons_payload {
struct cons_pointer car; struct cons_pointer car;
struct cons_pointer cdr; struct cons_pointer cdr;
}; };
/** /**
@ -237,10 +243,11 @@ struct cons_payload {
* (representing its stack frame) and a cons pointer (representing its * (representing its stack frame) and a cons pointer (representing its
* environment) as arguments and returns a cons pointer (representing its * environment) as arguments and returns a cons pointer (representing its
* result). * result).
*/ */
struct function_payload { struct function_payload {
struct cons_pointer source; struct cons_pointer source;
struct cons_pointer (*executable)(struct stack_frame*, struct cons_pointer); struct cons_pointer (*executable) (struct stack_frame *,
struct cons_pointer);
}; };
/** /**
@ -248,8 +255,8 @@ struct function_payload {
* but it may not be so in future. * but it may not be so in future.
*/ */
struct free_payload { struct free_payload {
struct cons_pointer car; struct cons_pointer car;
struct cons_pointer cdr; struct cons_pointer cdr;
}; };
/** /**
@ -258,7 +265,7 @@ struct free_payload {
* optional bignum object. * optional bignum object.
*/ */
struct integer_payload { struct integer_payload {
long int value; long int value;
}; };
/** /**
@ -266,7 +273,7 @@ struct integer_payload {
* precision, but I'm not sure of the detail. * precision, but I'm not sure of the detail.
*/ */
struct real_payload { struct real_payload {
long double value; long double value;
}; };
/** /**
@ -280,19 +287,19 @@ struct real_payload {
* *
* NOTE that this means that special forms do not appear on the lisp stack, * NOTE that this means that special forms do not appear on the lisp stack,
* which may be confusing. TODO: think about this. * which may be confusing. TODO: think about this.
*/ */
struct special_payload { struct special_payload {
struct cons_pointer source; struct cons_pointer source;
struct cons_pointer (*executable)(struct cons_pointer s_expr, struct cons_pointer (*executable) (struct cons_pointer s_expr,
struct cons_pointer env, struct cons_pointer env,
struct stack_frame* frame); struct stack_frame * frame);
}; };
/** /**
* payload of a read or write stream cell. * payload of a read or write stream cell.
*/ */
struct stream_payload { struct stream_payload {
FILE * stream; FILE *stream;
}; };
/** /**
@ -302,124 +309,164 @@ struct stream_payload {
* payload of a string cell. * payload of a string cell.
*/ */
struct string_payload { struct string_payload {
wint_t character; /* the actual character stored in this cell */ wint_t character; /* the actual character stored in this cell */
uint32_t padding; /* unused padding to word-align the cdr */ uint32_t padding; /* unused padding to word-align the cdr */
struct cons_pointer cdr; struct cons_pointer cdr;
}; };
struct vectorp_payload { struct vectorp_payload {
union { union {
char bytes[TAGLENGTH]; /* the tag (type) of the vector-space char bytes[TAGLENGTH]; /* the tag (type) of the
* object this cell points to, considered * vector-space object this cell
* as bytes. NOTE that the vector space * points to, considered as bytes.
* object should itself have the identical tag. */ * NOTE that the vector space object
uint32_t value; /* the tag considered as a number */ * should itself have the identical
} tag; * tag. */
uint64_t address; /* the address of the actual vector space uint32_t value; /* the tag considered as a number */
* object (TODO: will change when I actually } tag;
* implement vector space) */ 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. * an object in cons space.
*/ */
struct cons_space_object { struct cons_space_object {
union { union {
char bytes[TAGLENGTH]; /* the tag (type) of this cell, considered as bytes */ char bytes[TAGLENGTH]; /* the tag (type) of this cell,
uint32_t value; /* the tag considered as a number */ * considered as bytes */
} tag; uint32_t value; /* the tag considered as a number */
uint32_t count; /* the count of the number of references to this cell */ } tag;
struct cons_pointer access; /* cons pointer to the access control list of this cell */ uint32_t count; /* the count of the number of references to
union { * this cell */
/* if tag == CONSTAG */ struct cons_pointer access; /* cons pointer to the access control list of
struct cons_payload cons; * this cell */
/* if tag == FREETAG */ union {
struct free_payload free; /*
/* if tag == FUNCTIONTAG */ * if tag == CONSTAG
struct function_payload function; */
/* if tag == INTEGERTAG */ struct cons_payload cons;
struct integer_payload integer; /*
/* if tag == NILTAG; we'll treat the special cell NIL as just a cons */ * if tag == FREETAG
struct cons_payload nil; */
/* if tag == READTAG || tag == WRITETAG */ struct free_payload free;
struct stream_payload stream; /*
/* if tag == REALTAG */ * if tag == FUNCTIONTAG
struct real_payload real; */
/* if tag == SPECIALTAG */ struct function_payload function;
struct special_payload special; /*
/* if tag == STRINGTAG || tag == SYMBOLTAG */ * if tag == INTEGERTAG
struct string_payload string; */
/* if tag == TRUETAG; we'll treat the special cell T as just a cons */ struct integer_payload integer;
struct cons_payload t; /*
/* if tag == VECTORPTAG */ * if tag == NILTAG; we'll treat the special cell NIL as just a cons
struct vectorp_payload vectorp; */
} payload; 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 * 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 * 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 * 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. * 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. * Construct a cell which points to an executable Lisp special form.
*/ */
struct cons_pointer make_function( struct cons_pointer src, struct cons_pointer make_function(struct cons_pointer src,
struct cons_pointer (*executable) struct cons_pointer (*executable)
(struct stack_frame*, struct cons_pointer));
(struct stack_frame *,
struct cons_pointer));
/** /**
* Construct a cell which points to an executable Lisp special form. * Construct a cell which points to an executable Lisp special form.
*/ */
struct cons_pointer make_special( struct cons_pointer src, struct cons_pointer make_special(struct cons_pointer src,
struct cons_pointer (*executable) struct cons_pointer (*executable)
(struct cons_pointer s_expr,
struct cons_pointer env,
struct stack_frame* frame));
(struct cons_pointer s_expr,
struct cons_pointer env,
struct stack_frame * frame));
/** /**
* Construct a string from this character and this tail. A string is * 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 * 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. * 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 * Construct a symbol from this character and this tail. A symbol is identical
* to a string except for having a different tag. * 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. * 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. * 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 #endif

72
src/equal.c
View file

@ -18,45 +18,55 @@
* Shallow, and thus cheap, equality: true if these two objects are * Shallow, and thus cheap, equality: true if these two objects are
* the same object, else false. * 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)
return ((a.page == b.page) && (a.offset == b.offset)); {
return ((a.page == b.page) && (a.offset == b.offset));
} }
/** /**
* Deep, and thus expensive, equality: true if these two objects have * Deep, and thus expensive, equality: true if these two objects have
* identical structure, else false. * identical structure, else false.
*/ */
bool equal( struct cons_pointer a, struct cons_pointer b) { bool equal(struct cons_pointer a, struct cons_pointer b)
bool result = eq( a, b); {
bool result = eq(a, b);
if ( ! result) { if (!result) {
struct cons_space_object* cell_a = &pointer2cell( a); struct cons_space_object *cell_a = &pointer2cell(a);
struct cons_space_object* cell_b = &pointer2cell( b); struct cons_space_object *cell_b = &pointer2cell(b);
if ( consp( a) && consp( b)) { if (consp(a) && consp(b)) {
result = equal( cell_a->payload.cons.car, cell_b->payload.cons.car) && result = equal(cell_a->payload.cons.car, cell_b->payload.cons.car)
equal( cell_a->payload.cons.cdr, cell_b->payload.cons.cdr); && equal(cell_a->payload.cons.cdr, cell_b->payload.cons.cdr);
} else if ( stringp( a) && stringp( b)) { } 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 * slightly complex because a string may or may not have a '\0'
* the empty string will. */ * cell at the end, but I'll ignore that for now. I think in
result = cell_a->payload.string.character == cell_b->payload.string.character && * practice only the empty string will.
equal( cell_a->payload.string.cdr, cell_b->payload.string.cdr); */
} else if ( numberp( a) && numberp( b)) { result =
double num_a = numeric_value( a); cell_a->payload.string.character ==
double num_b = numeric_value( b); cell_b->payload.string.character
double max = fabs( num_a) > fabs( num_b) ? fabs( num_a) : fabs( num_b); && equal(cell_a->payload.string.cdr,
cell_b->payload.string.cdr);
} else if (numberp(a) && numberp(b)) {
double num_a = numeric_value(a);
double num_b = numeric_value(b);
double max = fabs(num_a) > fabs(num_b) ? fabs(num_a) : fabs(num_b);
/* not more different than one part in a million - close enough */ /*
result = fabs( num_a - num_b) < (max / 1000000.0); * not more different than one part in a million - close enough
*/
result = fabs(num_a - num_b) < (max / 1000000.0);
}
/*
* there's only supposed ever to be one T and one NIL cell, so each
* should be caught by eq; equality of vector-space objects is a whole
* other ball game so we won't deal with it now (and indeedmay never).
* I'm not certain what equality means for read and write streams, so
* I'll ignore them, too, for now.
*/
} }
/* there's only supposed ever to be one T and one NIL cell, so each should
* be caught by eq; equality of vector-space objects is a whole other ball return result;
* 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;
} }

4
src/equal.h
View file

@ -19,12 +19,12 @@
* Shallow, and thus cheap, equality: true if these two objects are * Shallow, and thus cheap, equality: true if these two objects are
* the same object, else false. * 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 * Deep, and thus expensive, equality: true if these two objects have
* identical structure, else false. * 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 #endif

104
src/init.c
View file

@ -21,75 +21,93 @@
#include "lispops.h" #include "lispops.h"
#include "repl.h" #include "repl.h"
void bind_function( char* name, struct cons_pointer (*executable) void bind_function(char *name, struct cons_pointer (*executable)
(struct stack_frame*, struct cons_pointer)) { (struct stack_frame *, struct cons_pointer))
deep_bind( intern( c_string_to_lisp_symbol( name), oblist ), {
make_function( NIL, executable)); deep_bind(intern(c_string_to_lisp_symbol(name), oblist),
make_function(NIL, executable));
} }
void bind_special( char* name, struct cons_pointer (*executable) void bind_special(char *name, struct cons_pointer (*executable)
(struct cons_pointer s_expr, struct cons_pointer env,
struct stack_frame* frame)) {
deep_bind( intern( c_string_to_lisp_symbol( name), oblist ),
make_special( NIL, executable));
(struct cons_pointer s_expr, struct cons_pointer env,
struct stack_frame * frame))
{
deep_bind(intern(c_string_to_lisp_symbol(name), oblist),
make_special(NIL, executable));
} }
int main (int argc, char *argv[]) { int main(int argc, char *argv[])
/* attempt to set wide character acceptance on all streams */ {
/*
* attempt to set wide character acceptance on all streams
*/
fwide(stdin, 1); fwide(stdin, 1);
fwide(stdout, 1); fwide(stdout, 1);
fwide(stderr, 1); fwide(stderr, 1);
int option; int option;
bool dump_at_end = false; bool dump_at_end = false;
bool show_prompt = false; bool show_prompt = false;
while ((option = getopt (argc, argv, "pd")) != -1) while ((option = getopt(argc, argv, "pd")) != -1) {
{ switch (option) {
switch (option)
{
case 'd': case 'd':
dump_at_end = true; dump_at_end = true;
break; break;
case 'p': case 'p':
show_prompt = true; show_prompt = true;
break; break;
default: default:
fprintf( stderr, "Unexpected option %c\n", option); fprintf(stderr, "Unexpected option %c\n", option);
break; break;
} }
} }
if (show_prompt) { if (show_prompt) {
fprintf( stdout, "Post scarcity software environment version %s\n\n", VERSION); fprintf(stdout,
"Post scarcity software environment version %s\n\n", VERSION);
} }
initialise_cons_pages(); initialise_cons_pages();
/* privileged variables (keywords) */ /*
deep_bind( intern( c_string_to_lisp_string( "nil"), oblist), NIL); * privileged variables (keywords)
deep_bind( intern( c_string_to_lisp_string( "t"), oblist), TRUE); */
deep_bind(intern(c_string_to_lisp_string("nil"), oblist), NIL);
deep_bind(intern(c_string_to_lisp_string("t"), oblist), TRUE);
/* primitive function operations */ /*
bind_function( "assoc", &lisp_assoc); * primitive function operations
bind_function( "car", &lisp_car); */
bind_function( "cdr", &lisp_cdr); bind_function("assoc", &lisp_assoc);
bind_function( "cons", &lisp_cons); bind_function("car", &lisp_car);
bind_function( "eq", &lisp_eq); bind_function("cdr", &lisp_cdr);
bind_function( "equal", &lisp_equal); bind_function("cons", &lisp_cons);
bind_function( "read", &lisp_read); bind_function("eq", &lisp_eq);
bind_function( "print", &lisp_print); bind_function("equal", &lisp_equal);
bind_function("read", &lisp_read);
bind_function("print", &lisp_print);
/* primitive special forms */ /*
bind_special( "apply", &lisp_apply); * primitive special forms
bind_special( "eval", &lisp_eval); */
bind_special( "quote", &lisp_quote); bind_special("apply", &lisp_apply);
bind_special("eval", &lisp_eval);
bind_special("quote", &lisp_quote);
repl(stdin, stdout, stderr, show_prompt); repl(stdin, stdout, stderr, show_prompt);
// print( stdout, lisp_eval( input, oblist, NULL)); // print( stdout, lisp_eval( input, oblist, NULL));
if ( dump_at_end) { if (dump_at_end) {
dump_pages(stderr); dump_pages(stderr);
} }
return(0); return (0);
} }

32
src/integer.c
View file

@ -19,28 +19,28 @@
* as a cons-space object. Cell may in principle be any kind of number, * as a cons-space object. Cell may in principle be any kind of number,
* but only integers and reals are so far implemented. * but only integers and reals are so far implemented.
*/ */
double numeric_value( struct cons_pointer pointer) { double numeric_value(struct cons_pointer pointer)
double result = NAN; {
struct cons_space_object* cell = &pointer2cell(pointer); double result = NAN;
struct cons_space_object *cell = &pointer2cell(pointer);
if ( integerp( pointer)) { if (integerp(pointer)) {
result = (double) cell->payload.integer.value; result = (double) cell->payload.integer.value;
} else if ( realp( pointer)) { } else if (realp(pointer)) {
result = cell->payload.real.value; result = cell->payload.real.value;
} }
return result; return result;
} }
/** /**
* Allocate an integer cell representing this value and return a cons pointer to it. * Allocate an integer cell representing this value and return a cons pointer to it.
*/ */
struct cons_pointer make_integer( int value) { struct cons_pointer make_integer(int value)
struct cons_pointer result = allocate_cell( INTEGERTAG); {
struct cons_space_object* cell = &pointer2cell(result); struct cons_pointer result = allocate_cell(INTEGERTAG);
cell->payload.integer.value = value; struct cons_space_object *cell = &pointer2cell(result);
cell->payload.integer.value = value;
return result; return result;
} }

4
src/integer.h
View file

@ -11,11 +11,11 @@
#ifndef __integer_h #ifndef __integer_h
#define __integer_h #define __integer_h
double numeric_value( struct cons_pointer pointer); double numeric_value(struct cons_pointer pointer);
/** /**
* Allocate an integer cell representing this value and return a cons pointer to it. * Allocate an integer cell representing this value and return a cons pointer to it.
*/ */
struct cons_pointer make_integer( int value); struct cons_pointer make_integer(int value);
#endif #endif

88
src/intern.c
View file

@ -43,21 +43,23 @@ struct cons_pointer oblist = NIL;
* from the store (so that later when we want to retrieve a value, an eq test * from the store (so that later when we want to retrieve a value, an eq test
* will work); otherwise return NIL. * will work); otherwise return NIL.
*/ */
struct cons_pointer internedp( struct cons_pointer key, struct cons_pointer store) { struct cons_pointer
struct cons_pointer result = NIL; internedp(struct cons_pointer key, struct cons_pointer store)
{
struct cons_pointer result = NIL;
for ( struct cons_pointer next = store; for (struct cons_pointer next = store;
nilp( result) && consp( next); nilp(result) && consp(next);
next = pointer2cell( next).payload.cons.cdr) { next = pointer2cell(next).payload.cons.cdr) {
struct cons_space_object entry = struct cons_space_object entry =
pointer2cell( pointer2cell( next).payload.cons.car); pointer2cell(pointer2cell(next).payload.cons.car);
if ( equal( key, entry.payload.cons.car)) { if (equal(key, entry.payload.cons.car)) {
result = entry.payload.cons.car; result = entry.payload.cons.car;
}
} }
}
return result; return result;
} }
/** /**
@ -68,60 +70,64 @@ struct cons_pointer internedp( struct cons_pointer key, struct cons_pointer stor
* If this key is lexically identical to a key in this store, return the value * If this key is lexically identical to a key in this store, return the value
* of that key from the store; otherwise return NIL. * of that key from the store; otherwise return NIL.
*/ */
struct cons_pointer c_assoc( struct cons_pointer key, struct cons_pointer store) { struct cons_pointer c_assoc(struct cons_pointer key, struct cons_pointer store)
struct cons_pointer result = NIL; {
struct cons_pointer result = NIL;
for ( struct cons_pointer next = store; for (struct cons_pointer next = store;
consp( next); consp(next); next = pointer2cell(next).payload.cons.cdr) {
next = pointer2cell( next).payload.cons.cdr) { struct cons_space_object entry =
struct cons_space_object entry = pointer2cell(pointer2cell(next).payload.cons.car);
pointer2cell( pointer2cell( next).payload.cons.car);
if ( equal( key, entry.payload.cons.car)) { if (equal(key, entry.payload.cons.car)) {
result = entry.payload.cons.cdr; result = entry.payload.cons.cdr;
break; break;
}
} }
}
return result; return result;
} }
/** /**
* Return a new key/value store containing all the key/value pairs in this store * Return a new key/value store containing all the key/value pairs in this store
* with this key/value pair added to the front. * with this key/value pair added to the front.
*/ */
struct cons_pointer bind( struct cons_pointer key, struct cons_pointer value, struct cons_pointer
struct cons_pointer store) { bind(struct cons_pointer key, struct cons_pointer value,
return make_cons( make_cons( key, value), store); 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 * 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 * current environment. May not be useful except in bootstrapping (and even
* there it may not be especially useful). * there it may not be especially useful).
*/ */
struct cons_pointer deep_bind( struct cons_pointer key, struct cons_pointer value) { struct cons_pointer
oblist = bind( key, value, oblist); deep_bind(struct cons_pointer key, struct cons_pointer value)
return oblist; {
oblist = bind(key, value, oblist);
return oblist;
} }
/** /**
* Ensure that a canonical copy of this key is bound in this environment, and * 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 * return that canonical copy. If there is currently no such binding, create one
* with the value NIL. * with the value NIL.
*/ */
struct cons_pointer intern( struct cons_pointer key, struct cons_pointer
struct cons_pointer environment) { intern(struct cons_pointer key, struct cons_pointer environment)
struct cons_pointer result = environment; {
struct cons_pointer canonical = internedp( key, environment); struct cons_pointer result = environment;
struct cons_pointer canonical = internedp(key, environment);
if ( nilp( canonical)) { if (nilp(canonical)) {
/* not currently bound */ /*
result = bind( key, NIL, environment); * not currently bound
} */
result = bind(key, NIL, environment);
}
return result; return result;
} }

19
src/intern.h
View file

@ -17,7 +17,6 @@
* Licensed under GPL version 2.0, or, at your option, any later version. * Licensed under GPL version 2.0, or, at your option, any later version.
*/ */
#ifndef __intern_h #ifndef __intern_h
#define __intern_h #define __intern_h
@ -28,35 +27,37 @@ extern struct cons_pointer oblist;
* implementation a store is just an assoc list, but in future it might be a * implementation a store is just an assoc list, but in future it might be a
* namespace, a regularity or a homogeneity. * 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 * Return true if this key is present as a key in this enviroment, defaulting to
* the oblist if no environment is passed. * the oblist if no environment is passed.
*/ */
struct cons_pointer internedp( struct cons_pointer key, 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 * Return a new key/value store containing all the key/value pairs in this store
* with this key/value pair added to the front. * with this key/value pair added to the front.
*/ */
struct cons_pointer bind( struct cons_pointer key, struct cons_pointer value, struct cons_pointer bind(struct cons_pointer key,
struct cons_pointer store); struct cons_pointer value, struct cons_pointer store);
/** /**
* Binds this key to this value in the global oblist, but doesn't affect the * 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 * current environment. May not be useful except in bootstrapping (and even
* there it may not be especially useful). * 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 * 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 * return that canonical copy. If there is currently no such binding, create one
* with the value NIL. * with the value NIL.
*/ */
struct cons_pointer intern( struct cons_pointer key, struct cons_pointer intern(struct cons_pointer key,
struct cons_pointer environment); struct cons_pointer environment);
#endif #endif

371
src/lispops.c
View file

@ -37,11 +37,11 @@
/* /*
* also to create in this section: * also to create in this section:
* struct cons_pointer lisp_cond( struct cons_pointer args, struct cons_pointer env, * 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 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 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. * and others I haven't thought of yet.
*/ */
@ -49,27 +49,29 @@
/** /**
* Implementation of car in C. If arg is not a cons, does not error but returns nil. * Implementation of car in C. If arg is not a cons, does not error but returns nil.
*/ */
struct cons_pointer c_car( struct cons_pointer arg) { struct cons_pointer c_car(struct cons_pointer arg)
struct cons_pointer result = NIL; {
struct cons_pointer result = NIL;
if ( consp(arg)) {
result = pointer2cell( arg).payload.cons.car;
}
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. * Implementation of cdr in C. If arg is not a cons, does not error but returns nil.
*/ */
struct cons_pointer c_cdr( struct cons_pointer arg) { struct cons_pointer c_cdr(struct cons_pointer arg)
struct cons_pointer result = NIL; {
struct cons_pointer result = NIL;
if ( consp(arg)) {
result = pointer2cell( arg).payload.cons.cdr;
}
return result; if (consp(arg)) {
result = pointer2cell(arg).payload.cons.cdr;
}
return result;
} }
/** /**
@ -78,61 +80,70 @@ struct cons_pointer c_cdr( struct cons_pointer arg) {
* I'm now confused about whether at this stage I actually need an apply special form, * I'm now confused about whether at this stage I actually need an apply special form,
* and if so how it differs from eval. * and if so how it differs from eval.
*/ */
struct cons_pointer lisp_apply( struct cons_pointer args, struct cons_pointer env, struct cons_pointer
struct stack_frame* frame) { lisp_apply(struct cons_pointer args, struct cons_pointer env,
struct cons_pointer result = args; struct stack_frame *frame)
{
if ( consp( args)) { struct cons_pointer result = args;
lisp_eval( args, env, frame);
}
return result; if (consp(args)) {
lisp_eval(args, env, frame);
}
return result;
} }
struct cons_pointer eval_cons( struct cons_pointer s_expr, struct cons_pointer env, struct cons_pointer
struct stack_frame* my_frame) { eval_cons(struct cons_pointer s_expr, struct cons_pointer env,
struct cons_pointer result = NIL; struct stack_frame *my_frame)
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 result = NIL;
struct cons_pointer args = c_cdr( s_expr); struct cons_pointer fn_pointer = lisp_eval(c_car(s_expr), env, my_frame);
struct cons_space_object fn_cell = pointer2cell(fn_pointer);
struct cons_pointer args = c_cdr(s_expr);
switch ( fn_cell.tag.value) { switch (fn_cell.tag.value) {
case SPECIALTV : case SPECIALTV:
{ {
struct cons_space_object special = pointer2cell( fn_pointer); struct cons_space_object special = pointer2cell(fn_pointer);
result = (*special.payload.special.executable)( args, env, my_frame); result =
(*special.payload.special.executable) (args, env, my_frame);
}
break;
case FUNCTIONTV:
/*
* actually, this is apply
*/
{
struct cons_space_object function = pointer2cell(fn_pointer);
struct stack_frame *frame = make_stack_frame(my_frame, args, env);
/*
* the trick: pass the remaining arguments and environment to the
* executable code which is the payload of the function object.
*/
result = (*function.payload.function.executable) (frame, env);
free_stack_frame(frame);
}
break;
default:
{
char *buffer = malloc(1024);
memset(buffer, '\0', 1024);
sprintf(buffer,
"Unexpected cell with tag %d (%c%c%c%c) in function position",
fn_cell.tag.value, fn_cell.tag.bytes[0],
fn_cell.tag.bytes[1], fn_cell.tag.bytes[2],
fn_cell.tag.bytes[3]);
struct cons_pointer message = c_string_to_lisp_string(buffer);
free(buffer);
result = lisp_throw(message, my_frame);
}
} }
break;
case FUNCTIONTV : return result;
/* 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;
} }
/** /**
@ -148,40 +159,45 @@ struct cons_pointer eval_cons( struct cons_pointer s_expr, struct cons_pointer e
* passes them in a stack frame as arguments to the function. * 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. * 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 cons_pointer
struct stack_frame* previous) { lisp_eval(struct cons_pointer s_expr, struct cons_pointer env,
struct cons_pointer result = s_expr; struct stack_frame *previous)
struct cons_space_object cell = pointer2cell( s_expr); {
struct stack_frame* my_frame = struct cons_pointer result = s_expr;
make_stack_frame( previous, make_cons( s_expr, NIL), env); struct cons_space_object cell = pointer2cell(s_expr);
struct stack_frame *my_frame =
make_stack_frame(previous, make_cons(s_expr, NIL), env);
switch ( cell.tag.value) { switch (cell.tag.value) {
case CONSTV : case CONSTV:
result = eval_cons( s_expr, env, my_frame); result = eval_cons(s_expr, env, my_frame);
break; break;
case SYMBOLTV : case SYMBOLTV:
{ {
struct cons_pointer canonical = internedp( s_expr, env); struct cons_pointer canonical = internedp(s_expr, env);
if ( nilp( canonical)) { if (nilp(canonical)) {
struct cons_pointer message = struct cons_pointer message =
c_string_to_lisp_string( "Attempt to take value of unbound symbol."); c_string_to_lisp_string
result = lisp_throw( message, my_frame); ("Attempt to take value of unbound symbol.");
} else { result = lisp_throw(message, my_frame);
result = c_assoc( canonical, env); } 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); free_stack_frame(my_frame);
return result; return result;
} }
/** /**
@ -191,9 +207,11 @@ struct cons_pointer lisp_eval( struct cons_pointer s_expr, struct cons_pointer e
* Returns its argument (strictly first argument - only one is expected but * Returns its argument (strictly first argument - only one is expected but
* this isn't at this stage checked) unevaluated. * this isn't at this stage checked) unevaluated.
*/ */
struct cons_pointer lisp_quote( struct cons_pointer args, struct cons_pointer env, struct cons_pointer
struct stack_frame* frame) { lisp_quote(struct cons_pointer args, struct cons_pointer env,
return c_car( args); struct stack_frame *frame)
{
return c_car(args);
} }
/** /**
@ -203,22 +221,24 @@ struct cons_pointer lisp_quote( struct cons_pointer args, struct cons_pointer en
* Returns a cell constructed from a and b. If a is of type string but its * 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; * cdr is nill, and b is of type string, then returns a new string cell;
* otherwise returns a new cons cell. * otherwise returns a new cons cell.
*/ */
struct cons_pointer lisp_cons(struct stack_frame* frame, struct cons_pointer env) { struct cons_pointer
struct cons_pointer car = frame->arg[0]; lisp_cons(struct stack_frame *frame, struct cons_pointer env)
struct cons_pointer cdr = frame->arg[1]; {
struct cons_pointer result; struct cons_pointer car = frame->arg[0];
struct cons_pointer cdr = frame->arg[1];
struct cons_pointer result;
if ( nilp( car) && nilp( cdr)) { if (nilp(car) && nilp(cdr)) {
return NIL; return NIL;
} else if ( stringp( car) && stringp( cdr) && } else if (stringp(car) && stringp(cdr) &&
nilp( pointer2cell( car).payload.string.cdr)) { nilp(pointer2cell(car).payload.string.cdr)) {
result = make_string( pointer2cell( car).payload.string.character, cdr); result = make_string(pointer2cell(car).payload.string.character, cdr);
} else { } else {
result = make_cons( car, cdr); result = make_cons(car, cdr);
} }
return result; return result;
} }
/** /**
@ -226,70 +246,78 @@ struct cons_pointer lisp_cons(struct stack_frame* frame, struct cons_pointer env
* Returns the first item (head) of a sequence. Valid for cons cells, * 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. * 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
struct cons_pointer result = NIL; lisp_car(struct stack_frame *frame, struct cons_pointer env)
{
struct cons_pointer result = NIL;
if ( consp( frame->arg[ 0])) { if (consp(frame->arg[0])) {
struct cons_space_object cell = pointer2cell( frame->arg[ 0]); struct cons_space_object cell = pointer2cell(frame->arg[0]);
result = cell.payload.cons.car; result = cell.payload.cons.car;
} else if ( stringp( frame->arg[ 0])) { } else if (stringp(frame->arg[0])) {
struct cons_space_object cell = pointer2cell( frame->arg[ 0]); struct cons_space_object cell = pointer2cell(frame->arg[0]);
result = make_string( cell.payload.string.character, NIL); result = make_string(cell.payload.string.character, NIL);
} else { } else {
struct cons_pointer message = struct cons_pointer message =
c_string_to_lisp_string( "Attempt to take CAR/CDR of non sequence"); c_string_to_lisp_string("Attempt to take CAR/CDR of non sequence");
result = lisp_throw( message, frame); result = lisp_throw(message, frame);
} }
return result; return result;
} }
/** /**
* (cdr s_expr) * (cdr s_expr)
* Returns the remainder of a sequence when the head is removed. Valid for cons cells, * 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. * 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
struct cons_pointer result = NIL; lisp_cdr(struct stack_frame *frame, struct cons_pointer env)
{
struct cons_pointer result = NIL;
if ( consp( frame->arg[ 0])) { if (consp(frame->arg[0])) {
struct cons_space_object cell = pointer2cell( frame->arg[ 0]); struct cons_space_object cell = pointer2cell(frame->arg[0]);
result = cell.payload.cons.car; result = cell.payload.cons.car;
} else if ( stringp( frame->arg[ 0])) { } else if (stringp(frame->arg[0])) {
struct cons_space_object cell = pointer2cell( frame->arg[ 0]); struct cons_space_object cell = pointer2cell(frame->arg[0]);
result = cell.payload.string.cdr; result = cell.payload.string.cdr;
} else { } else {
struct cons_pointer message = struct cons_pointer message =
c_string_to_lisp_string( "Attempt to take CAR/CDR of non sequence"); c_string_to_lisp_string("Attempt to take CAR/CDR of non sequence");
result = lisp_throw( message, frame); result = lisp_throw(message, frame);
} }
return result; return result;
} }
/** /**
* (assoc key store) * (assoc key store)
* Returns the value associated with key in store, or NIL if not found. * Returns the value associated with key in store, or NIL if not found.
*/ */
struct cons_pointer lisp_assoc( struct stack_frame* frame, struct cons_pointer env) { struct cons_pointer
return c_assoc( frame->arg[ 0], frame->arg[ 1]); lisp_assoc(struct stack_frame *frame, struct cons_pointer env)
{
return c_assoc(frame->arg[0], frame->arg[1]);
} }
/** /**
* (eq a b) * (eq a b)
* Returns T if a and b are pointers to the same object, else NIL * Returns T if a and b are pointers to the same object, else NIL
*/ */
struct cons_pointer lisp_eq( struct stack_frame* frame, struct cons_pointer env) { struct cons_pointer lisp_eq(struct stack_frame *frame, struct cons_pointer env)
return eq( frame->arg[ 0], frame->arg[ 1]) ? TRUE : NIL; {
return eq(frame->arg[0], frame->arg[1]) ? TRUE : NIL;
} }
/** /**
* (eq a b) * (eq a b)
* Returns T if a and b are pointers to structurally identical objects, else NIL * Returns T if a and b are pointers to structurally identical objects, else NIL
*/ */
struct cons_pointer lisp_equal( struct stack_frame* frame, struct cons_pointer env) { struct cons_pointer
return equal( frame->arg[ 0], frame->arg[ 1]) ? TRUE : NIL; lisp_equal(struct stack_frame *frame, struct cons_pointer env)
{
return equal(frame->arg[0], frame->arg[1]) ? TRUE : NIL;
} }
/** /**
@ -298,14 +326,16 @@ struct cons_pointer lisp_equal( struct stack_frame* frame, struct cons_pointer e
* Read one complete lisp form and return it. If read-stream is specified and * 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. * is a read stream, then read from that stream, else stdin.
*/ */
struct cons_pointer lisp_read( struct stack_frame* frame, struct cons_pointer env) { struct cons_pointer
FILE* input = stdin; lisp_read(struct stack_frame *frame, struct cons_pointer env)
{
FILE *input = stdin;
if ( readp( frame->arg[0])) { if (readp(frame->arg[0])) {
input = pointer2cell( frame->arg[0]).payload.stream.stream; input = pointer2cell(frame->arg[0]).payload.stream.stream;
} }
return read( input); return read(input);
} }
/** /**
@ -314,27 +344,30 @@ struct cons_pointer lisp_read( struct stack_frame* frame, struct cons_pointer en
* Print one complete lisp form and return NIL. If write-stream is specified and * 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. * is a write stream, then print to that stream, else stdout.
*/ */
struct cons_pointer lisp_print( struct stack_frame* frame, struct cons_pointer env) { struct cons_pointer
FILE* output = stdout; lisp_print(struct stack_frame *frame, struct cons_pointer env)
{
FILE *output = stdout;
if ( writep( frame->arg[1])) { if (writep(frame->arg[1])) {
output = pointer2cell( frame->arg[1]).payload.stream.stream; output = pointer2cell(frame->arg[1]).payload.stream.stream;
} }
print( output, frame->arg[0]); print(output, frame->arg[0]);
return NIL; return NIL;
} }
/** /**
* TODO: make this do something sensible somehow. * TODO: make this do something sensible somehow.
*/ */
struct cons_pointer lisp_throw( struct cons_pointer message, struct stack_frame* frame) { struct cons_pointer
fprintf( stderr, "\nERROR: "); lisp_throw(struct cons_pointer message, struct stack_frame *frame)
print( stderr, message); {
fprintf( stderr, "\n\nAn exception was thrown and I've no idea what to do now\n"); fprintf(stderr, "\nERROR: ");
print(stderr, message);
fprintf(stderr,
"\n\nAn exception was thrown and I've no idea what to do now\n");
exit( 1); exit(1);
} }

54
src/lispops.h
View file

@ -19,23 +19,41 @@
* Licensed under GPL version 2.0, or, at your option, any later version. * Licensed under GPL version 2.0, or, at your option, any later version.
*/ */
/* special forms */ /*
struct cons_pointer lisp_eval( struct cons_pointer args, struct cons_pointer env, * special forms
struct stack_frame* frame); */
struct cons_pointer lisp_apply( struct cons_pointer args, struct cons_pointer env, struct cons_pointer lisp_eval(struct cons_pointer args,
struct stack_frame* frame); struct cons_pointer env,
struct cons_pointer lisp_quote( struct cons_pointer args, struct cons_pointer env, struct stack_frame *frame);
struct stack_frame* frame); struct cons_pointer lisp_apply(struct cons_pointer args,
struct cons_pointer env,
struct stack_frame *frame);
struct cons_pointer lisp_quote(struct cons_pointer args,
struct cons_pointer env,
struct stack_frame *frame);
/* functions */ /*
struct cons_pointer lisp_cons( struct stack_frame* frame, struct cons_pointer env); * functions
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_cons(struct stack_frame *frame,
struct cons_pointer lisp_assoc( struct stack_frame* frame, struct cons_pointer env); struct cons_pointer env);
struct cons_pointer lisp_eq( struct stack_frame* frame, struct cons_pointer env); struct cons_pointer lisp_car(struct stack_frame *frame,
struct cons_pointer lisp_equal( struct stack_frame* frame, struct cons_pointer env); struct cons_pointer env);
struct cons_pointer lisp_read( struct stack_frame* frame, struct cons_pointer env); struct cons_pointer lisp_cdr(struct stack_frame *frame,
struct cons_pointer lisp_print( struct stack_frame* frame, struct cons_pointer env); struct cons_pointer env);
struct cons_pointer lisp_assoc(struct stack_frame *frame,
struct cons_pointer env);
struct cons_pointer lisp_eq(struct stack_frame *frame,
struct cons_pointer env);
struct cons_pointer lisp_equal(struct stack_frame *frame,
struct cons_pointer env);
struct cons_pointer lisp_read(struct stack_frame *frame,
struct cons_pointer env);
struct cons_pointer lisp_print(struct stack_frame *frame,
struct cons_pointer env);
/* neither, at this stage, really */ /*
struct cons_pointer lisp_throw( struct cons_pointer message, struct stack_frame* frame); * neither, at this stage, really
*/
struct cons_pointer lisp_throw(struct cons_pointer message,
struct stack_frame *frame);

140
src/print.c
View file

@ -11,7 +11,9 @@
#include <ctype.h> #include <ctype.h>
#include <stdio.h> #include <stdio.h>
#include <string.h> #include <string.h>
/* wide characters */ /*
* wide characters
*/
#include <wchar.h> #include <wchar.h>
#include <wctype.h> #include <wctype.h>
@ -20,88 +22,94 @@
#include "integer.h" #include "integer.h"
#include "print.h" #include "print.h"
void print_string_contents( FILE* output, struct cons_pointer pointer) { void print_string_contents(FILE * output, struct cons_pointer pointer)
if ( stringp( pointer) || symbolp( pointer)) { {
struct cons_space_object* cell = &pointer2cell(pointer); if (stringp(pointer) || symbolp(pointer)) {
wint_t c = cell->payload.string.character; struct cons_space_object *cell = &pointer2cell(pointer);
wint_t c = cell->payload.string.character;
if ( c != '\0') { if (c != '\0') {
fputwc( c, output); 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)
void print_string( FILE* output, struct cons_pointer pointer) { {
fputwc( btowc('"'), output); fputwc(btowc('"'), output);
print_string_contents( output, pointer); print_string_contents(output, pointer);
fputwc( btowc('"'), output); fputwc(btowc('"'), output);
} }
/** /**
* Print a single list cell (cons cell). TODO: does not handle dotted pairs. * Print a single list cell (cons cell). TODO: does not handle dotted pairs.
*/ */
void print_list_contents( FILE* output, struct cons_pointer pointer, void
bool initial_space) { print_list_contents(FILE * output, struct cons_pointer pointer,
struct cons_space_object* cell = &pointer2cell(pointer); bool initial_space)
{
struct cons_space_object *cell = &pointer2cell(pointer);
switch ( cell->tag.value) { switch (cell->tag.value) {
case CONSTV : case CONSTV:
if (initial_space) { if (initial_space) {
fputwc( btowc(' '), output); fputwc(btowc(' '), output);
} }
print( output, cell->payload.cons.car); print(output, cell->payload.cons.car);
print_list_contents( output, cell->payload.cons.cdr, true); print_list_contents(output, cell->payload.cons.cdr, true);
break; break;
case NILTV: case NILTV:
break; break;
default: default:
fwprintf( output, L" . "); fwprintf(output, L" . ");
print( output, pointer); print(output, pointer);
} }
} }
void print_list(FILE * output, struct cons_pointer pointer)
void print_list( FILE* output, struct cons_pointer pointer) { {
fputwc( btowc('('), output); fputwc(btowc('('), output);
print_list_contents( output, pointer, false); print_list_contents(output, pointer, false);
fputwc( btowc(')'), output); fputwc(btowc(')'), output);
} }
void print( FILE* output, struct cons_pointer pointer) { void print(FILE * output, struct cons_pointer pointer)
struct cons_space_object cell = pointer2cell( 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 * Because tags have values as well as bytes, this if ... else if
* be neater. */ * statement can ultimately be replaced by a switch, which will be neater.
switch ( cell.tag.value) { */
case CONSTV : switch (cell.tag.value) {
print_list( output, pointer); case CONSTV:
break; print_list(output, pointer);
case INTEGERTV : break;
fwprintf( output, L"%ld", cell.payload.integer.value); case INTEGERTV:
break; fwprintf(output, L"%ld", cell.payload.integer.value);
case NILTV : break;
fwprintf( output, L"nil"); case NILTV:
break; fwprintf(output, L"nil");
break;
case REALTV: case REALTV:
fwprintf(output, L"%lf", cell.payload.real.value); fwprintf(output, L"%lf", cell.payload.real.value);
break; break;
case STRINGTV : case STRINGTV:
print_string( output, pointer); print_string(output, pointer);
break; break;
case SYMBOLTV : case SYMBOLTV:
print_string_contents( output, pointer); print_string_contents(output, pointer);
break; break;
case TRUETV : case TRUETV:
fwprintf( output, L"t"); fwprintf(output, L"t");
break; break;
default : default:
fwprintf( stderr, L"Error: Unrecognised tag value %d (%c%c%c%c)\n", fwprintf(stderr,
cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1], L"Error: Unrecognised tag value %d (%c%c%c%c)\n",
cell.tag.bytes[2], cell.tag.bytes[3]); cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1],
break; cell.tag.bytes[2], cell.tag.bytes[3]);
} break;
}
} }

2
src/print.h
View file

@ -14,6 +14,6 @@
#ifndef __print_h #ifndef __print_h
#define __print_h #define __print_h
void print( FILE* output, struct cons_pointer pointer); void print(FILE * output, struct cons_pointer pointer);
#endif #endif

275
src/read.c
View file

@ -11,7 +11,9 @@
#include <math.h> #include <math.h>
#include <stdbool.h> #include <stdbool.h>
#include <stdio.h> #include <stdio.h>
/* wide characters */ /*
* wide characters
*/
#include <wchar.h> #include <wchar.h>
#include <wctype.h> #include <wctype.h>
@ -21,23 +23,23 @@
#include "read.h" #include "read.h"
#include "real.h" #include "real.h"
/* for the time being things which may be read are: /*
strings * for the time being things which may be read are: strings numbers - either
numbers - either integer or real, but not yet including ratios or bignums * integer or real, but not yet including ratios or bignums lists Can't read
lists * atoms because I don't yet know what an atom is or how it's stored.
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_number(FILE * input, wint_t initial);
struct cons_pointer read_list( 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_string(FILE * input, wint_t initial);
struct cons_pointer read_symbol( FILE* input, wint_t initial); struct cons_pointer read_symbol(FILE * input, wint_t initial);
/** /**
* quote reader macro in C (!) * quote reader macro in C (!)
*/ */
struct cons_pointer c_quote( struct cons_pointer arg) { struct cons_pointer c_quote(struct cons_pointer arg)
return make_cons( c_string_to_lisp_symbol( "quote"), {
make_cons( arg, NIL)); return make_cons(c_string_to_lisp_symbol("quote"), make_cons(arg, NIL));
} }
/** /**
@ -45,94 +47,93 @@ struct cons_pointer c_quote( struct cons_pointer arg) {
* treating this initial character as the first character of the object * treating this initial character as the first character of the object
* representation. * representation.
*/ */
struct cons_pointer read_continuation( FILE* input, wint_t initial) { struct cons_pointer read_continuation(FILE * input, wint_t initial)
struct cons_pointer result = NIL; {
struct cons_pointer result = NIL;
wint_t c; wint_t c;
for (c = initial; for (c = initial;
c == '\0' || iswblank( c) || iswcntrl(c); c == '\0' || iswblank(c) || iswcntrl(c); c = fgetwc(input));
c = fgetwc( input));
switch (c) {
switch( c) { case '\'':
case '\'': result = c_quote(read_continuation(input, fgetwc(input)));
result = c_quote( read_continuation( input, fgetwc( input))); break;
break; case '(':
case '(' : result = read_list(input, fgetwc(input));
result = read_list(input, fgetwc( input)); break;
break; case '"':
case '"': result = read_string(input, fgetwc(input));
result = read_string(input, fgetwc( input)); break;
break; default:
default: if (iswdigit(c)) {
if ( iswdigit( c)) { result = read_number(input, c);
result = read_number( input, c); } else if (iswprint(c)) {
} else if (iswprint( c)) { result = read_symbol(input, c);
result = read_symbol( input, c); } else {
} else { fprintf(stderr, "Unrecognised start of input character %c\n", c);
fprintf( stderr, "Unrecognised start of input character %c\n", c); }
} }
}
return result; return result;
} }
/** /**
* read a number from this input stream, given this initial character. * read a number from this input stream, given this initial character.
*/ */
struct cons_pointer read_number( FILE* input, wint_t initial) { struct cons_pointer read_number(FILE * input, wint_t initial)
int accumulator = 0; {
int places_of_decimals = 0; int accumulator = 0;
bool seen_period = false; int places_of_decimals = 0;
wint_t c; bool seen_period = false;
wint_t c;
fprintf( stderr, "read_number starting '%c' (%d)\n", initial, initial); fprintf(stderr, "read_number starting '%c' (%d)\n", initial, initial);
for (c = initial; iswdigit( c) || c == btowc('.'); c = fgetwc( input)) {
if ( c == btowc('.')) {
seen_period = true;
} else {
accumulator = accumulator * 10 + ((int)c - (int)'0');
if ( seen_period) { for (c = initial; iswdigit(c) || c == btowc('.'); c = fgetwc(input)) {
places_of_decimals ++; if (c == btowc('.')) {
} seen_period = true;
} else {
accumulator = accumulator * 10 + ((int) c - (int) '0');
if (seen_period) {
places_of_decimals++;
}
}
} }
}
/* push back the character read which was not a digit */ /*
ungetwc( c, input); * push back the character read which was not a digit
*/
ungetwc(c, input);
if (seen_period) { if (seen_period) {
return make_real(accumulator / pow(10, places_of_decimals)); return make_real(accumulator / pow(10, places_of_decimals));
} } else {
else return make_integer(accumulator);
{ }
return make_integer( accumulator);
}
} }
/** /**
* Read a list from this input stream, which no longer contains the opening * Read a list from this input stream, which no longer contains the opening
* left parenthesis. * left parenthesis.
*/ */
struct cons_pointer read_list( FILE* input, wint_t initial) { struct cons_pointer read_list(FILE * input, wint_t initial)
struct cons_pointer result= NIL; {
struct cons_pointer result = NIL;
if ( initial != ')' ) { if (initial != ')') {
fwprintf( stderr, L"read_list starting '%C' (%d)\n", initial, initial); fwprintf(stderr, L"read_list starting '%C' (%d)\n", initial, initial);
struct cons_pointer car = read_continuation( input, initial); struct cons_pointer car = read_continuation(input, initial);
result = make_cons( car, read_list( input, fgetwc( input))); result = make_cons(car, read_list(input, fgetwc(input)));
} else { } else {
fprintf( stderr, "End of list detected\n"); fprintf(stderr, "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 * (is_quoted == true), in which case it may contain whitespace but may
@ -140,73 +141,75 @@ struct cons_pointer read_list( FILE* input, wint_t initial) {
* so delimited in which case it may not contain whitespace (unless escaped) * so delimited in which case it may not contain whitespace (unless escaped)
* but may contain a double quote character (probably not a good idea!) * but may contain a double quote character (probably not a good idea!)
*/ */
struct cons_pointer read_string( FILE* input, wint_t initial) { struct cons_pointer read_string(FILE * input, wint_t initial)
struct cons_pointer cdr = NIL; {
struct cons_pointer result; struct cons_pointer cdr = NIL;
struct cons_pointer result;
fwprintf( stderr, L"read_string starting '%C' (%d)\n", fwprintf(stderr, L"read_string starting '%C' (%d)\n", initial, initial);
initial, initial);
switch ( initial) { switch (initial) {
case '\0': case '\0':
result = make_string( initial, NIL); result = make_string(initial, NIL);
break; break;
case '"': case '"':
result = make_string( '\0', NIL); result = make_string('\0', NIL);
break; break;
default: default:
result = make_string( initial, read_string( input, fgetwc( input))); result = make_string(initial, read_string(input, fgetwc(input)));
break; 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)));
} }
break;
}
return result; return result;
} }
struct cons_pointer read_symbol(FILE * input, wint_t initial)
{
struct cons_pointer cdr = NIL;
struct cons_pointer result;
fwprintf(stderr, L"read_symbol starting '%C' (%d)\n", initial, initial);
switch (initial) {
case '\0':
result = make_symbol(initial, NIL);
break;
case '"':
/*
* THIS IS NOT A GOOD IDEA, but is legal
*/
result = make_symbol(initial, read_symbol(input, fgetwc(input)));
break;
case ')':
/*
* unquoted strings may not include right-parenthesis
*/
result = make_symbol('\0', NIL);
/*
* push back the character read
*/
ungetwc(initial, input);
break;
default:
if (iswblank(initial) || !iswprint(initial)) {
result = make_symbol('\0', NIL);
/*
* push back the character read
*/
ungetwc(initial, input);
} else {
result = make_symbol(initial, read_symbol(input, fgetwc(input)));
}
break;
}
return result;
}
/** /**
* Read the next object on this input stream and return a cons_pointer to it. * 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)
return read_continuation( input, fgetwc( input)); {
return read_continuation(input, fgetwc(input));
} }

2
src/read.h
View file

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

12
src/real.c
View file

@ -14,11 +14,11 @@
* @param value the value to wrap; * @param value the value to wrap;
* @return a real number cell wrapping this value. * @return a real number cell wrapping this value.
*/ */
struct cons_pointer make_real( long double value) { struct cons_pointer make_real(long double value)
struct cons_pointer result = allocate_cell( REALTAG); {
struct cons_space_object* cell = &pointer2cell(result); struct cons_pointer result = allocate_cell(REALTAG);
cell->payload.real.value = value; struct cons_space_object *cell = &pointer2cell(result);
cell->payload.real.value = value;
return result; return result;
} }

9
src/real.h
View file

@ -4,7 +4,7 @@
* and open the template in the editor. * and open the template in the editor.
*/ */
/* /*
* File: real.h * File: real.h
* Author: simon * Author: simon
* *
@ -24,12 +24,9 @@ extern "C" {
* @param value the value to wrap; * @param value the value to wrap;
* @return a real number cell wrapping this value. * @return a real number cell wrapping this value.
*/ */
struct cons_pointer make_real( double value); struct cons_pointer make_real(double value);
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif
#endif /* REAL_H */
#endif /* REAL_H */

24
src/repl.c
View file

@ -21,22 +21,22 @@
* @param err_stream the stream to send errors to; * @param err_stream the stream to send errors to;
* @param show_prompt true if prompts should be shown. * @param show_prompt true if prompts should be shown.
*/ */
void repl( FILE* in_stream, FILE* out_stream, FILE* error_stream, void
bool show_prompt) { repl(FILE * in_stream, FILE * out_stream, FILE * error_stream,
bool show_prompt)
{
while (!feof(in_stream)) { while (!feof(in_stream)) {
if (show_prompt) { if (show_prompt) {
fwprintf( out_stream, L"\n:: "); fwprintf(out_stream, L"\n:: ");
} }
struct cons_pointer input = read( in_stream); struct cons_pointer input = read(in_stream);
fwprintf( error_stream, L"\nread {%d,%d}=> ", input.page, input.offset); fwprintf(error_stream, L"\nread {%d,%d}=> ", input.page, input.offset);
if (show_prompt) { if (show_prompt) {
fwprintf( out_stream, L"\n-> "); fwprintf(out_stream, L"\n-> ");
} }
// print( out_stream, lisp_eval(input, oblist, NULL)); // print( out_stream, lisp_eval(input, oblist, NULL));
print( out_stream, input); print(out_stream, input);
fwprintf( out_stream, L"\n"); fwprintf(out_stream, L"\n");
fwprintf( error_stream, L"\neval {%d,%d}=> ", input.page, input.offset); fwprintf(error_stream, L"\neval {%d,%d}=> ", input.page, input.offset);
} }
} }

11
src/repl.h
View file

@ -4,7 +4,7 @@
* and open the template in the editor. * and open the template in the editor.
*/ */
/* /*
* File: repl.h * File: repl.h
* Author: simon * Author: simon
* *
@ -25,13 +25,10 @@ extern "C" {
* @param err_stream the stream to send errors to; * @param err_stream the stream to send errors to;
* @param show_prompt true if prompts should be shown. * @param show_prompt true if prompts should be shown.
*/ */
void repl( FILE* in_stream, FILE* out_stream, FILE* error_stream, void repl(FILE * in_stream, FILE * out_stream,
bool show_prompt); FILE * error_stream, bool show_prompt);
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif
#endif /* REPL_H */
#endif /* REPL_H */

135
src/stack.c
View file

@ -29,82 +29,95 @@
* Allocate a new stack frame with its previous pointer set to this value, * Allocate a new stack frame with its previous pointer set to this value,
* its arguments set up from these args, evaluated in this env. * its arguments set up from these args, evaluated in this env.
*/ */
struct stack_frame* make_stack_frame( struct stack_frame* previous, struct stack_frame *make_stack_frame(struct stack_frame *previous,
struct cons_pointer args, struct cons_pointer args,
struct cons_pointer env) { 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)); /*
* TODO: later, pop a frame off a free-list of stack frames
*/
struct stack_frame *result = malloc(sizeof(struct stack_frame));
result->previous = previous; result->previous = previous;
/* clearing the frame with memset would probably be slightly quicker, but /*
* this is clear. */ * clearing the frame with memset would probably be slightly quicker, but
result->more = NIL; * this is clear.
result->function = NIL; */
result->more = NIL;
result->function = NIL;
for ( int i = 0; i < args_in_frame; i++) { for (int i = 0; i < args_in_frame; i++) {
result->arg[i] = NIL; 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;
} }
}
return result; int i = 0; /* still an index into args, so same name will
* do */
while (!nilp(args)) { /* iterate down the arg list filling in the
* arg slots in the frame. When there are no
* more slots, if there are still args, stash
* them on more */
struct cons_space_object cell = pointer2cell(args);
if (i < args_in_frame) {
/*
* TODO: if we were running on real massively parallel hardware,
* each arg except the first should be handed off to another
* processor to be evaled in parallel
*/
result->arg[i] = lisp_eval(cell.payload.cons.car, env, result);
inc_ref(result->arg[i]);
args = cell.payload.cons.cdr;
} else {
/*
* TODO: this isn't right. These args should also each be evaled.
*/
result->more = args;
inc_ref(result->more);
args = NIL;
}
}
return result;
} }
/** /**
* Free this stack frame. * Free this stack frame.
*/ */
void free_stack_frame( struct stack_frame* frame) { void free_stack_frame(struct stack_frame *frame)
/* TODO: later, push it back on the stack-frame freelist */ {
for ( int i = 0; i < args_in_frame; i++) { /*
dec_ref( frame->arg[ i]); * TODO: later, push it back on the stack-frame freelist
} */
dec_ref( frame->more); for (int i = 0; i < args_in_frame; i++) {
dec_ref(frame->arg[i]);
free( frame); }
dec_ref(frame->more);
free(frame);
} }
/** /**
* Fetch a pointer to the value of the local variable at this index. * Fetch a pointer to the value of the local variable at this index.
*/ */
struct cons_pointer fetch_arg( struct stack_frame* frame, unsigned int index) { struct cons_pointer fetch_arg(struct stack_frame *frame, unsigned int index)
struct cons_pointer result = NIL; {
struct cons_pointer result = NIL;
if ( index < args_in_frame) {
result = frame->arg[ index]; if (index < args_in_frame) {
} else { result = frame->arg[index];
struct cons_pointer p = frame->more; } else {
struct cons_pointer p = frame->more;
for ( int i = args_in_frame; i < index; i++) {
p = pointer2cell( p).payload.cons.cdr; for (int i = args_in_frame; i < index; i++) {
p = pointer2cell(p).payload.cons.cdr;
}
result = pointer2cell(p).payload.cons.car;
} }
result = pointer2cell( p).payload.cons.car; return result;
}
return result;
} }

16
src/stack.h
View file

@ -24,13 +24,15 @@
#ifndef __stack_h #ifndef __stack_h
#define __stack_h #define __stack_h
struct stack_frame* make_stack_frame( struct stack_frame* previous, struct stack_frame *make_stack_frame(struct stack_frame *previous,
struct cons_pointer args, struct cons_pointer args,
struct cons_pointer env); struct cons_pointer env);
void free_stack_frame( struct stack_frame* frame); void free_stack_frame(struct stack_frame *frame);
struct cons_pointer fetch_arg( struct stack_frame* frame, unsigned int n); struct cons_pointer fetch_arg(struct stack_frame *frame, unsigned int n);
/* struct stack_frame is defined in consspaceobject.h to break circularity /*
* TODO: refactor. */ * struct stack_frame is defined in consspaceobject.h to break circularity
* TODO: refactor.
*/
#endif #endif

1
src/version.h
View file

@ -8,5 +8,4 @@
* Licensed under GPL version 2.0, or, at your option, any later version. * Licensed under GPL version 2.0, or, at your option, any later version.
*/ */
#define VERSION "0.0.0" #define VERSION "0.0.0"