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

Merge branch 'exp1' into develop

Browse source
This commit is contained in:
simon 2017-09-12 22:14:42 +01:00
parent 2d5fe63b55 36d8431a91
commit 00257ec076
25 changed files with 546 additions and 577 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
Makefile
View file

@ -8,14 +8,14 @@ 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 INDENT_FLAGS := -kr -br -brf -brs -ce -cdw -npsl -nut -prs -l79 -ts2
VERSION := "0.0.0" VERSION := "0.0.0"
CPPFLAGS ?= $(INC_FLAGS) -MMD -MP CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g
LDFLAGS := -lm LDFLAGS := -lm
$(TARGET): $(OBJS) $(TARGET): $(OBJS) Makefile
$(CC) $(LDFLAGS) $(OBJS) -DVERSION=$(VERSION) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS) $(CC) $(LDFLAGS) $(OBJS) -DVERSION=$(VERSION) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS)
format: format:

2
README.md
View file

@ -20,5 +20,5 @@ Although I describe it as a 'Lisp environment', for reasons explained in Post Sc
Copyright © 2017 [Simon Brooke](mailto:simon@journeyman.cc) Copyright © 2017 [Simon Brooke](mailto:simon@journeyman.cc)
Distributed under the terms of the Distributed under the terms of the
[GNU General Public License v2](http://www.gnu.org/licenses/gpl-2.0.html) [GNU General Public License v2](http://www.gnu.org/licenses/gpl-2.0.html)

113
src/conspage.c
View file

@ -45,43 +45,42 @@ struct cons_page *conspages[NCONSPAGES];
* Initialise all cells and prepend each to the freelist; if pageno is zero, do not prepend * 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 = struct cons_space_object *cell =
&conspages[initialised_cons_pages]->cell[i]; &conspages[initialised_cons_pages]->cell[i];
if (initialised_cons_pages == 0 && i < 2) { if ( initialised_cons_pages == 0 && i < 2 ) {
if (i == 0) { if ( i == 0 ) {
/* /*
* initialise cell as NIL * initialise cell as NIL
*/ */
strncpy(&cell->tag.bytes[0], NILTAG, TAGLENGTH); strncpy( &cell->tag.bytes[0], NILTAG, TAGLENGTH );
cell->count = MAXREFERENCE; cell->count = MAXREFERENCE;
cell->payload.free.car = NIL; cell->payload.free.car = NIL;
cell->payload.free.cdr = NIL; cell->payload.free.cdr = NIL;
fprintf(stderr, "Allocated special cell NIL\n"); fprintf( stderr, "Allocated special cell NIL\n" );
} else if (i == 1) { } else if ( i == 1 ) {
/* /*
* initialise cell as T * initialise cell as T
*/ */
strncpy(&cell->tag.bytes[0], TRUETAG, TAGLENGTH); strncpy( &cell->tag.bytes[0], TRUETAG, TAGLENGTH );
cell->count = MAXREFERENCE; cell->count = MAXREFERENCE;
cell->payload.free.car = (struct cons_pointer) { cell->payload.free.car = ( struct cons_pointer ) {
0, 1}; 0, 1};
cell->payload.free.cdr = (struct cons_pointer) { cell->payload.free.cdr = ( struct cons_pointer ) {
0, 1}; 0, 1};
fprintf(stderr, "Allocated special cell T\n"); fprintf( stderr, "Allocated special cell T\n" );
} }
} else { } else {
/* /*
* otherwise, standard initialisation * otherwise, standard initialisation
*/ */
strncpy(&cell->tag.bytes[0], FREETAG, TAGLENGTH); strncpy( &cell->tag.bytes[0], FREETAG, TAGLENGTH );
cell->payload.free.car = NIL; cell->payload.free.car = NIL;
cell->payload.free.cdr = freelist; cell->payload.free.cdr = freelist;
freelist.page = initialised_cons_pages; freelist.page = initialised_cons_pages;
@ -91,10 +90,10 @@ void make_cons_page()
initialised_cons_pages++; initialised_cons_pages++;
} else { } else {
fprintf(stderr, fprintf( stderr,
"FATAL: Failed to allocate memory for cons page %d\n", "FATAL: Failed to allocate memory for cons page %d\n",
initialised_cons_pages); initialised_cons_pages );
exit(1); exit( 1 );
} }
} }
@ -102,14 +101,13 @@ void make_cons_page()
/** /**
* 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++ ) {
for (int i = 0; i < initialised_cons_pages; i++) { fprintf( output, "\nDUMPING PAGE %d\n", 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) { dump_object( output, ( struct cons_pointer ) {
i, j}); i, j} );
} }
} }
} }
@ -120,25 +118,24 @@ void dump_pages(FILE * output)
* *
* @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 );
} }
} }
@ -149,31 +146,30 @@ void free_cell(struct cons_pointer pointer)
* @param tag the tag of the cell to allocate - must be a valid cons space tag. * @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 { } else {
struct cons_space_object *cell = &pointer2cell(result); struct cons_space_object *cell = &pointer2cell( result );
if (strncmp(&cell->tag.bytes[0], FREETAG, TAGLENGTH) == 0) { if ( strncmp( &cell->tag.bytes[0], FREETAG, TAGLENGTH ) == 0 ) {
freelist = cell->payload.free.cdr; freelist = cell->payload.free.cdr;
strncpy(&cell->tag.bytes[0], tag, 4); strncpy( &cell->tag.bytes[0], tag, 4 );
cell->count = 0; cell->count = 0;
cell->payload.cons.car = NIL; cell->payload.cons.car = NIL;
cell->payload.cons.cdr = NIL; cell->payload.cons.cdr = NIL;
fprintf(stderr, fprintf( stderr,
"Allocated cell of type '%s' at %d, %d \n", tag, "Allocated cell of type '%s' at %d, %d \n", tag,
result.page, result.offset); result.page, result.offset );
dump_object(stderr, result); dump_object( stderr, result );
} else { } else {
fprintf(stderr, "WARNING: Allocating non-free cell!"); fprintf( stderr, "WARNING: Allocating non-free cell!" );
} }
} }
@ -183,17 +179,16 @@ struct cons_pointer allocate_cell(char *tag)
/** /**
* initialise the cons page system; to be called exactly once during startup. * initialise the cons page system; to be called exactly once during startup.
*/ */
void initialise_cons_pages() void initialise_cons_pages( ) {
{ if ( conspageinitihasbeencalled == false ) {
if (conspageinitihasbeencalled == false) { for ( int i = 0; i < NCONSPAGES; i++ ) {
for (int i = 0; i < NCONSPAGES; i++) { conspages[i] = ( struct cons_page * ) NULL;
conspages[i] = (struct cons_page *) NULL;
} }
make_cons_page(); make_cons_page( );
conspageinitihasbeencalled = true; conspageinitihasbeencalled = true;
} else { } else {
fprintf(stderr, fprintf( stderr,
"WARNING: conspageinit() called a second or subsequent time\n"); "WARNING: conspageinit() called a second or subsequent time\n" );
} }
} }

8
src/conspage.h
View file

@ -43,7 +43,7 @@ extern struct cons_page *conspages[NCONSPAGES];
* *
* @pointer the cell to free * @pointer the cell to free
*/ */
void free_cell(struct cons_pointer pointer); void free_cell( struct cons_pointer pointer );
/** /**
* Allocates a cell with the specified tag. Dangerous, primitive, low * Allocates a cell with the specified tag. Dangerous, primitive, low
@ -52,16 +52,16 @@ void free_cell(struct cons_pointer pointer);
* @param tag the tag of the cell to allocate - must be a valid cons space tag. * @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.
*/ */
void initialise_cons_pages(); 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

157
src/consspaceobject.c
View file

@ -23,10 +23,9 @@
/** /**
* 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 );
struct cons_space_object cell = pointer2cell(pointer); return strncmp( &cell.tag.bytes[0], tag, TAGLENGTH ) == 0;
return strncmp(&cell.tag.bytes[0], tag, TAGLENGTH) == 0;
} }
/** /**
@ -35,11 +34,10 @@ int check_tag(struct cons_pointer pointer, char *tag)
* You can't roll over the reference count. Once it hits the maximum * 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++;
} }
} }
@ -50,15 +48,14 @@ void inc_ref(struct cons_pointer 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 );
} }
} }
} }
@ -66,54 +63,55 @@ 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_space_object cell = pointer2cell( pointer );
struct cons_space_object cell = pointer2cell(pointer); fwprintf( output,
fwprintf(output, L"\tDumping %c%c%c%c (%d) at page %d, offset %d count %u\n",
L"\tDumping %c%c%c%c (%d) at page %d, offset %d count %u\n", cell.tag.bytes[0],
cell.tag.bytes[0], cell.tag.bytes[1],
cell.tag.bytes[1], cell.tag.bytes[2],
cell.tag.bytes[2], cell.tag.bytes[3],
cell.tag.bytes[3], cell.tag.value, pointer.page, pointer.offset, cell.count );
cell.tag.value, pointer.page, 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.page,
cell.payload.cons.car.offset, cell.payload.cons.car.offset,
cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset); cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset );
} else if (check_tag(pointer, INTEGERTAG)) { } else if ( check_tag( pointer, INTEGERTAG ) ) {
fwprintf(output, fwprintf( output,
L"\t\tInteger cell: value %ld\n", cell.payload.integer.value); L"\t\tInteger cell: value %ld\n",
} else if (check_tag(pointer, FREETAG)) { cell.payload.integer.value );
fwprintf(output, L"\t\tFree cell: next at page %d offset %d\n", } else if ( check_tag( pointer, FREETAG ) ) {
cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset); fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n",
} else if (check_tag(pointer, REALTAG)) { cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset );
fwprintf(output, L"\t\tReal cell: value %Lf\n", } else if ( check_tag( pointer, REALTAG ) ) {
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, L"String cell: character '%1c' (%1d) next at page %2d offset %3d\n",
cell.payload.string.cdr.page, 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 = struct cons_space_object *cell =
&conspages[pointer.page]->cell[pointer.offset]; &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;
@ -124,11 +122,10 @@ struct cons_pointer make_cons(struct cons_pointer car, struct cons_pointer cdr)
* Construct a cell which points to an executable Lisp special form. * Construct a cell which points to an executable Lisp special form.
*/ */
struct cons_pointer struct cons_pointer
make_function(struct cons_pointer src, struct cons_pointer (*executable) make_function( struct cons_pointer src, struct cons_pointer ( *executable )
(struct stack_frame *, struct cons_pointer)) ( struct stack_frame *, struct cons_pointer ) ) {
{ struct cons_pointer pointer = allocate_cell( FUNCTIONTAG );
struct cons_pointer pointer = allocate_cell(FUNCTIONTAG); struct cons_space_object *cell = &pointer2cell( pointer );
struct cons_space_object *cell = &pointer2cell(pointer);
cell->payload.function.source = src; cell->payload.function.source = src;
cell->payload.function.executable = executable; cell->payload.function.executable = executable;
@ -143,22 +140,21 @@ make_function(struct cons_pointer src, struct cons_pointer (*executable)
* pointer to next is NIL. * pointer to next is NIL.
*/ */
struct cons_pointer struct cons_pointer
make_string_like_thing(wint_t c, struct cons_pointer tail, char *tag) make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) {
{
struct cons_pointer pointer = NIL; struct cons_pointer pointer = NIL;
if (check_tag(tail, tag) || check_tag(tail, NILTAG)) { if ( check_tag( tail, tag ) || check_tag( tail, NILTAG ) ) {
pointer = allocate_cell(tag); pointer = allocate_cell( tag );
struct cons_space_object *cell = &pointer2cell(pointer); struct cons_space_object *cell = &pointer2cell( pointer );
inc_ref(tail); inc_ref( tail );
cell->payload.string.character = c; cell->payload.string.character = c;
cell->payload.string.cdr.page = tail.page; cell->payload.string.cdr.page = tail.page;
cell->payload.string.cdr.offset = tail.offset; cell->payload.string.cdr.offset = tail.offset;
} else { } else {
fwprintf(stderr, fwprintf( stderr,
L"Warning: only NIL and %s can be appended to %s\n", L"Warning: only NIL and %s can be appended to %s\n",
tag, tag); tag, tag );
} }
return pointer; return pointer;
@ -170,24 +166,22 @@ make_string_like_thing(wint_t c, struct cons_pointer tail, char *tag)
* has one character and a pointer to the next; in the last cell the * 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 struct cons_pointer
make_special(struct cons_pointer src, struct cons_pointer (*executable) make_special( struct cons_pointer src, struct cons_pointer ( *executable )
@ -196,11 +190,10 @@ make_special(struct cons_pointer src, struct cons_pointer (*executable)
(struct cons_pointer s_expr, ( struct cons_pointer s_expr,
struct cons_pointer env, struct stack_frame * frame)) struct cons_pointer env, struct stack_frame * frame ) ) {
{ struct cons_pointer pointer = allocate_cell( SPECIALTAG );
struct cons_pointer pointer = allocate_cell(SPECIALTAG); struct cons_space_object *cell = &pointer2cell( pointer );
struct cons_space_object *cell = &pointer2cell(pointer);
cell->payload.special.source = src; cell->payload.special.source = src;
cell->payload.special.executable = executable; cell->payload.special.executable = executable;
@ -211,12 +204,11 @@ make_special(struct cons_pointer src, struct cons_pointer (*executable)
/** /**
* Return a lisp string representation of this old skool ASCII string. * 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;
@ -225,12 +217,11 @@ struct cons_pointer c_string_to_lisp_string(char *string)
/** /**
* Return a lisp symbol representation of this old skool ASCII string. * 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;

48
src/consspaceobject.h
View file

@ -246,8 +246,8 @@ struct cons_payload {
*/ */
struct function_payload { struct function_payload {
struct cons_pointer source; struct cons_pointer source;
struct cons_pointer (*executable) (struct stack_frame *, struct cons_pointer ( *executable ) ( struct stack_frame *,
struct cons_pointer); struct cons_pointer );
}; };
/** /**
@ -290,9 +290,9 @@ struct real_payload {
*/ */
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 );
}; };
/** /**
@ -393,31 +393,31 @@ struct cons_space_object {
/** /**
* 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 make_cons( struct cons_pointer car,
struct cons_pointer cdr); 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 )
@ -426,14 +426,14 @@ struct cons_pointer make_function(struct cons_pointer src,
(struct stack_frame *, ( struct stack_frame *,
struct cons_pointer)); 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 )
@ -442,31 +442,31 @@ struct cons_pointer make_special(struct cons_pointer src,
(struct cons_pointer s_expr, ( struct cons_pointer s_expr,
struct cons_pointer env, struct cons_pointer env,
struct stack_frame * frame)); 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

40
src/equal.c
View file

@ -18,27 +18,26 @@
* 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.cdr, cell_b->payload.cons.cdr); equal( cell_a->payload.cons.car, cell_b->payload.cons.car )
} else if (stringp(a) && stringp(b)) { && equal( cell_a->payload.cons.cdr, cell_b->payload.cons.cdr );
} else if ( stringp( a ) && stringp( b ) ) {
/* /*
* slightly complex because a string may or may not have a '\0' * 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 * cell at the end, but I'll ignore that for now. I think in
@ -47,17 +46,18 @@ bool equal(struct cons_pointer a, struct cons_pointer b)
result = result =
cell_a->payload.string.character == cell_a->payload.string.character ==
cell_b->payload.string.character cell_b->payload.string.character
&& equal(cell_a->payload.string.cdr, && equal( cell_a->payload.string.cdr,
cell_b->payload.string.cdr); cell_b->payload.string.cdr );
} else if (numberp(a) && numberp(b)) { } else if ( numberp( a ) && numberp( b ) ) {
double num_a = numeric_value(a); double num_a = numeric_value( a );
double num_b = numeric_value(b); double num_b = numeric_value( b );
double max = fabs(num_a) > fabs(num_b) ? fabs(num_a) : fabs(num_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 * not more different than one part in a million - close enough
*/ */
result = fabs(num_a - num_b) < (max / 1000000.0); result = fabs( num_a - num_b ) < ( max / 1000000.0 );
} }
/* /*
* there's only supposed ever to be one T and one NIL cell, so each * there's only supposed ever to be one T and one NIL cell, so each

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

78
src/init.c
View file

@ -21,14 +21,13 @@
#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 ),
deep_bind(intern(c_string_to_lisp_symbol(name), oblist), make_function( NIL, executable ) );
make_function(NIL, executable));
} }
void bind_special(char *name, struct cons_pointer (*executable) void bind_special( char *name, struct cons_pointer ( *executable )
@ -37,27 +36,25 @@ void bind_special(char *name, struct cons_pointer (*executable)
(struct cons_pointer s_expr, struct cons_pointer env, ( struct cons_pointer s_expr, struct cons_pointer env,
struct stack_frame * frame)) struct stack_frame * frame ) ) {
{ deep_bind( intern( c_string_to_lisp_symbol( name ), oblist ),
deep_bind(intern(c_string_to_lisp_symbol(name), oblist), make_special( NIL, executable ) );
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;
@ -65,49 +62,50 @@ int main(int argc, char *argv[])
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, fprintf( stdout,
"Post scarcity software environment version %s\n\n", VERSION); "Post scarcity software environment version %s\n\n",
VERSION );
} }
initialise_cons_pages(); initialise_cons_pages( );
/* /*
* privileged variables (keywords) * privileged variables (keywords)
*/ */
deep_bind(intern(c_string_to_lisp_string("nil"), oblist), NIL); deep_bind( intern( c_string_to_lisp_string( "nil" ), oblist ), NIL );
deep_bind(intern(c_string_to_lisp_string("t"), oblist), TRUE); deep_bind( intern( c_string_to_lisp_string( "t" ), oblist ), TRUE );
/* /*
* primitive function operations * primitive function operations
*/ */
bind_function("assoc", &lisp_assoc); bind_function( "assoc", &lisp_assoc );
bind_function("car", &lisp_car); bind_function( "car", &lisp_car );
bind_function("cdr", &lisp_cdr); bind_function( "cdr", &lisp_cdr );
bind_function("cons", &lisp_cons); bind_function( "cons", &lisp_cons );
bind_function("eq", &lisp_eq); bind_function( "eq", &lisp_eq );
bind_function("equal", &lisp_equal); bind_function( "equal", &lisp_equal );
bind_function("read", &lisp_read); bind_function( "read", &lisp_read );
bind_function("print", &lisp_print); bind_function( "print", &lisp_print );
/* /*
* primitive special forms * primitive special forms
*/ */
bind_special("apply", &lisp_apply); bind_special( "apply", &lisp_apply );
bind_special("eval", &lisp_eval); bind_special( "eval", &lisp_eval );
bind_special("quote", &lisp_quote); 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 );
} }

21
src/integer.c
View file

@ -9,6 +9,7 @@
#define _GNU_SOURCE #define _GNU_SOURCE
#include <math.h> #include <math.h>
#include <stdio.h>
#include "conspage.h" #include "conspage.h"
#include "consspaceobject.h" #include "consspaceobject.h"
@ -19,14 +20,13 @@
* 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; double result = NAN;
struct cons_space_object *cell = &pointer2cell(pointer); struct cons_space_object *cell = &pointer2cell( pointer );
if (integerp(pointer)) { if ( integerp( pointer ) ) {
result = (double) cell->payload.integer.value; result = cell->payload.integer.value * 1.0;
} else if (realp(pointer)) { } else if ( realp( pointer ) ) {
result = cell->payload.real.value; result = cell->payload.real.value;
} }
@ -36,11 +36,12 @@ double numeric_value(struct cons_pointer pointer)
/** /**
* Allocate an integer cell representing this value and return a cons pointer to it. * Allocate an integer cell representing this value and return a cons pointer to it.
*/ */
struct cons_pointer make_integer(int value) struct cons_pointer make_integer( long int value ) {
{ struct cons_pointer result = allocate_cell( INTEGERTAG );
struct cons_pointer result = allocate_cell(INTEGERTAG); struct cons_space_object *cell = &pointer2cell( result );
struct cons_space_object *cell = &pointer2cell(result);
cell->payload.integer.value = value; cell->payload.integer.value = value;
dump_object( stderr, result);
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( long int value );
#endif #endif

46
src/intern.c
View file

@ -44,17 +44,16 @@ struct cons_pointer oblist = NIL;
* will work); otherwise return NIL. * will work); otherwise return NIL.
*/ */
struct cons_pointer struct cons_pointer
internedp(struct cons_pointer key, struct cons_pointer store) internedp( struct cons_pointer key, struct cons_pointer store ) {
{
struct cons_pointer result = NIL; 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;
} }
} }
@ -70,16 +69,16 @@ internedp(struct cons_pointer key, struct cons_pointer store)
* If this key is lexically identical to a key in this store, return the value * 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); next = pointer2cell(next).payload.cons.cdr) { consp( next ); 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;
} }
@ -93,10 +92,9 @@ struct cons_pointer c_assoc(struct cons_pointer key, struct cons_pointer store)
* with this key/value pair added to the front. * with this key/value pair added to the front.
*/ */
struct cons_pointer struct cons_pointer
bind(struct cons_pointer key, struct cons_pointer value, bind( struct cons_pointer key, struct cons_pointer value,
struct cons_pointer store) struct cons_pointer store ) {
{ return make_cons( make_cons( key, value ), store );
return make_cons(make_cons(key, value), store);
} }
/** /**
@ -105,9 +103,8 @@ bind(struct cons_pointer key, struct cons_pointer value,
* there it may not be especially useful). * there it may not be especially useful).
*/ */
struct cons_pointer struct cons_pointer
deep_bind(struct cons_pointer key, struct cons_pointer value) deep_bind( struct cons_pointer key, struct cons_pointer value ) {
{ oblist = bind( key, value, oblist );
oblist = bind(key, value, oblist);
return oblist; return oblist;
} }
@ -117,16 +114,15 @@ deep_bind(struct cons_pointer key, struct cons_pointer value)
* with the value NIL. * with the value NIL.
*/ */
struct cons_pointer struct cons_pointer
intern(struct cons_pointer key, struct cons_pointer environment) intern( struct cons_pointer key, struct cons_pointer environment ) {
{
struct cons_pointer result = environment; struct cons_pointer result = environment;
struct cons_pointer canonical = internedp(key, environment); struct cons_pointer canonical = internedp( key, environment );
if (nilp(canonical)) { if ( nilp( canonical ) ) {
/* /*
* not currently bound * not currently bound
*/ */
result = bind(key, NIL, environment); result = bind( key, NIL, environment );
} }
return result; return result;

21
src/intern.h
View file

@ -27,37 +27,38 @@ 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 c_assoc( struct cons_pointer key,
struct cons_pointer store); 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 bind( struct cons_pointer key,
struct cons_pointer value, 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 deep_bind( struct cons_pointer key,
struct cons_pointer value); 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

204
src/lispops.c
View file

@ -49,12 +49,11 @@
/** /**
* 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)) { if ( consp( arg ) ) {
result = pointer2cell(arg).payload.cons.car; result = pointer2cell( arg ).payload.cons.car;
} }
return result; return result;
@ -63,12 +62,11 @@ struct cons_pointer c_car(struct cons_pointer arg)
/** /**
* Implementation of cdr in C. If arg is not a cons, does not error but returns nil. * 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)) { if ( consp( arg ) ) {
result = pointer2cell(arg).payload.cons.cdr; result = pointer2cell( arg ).payload.cons.cdr;
} }
return result; return result;
@ -81,33 +79,33 @@ struct cons_pointer c_cdr(struct cons_pointer arg)
* and if so how it differs from eval. * and if so how it differs from eval.
*/ */
struct cons_pointer struct cons_pointer
lisp_apply(struct cons_pointer args, struct cons_pointer env, lisp_apply( struct cons_pointer args, struct cons_pointer env,
struct stack_frame *frame) struct stack_frame *frame ) {
{
struct cons_pointer result = args; struct cons_pointer result = args;
if (consp(args)) { if ( consp( args ) ) {
lisp_eval(args, env, frame); lisp_eval( args, env, frame );
} }
return result; return result;
} }
struct cons_pointer struct cons_pointer
eval_cons(struct cons_pointer s_expr, struct cons_pointer env, eval_cons( struct cons_pointer s_expr, struct cons_pointer env,
struct stack_frame *my_frame) struct stack_frame *my_frame ) {
{
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct cons_pointer fn_pointer = lisp_eval(c_car(s_expr), env, my_frame); struct cons_pointer fn_pointer =
struct cons_space_object fn_cell = pointer2cell(fn_pointer); lisp_eval( c_car( s_expr ), env, my_frame );
struct cons_pointer args = c_cdr(s_expr); 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 = result =
(*special.payload.special.executable) (args, env, my_frame); ( *special.payload.special.executable ) ( args, env,
my_frame );
} }
break; break;
@ -116,30 +114,31 @@ eval_cons(struct cons_pointer s_expr, struct cons_pointer env,
* actually, this is apply * actually, this is apply
*/ */
{ {
struct cons_space_object function = pointer2cell(fn_pointer); struct cons_space_object function = pointer2cell( fn_pointer );
struct stack_frame *frame = make_stack_frame(my_frame, args, env); struct stack_frame *frame =
make_stack_frame( my_frame, args, env );
/* /*
* the trick: pass the remaining arguments and environment to the * the trick: pass the remaining arguments and environment to the
* executable code which is the payload of the function object. * executable code which is the payload of the function object.
*/ */
result = (*function.payload.function.executable) (frame, env); result = ( *function.payload.function.executable ) ( frame, env );
free_stack_frame(frame); free_stack_frame( frame );
} }
break; break;
default: default:
{ {
char *buffer = malloc(1024); char *buffer = malloc( 1024 );
memset(buffer, '\0', 1024); memset( buffer, '\0', 1024 );
sprintf(buffer, sprintf( buffer,
"Unexpected cell with tag %d (%c%c%c%c) in function position", "Unexpected cell with tag %d (%c%c%c%c) in function position",
fn_cell.tag.value, fn_cell.tag.bytes[0], fn_cell.tag.value, fn_cell.tag.bytes[0],
fn_cell.tag.bytes[1], fn_cell.tag.bytes[2], fn_cell.tag.bytes[1], fn_cell.tag.bytes[2],
fn_cell.tag.bytes[3]); fn_cell.tag.bytes[3] );
struct cons_pointer message = c_string_to_lisp_string(buffer); struct cons_pointer message = c_string_to_lisp_string( buffer );
free(buffer); free( buffer );
result = lisp_throw(message, my_frame); result = lisp_throw( message, my_frame );
} }
} }
@ -160,29 +159,32 @@ eval_cons(struct cons_pointer s_expr, struct cons_pointer env,
* If a special form, passes the cdr of s_expr to the special form as argument. * If a special form, passes the cdr of s_expr to the special form as argument.
*/ */
struct cons_pointer struct cons_pointer
lisp_eval(struct cons_pointer s_expr, struct cons_pointer env, lisp_eval( struct cons_pointer s_expr, struct cons_pointer env,
struct stack_frame *previous) struct stack_frame *previous ) {
{
struct cons_pointer result = s_expr; struct cons_pointer result = s_expr;
struct cons_space_object cell = pointer2cell(s_expr); struct cons_space_object cell = pointer2cell( s_expr );
struct stack_frame *my_frame =
make_stack_frame(previous, make_cons(s_expr, NIL), env);
switch (cell.tag.value) { fprintf( stderr, "In eval; about to make stack frame" );
struct stack_frame *frame = make_stack_frame( previous, s_expr, env );
fprintf( stderr, "In eval; stack frame made" );
switch ( cell.tag.value ) {
case CONSTV: case CONSTV:
result = eval_cons(s_expr, env, my_frame); result = eval_cons( s_expr, env, 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 c_string_to_lisp_string
("Attempt to take value of unbound symbol."); ( "Attempt to take value of unbound symbol." );
result = lisp_throw(message, my_frame); result = lisp_throw( message, frame );
} else { } else {
result = c_assoc(canonical, env); result = c_assoc( canonical, env );
} }
} }
break; break;
@ -195,7 +197,7 @@ lisp_eval(struct cons_pointer s_expr, struct cons_pointer env,
*/ */
} }
free_stack_frame(my_frame); free_stack_frame( frame );
return result; return result;
} }
@ -208,10 +210,9 @@ lisp_eval(struct cons_pointer s_expr, struct cons_pointer env,
* this isn't at this stage checked) unevaluated. * this isn't at this stage checked) unevaluated.
*/ */
struct cons_pointer struct cons_pointer
lisp_quote(struct cons_pointer args, struct cons_pointer env, lisp_quote( struct cons_pointer args, struct cons_pointer env,
struct stack_frame *frame) struct stack_frame *frame ) {
{ return c_car( args );
return c_car(args);
} }
/** /**
@ -223,19 +224,19 @@ lisp_quote(struct cons_pointer args, struct cons_pointer env,
* otherwise returns a new cons cell. * otherwise returns a new cons cell.
*/ */
struct cons_pointer struct cons_pointer
lisp_cons(struct stack_frame *frame, struct cons_pointer env) lisp_cons( struct stack_frame *frame, struct cons_pointer env ) {
{
struct cons_pointer car = frame->arg[0]; struct cons_pointer car = frame->arg[0];
struct cons_pointer cdr = frame->arg[1]; struct cons_pointer cdr = frame->arg[1];
struct cons_pointer result; struct cons_pointer result;
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;
@ -247,20 +248,20 @@ lisp_cons(struct stack_frame *frame, struct cons_pointer env)
* strings, and TODO read streams and other things which can be considered as sequences. * strings, and TODO read streams and other things which can be considered as sequences.
*/ */
struct cons_pointer struct cons_pointer
lisp_car(struct stack_frame *frame, struct cons_pointer env) lisp_car( struct stack_frame *frame, struct cons_pointer env ) {
{
struct cons_pointer result = NIL; 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
result = lisp_throw(message, frame); ( "Attempt to take CAR/CDR of non sequence" );
result = lisp_throw( message, frame );
} }
return result; return result;
@ -272,20 +273,20 @@ lisp_car(struct stack_frame *frame, struct cons_pointer env)
* strings, and TODO read streams and other things which can be considered as sequences. * strings, and TODO read streams and other things which can be considered as sequences.
*/ */
struct cons_pointer struct cons_pointer
lisp_cdr(struct stack_frame *frame, struct cons_pointer env) lisp_cdr( struct stack_frame *frame, struct cons_pointer env ) {
{
struct cons_pointer result = NIL; 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
result = lisp_throw(message, frame); ( "Attempt to take CAR/CDR of non sequence" );
result = lisp_throw( message, frame );
} }
return result; return result;
@ -296,18 +297,17 @@ lisp_cdr(struct stack_frame *frame, struct cons_pointer env)
* Returns the value associated with key in store, or NIL if not found. * Returns the value associated with key in store, or NIL if not found.
*/ */
struct cons_pointer struct cons_pointer
lisp_assoc(struct stack_frame *frame, struct cons_pointer env) lisp_assoc( struct stack_frame *frame, struct cons_pointer env ) {
{ return c_assoc( frame->arg[0], frame->arg[1] );
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;
} }
/** /**
@ -315,9 +315,8 @@ struct cons_pointer lisp_eq(struct stack_frame *frame, struct cons_pointer env)
* Returns T if a and b are pointers to structurally identical objects, else NIL * Returns T if a and b are pointers to structurally identical objects, else NIL
*/ */
struct cons_pointer struct cons_pointer
lisp_equal(struct stack_frame *frame, struct cons_pointer env) lisp_equal( struct stack_frame *frame, struct cons_pointer env ) {
{ return equal( frame->arg[0], frame->arg[1] ) ? TRUE : NIL;
return equal(frame->arg[0], frame->arg[1]) ? TRUE : NIL;
} }
/** /**
@ -327,15 +326,14 @@ lisp_equal(struct stack_frame *frame, struct cons_pointer env)
* is a read stream, then read from that stream, else stdin. * is a read stream, then read from that stream, else stdin.
*/ */
struct cons_pointer struct cons_pointer
lisp_read(struct stack_frame *frame, struct cons_pointer env) lisp_read( struct stack_frame *frame, struct cons_pointer env ) {
{
FILE *input = stdin; FILE *input = stdin;
if (readp(frame->arg[0])) { if ( readp( frame->arg[0] ) ) {
input = pointer2cell(frame->arg[0]).payload.stream.stream; input = pointer2cell( frame->arg[0] ).payload.stream.stream;
} }
return read(input); return read( input );
} }
/** /**
@ -345,15 +343,14 @@ lisp_read(struct stack_frame *frame, struct cons_pointer env)
* is a write stream, then print to that stream, else stdout. * is a write stream, then print to that stream, else stdout.
*/ */
struct cons_pointer struct cons_pointer
lisp_print(struct stack_frame *frame, struct cons_pointer env) lisp_print( struct stack_frame *frame, struct cons_pointer env ) {
{
FILE *output = stdout; 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;
} }
@ -362,12 +359,11 @@ lisp_print(struct stack_frame *frame, struct cons_pointer env)
* TODO: make this do something sensible somehow. * TODO: make this do something sensible somehow.
*/ */
struct cons_pointer struct cons_pointer
lisp_throw(struct cons_pointer message, struct stack_frame *frame) lisp_throw( struct cons_pointer message, struct stack_frame *frame ) {
{ fprintf( stderr, "\nERROR: " );
fprintf(stderr, "\nERROR: "); print( stderr, message );
print(stderr, message); fprintf( stderr,
fprintf(stderr, "\n\nAn exception was thrown and I've no idea what to do now\n" );
"\n\nAn exception was thrown and I've no idea what to do now\n");
exit(1); exit( 1 );
} }

52
src/lispops.h
View file

@ -22,38 +22,38 @@
/* /*
* special forms * special forms
*/ */
struct cons_pointer lisp_eval(struct cons_pointer args, struct cons_pointer lisp_eval( struct cons_pointer args,
struct cons_pointer env,
struct stack_frame *frame);
struct cons_pointer lisp_apply(struct cons_pointer args,
struct cons_pointer env, struct cons_pointer env,
struct stack_frame *frame); struct stack_frame *frame );
struct cons_pointer lisp_quote(struct cons_pointer args, struct cons_pointer lisp_apply( struct cons_pointer args,
struct cons_pointer env, struct cons_pointer env,
struct stack_frame *frame); struct stack_frame *frame );
struct cons_pointer lisp_quote( struct cons_pointer args,
struct cons_pointer env,
struct stack_frame *frame );
/* /*
* functions * functions
*/ */
struct cons_pointer lisp_cons(struct stack_frame *frame, struct cons_pointer lisp_cons( struct stack_frame *frame,
struct cons_pointer env); struct cons_pointer env );
struct cons_pointer lisp_car(struct stack_frame *frame, struct cons_pointer lisp_car( struct stack_frame *frame,
struct cons_pointer env); struct cons_pointer env );
struct cons_pointer lisp_cdr(struct stack_frame *frame, struct cons_pointer lisp_cdr( struct stack_frame *frame,
struct cons_pointer env); struct cons_pointer env );
struct cons_pointer lisp_assoc(struct stack_frame *frame, struct cons_pointer lisp_assoc( struct stack_frame *frame,
struct cons_pointer env); struct cons_pointer env );
struct cons_pointer lisp_eq(struct stack_frame *frame, struct cons_pointer lisp_eq( struct stack_frame *frame,
struct cons_pointer env); struct cons_pointer env );
struct cons_pointer lisp_equal(struct stack_frame *frame, struct cons_pointer lisp_equal( struct stack_frame *frame,
struct cons_pointer env); struct cons_pointer env );
struct cons_pointer lisp_read(struct stack_frame *frame, struct cons_pointer lisp_read( struct stack_frame *frame,
struct cons_pointer env); struct cons_pointer env );
struct cons_pointer lisp_print(struct stack_frame *frame, struct cons_pointer lisp_print( struct stack_frame *frame,
struct cons_pointer env); struct cons_pointer env );
/* /*
* neither, at this stage, really * neither, at this stage, really
*/ */
struct cons_pointer lisp_throw(struct cons_pointer message, struct cons_pointer lisp_throw( struct cons_pointer message,
struct stack_frame *frame); struct stack_frame *frame );

81
src/print.c
View file

@ -22,94 +22,89 @@
#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 ) ) {
if (stringp(pointer) || symbolp(pointer)) { struct cons_space_object *cell = &pointer2cell( pointer );
struct cons_space_object *cell = &pointer2cell(pointer);
wint_t c = cell->payload.string.character; 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 void
print_list_contents(FILE * output, struct cons_pointer pointer, print_list_contents( FILE * output, struct cons_pointer pointer,
bool initial_space) bool initial_space ) {
{ struct cons_space_object *cell = &pointer2cell( pointer );
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 * Because tags have values as well as bytes, this if ... else if
* statement can ultimately be replaced by a switch, which will be neater. * statement can ultimately be replaced by a switch, which will be neater.
*/ */
switch (cell.tag.value) { switch ( cell.tag.value ) {
case CONSTV: case CONSTV:
print_list(output, pointer); print_list( output, pointer );
break; break;
case INTEGERTV: case INTEGERTV:
fwprintf(output, L"%ld", cell.payload.integer.value); fwprintf( output, L"%ld", cell.payload.integer.value );
break; break;
case NILTV: case NILTV:
fwprintf(output, L"nil"); fwprintf( output, L"nil" );
break; 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, fwprintf( stderr,
L"Error: Unrecognised tag value %d (%c%c%c%c)\n", L"Error: Unrecognised tag value %d (%c%c%c%c)\n",
cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1], cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1],
cell.tag.bytes[2], cell.tag.bytes[3]); cell.tag.bytes[2], cell.tag.bytes[3] );
break; 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

139
src/read.c
View file

@ -12,7 +12,7 @@
#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>
@ -26,20 +26,20 @@
/* /*
* for the time being things which may be read are: strings numbers - either * for the time being things which may be read are: strings numbers - either
* integer or real, but not yet including ratios or bignums lists Can't read * integer or real, but not yet including ratios or bignums lists Can't read
* atoms because I don't yet know what an atom is or how it's stored. * atoms because I don't yet know what an atom is or how it's stored.
*/ */
struct cons_pointer read_number(FILE * input, wint_t initial); struct cons_pointer read_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" ),
return make_cons(c_string_to_lisp_symbol("quote"), make_cons(arg, NIL)); make_cons( arg, NIL ) );
} }
/** /**
@ -47,32 +47,31 @@ struct cons_pointer c_quote(struct cons_pointer arg)
* treating this initial character as the first character of the object * 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 = fgetwc(input)); c == '\0' || iswblank( c ) || iswcntrl( c ); 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 );
} }
} }
@ -82,36 +81,38 @@ struct cons_pointer read_continuation(FILE * input, wint_t initial)
/** /**
* read a number from this input stream, given this initial character. * 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 ) {
{ long int accumulator = 0;
int accumulator = 0;
int places_of_decimals = 0; int places_of_decimals = 0;
bool seen_period = false; bool seen_period = false;
wint_t c; 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)) { for ( c = initial; iswdigit( c ) || c == btowc( '.' );
if (c == btowc('.')) { c = fgetwc( input ) ) {
if ( c == btowc( '.' ) ) {
seen_period = true; seen_period = true;
} else { } else {
accumulator = accumulator * 10 + ((int) c - (int) '0'); accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' );
if (seen_period) { fprintf( stderr, "Added character %c, accumulator now %ld\n", c, accumulator);
if ( seen_period ) {
places_of_decimals++; places_of_decimals++;
} }
} }
} }
/* /*
* push back the character read which was not a digit * push back the character read which was not a digit
*/ */
ungetwc(c, input); ungetwc( c, input );
if (seen_period) { 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 );
} }
} }
@ -119,86 +120,85 @@ struct cons_pointer read_number(FILE * input, wint_t initial)
* Read a list from this input stream, which no longer contains the opening * 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,
struct cons_pointer car = read_continuation(input, initial); initial );
result = make_cons(car, read_list(input, fgetwc(input))); struct cons_pointer car = read_continuation( input, initial );
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
* not contain a double quote character (unless escaped), or one not * not contain a double quote character (unless escaped), or one not
* 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 cdr = NIL;
struct cons_pointer result; struct cons_pointer result;
fwprintf(stderr, L"read_string starting '%C' (%d)\n", initial, initial); fwprintf( stderr, L"read_string starting '%C' (%d)\n", initial, initial );
switch (initial) { switch ( initial ) {
case '\0': 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; return result;
} }
struct cons_pointer read_symbol(FILE * input, wint_t initial) struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
{
struct cons_pointer cdr = NIL; struct cons_pointer cdr = NIL;
struct cons_pointer result; struct cons_pointer result;
fwprintf(stderr, L"read_symbol starting '%C' (%d)\n", initial, initial); fwprintf( stderr, L"read_symbol starting '%C' (%d)\n", initial, initial );
switch (initial) { switch ( initial ) {
case '\0': case '\0':
result = make_symbol(initial, NIL); result = make_symbol( initial, NIL );
break; break;
case '"': case '"':
/* /*
* THIS IS NOT A GOOD IDEA, but is legal * THIS IS NOT A GOOD IDEA, but is legal
*/ */
result = make_symbol(initial, read_symbol(input, fgetwc(input))); result = make_symbol( initial, read_symbol( input, fgetwc( input ) ) );
break; break;
case ')': case ')':
/* /*
* unquoted strings may not include right-parenthesis * unquoted strings may not include right-parenthesis
*/ */
result = make_symbol('\0', NIL); result = make_symbol( '\0', NIL );
/* /*
* push back the character read * push back the character read
*/ */
ungetwc(initial, input); ungetwc( initial, input );
break; break;
default: default:
if (iswblank(initial) || !iswprint(initial)) { if ( iswblank( initial ) || !iswprint( initial ) ) {
result = make_symbol('\0', NIL); result = make_symbol( '\0', NIL );
/* /*
* push back the character read * push back the character read
*/ */
ungetwc(initial, input); ungetwc( initial, input );
} else { } else {
result = make_symbol(initial, read_symbol(input, fgetwc(input))); result =
make_symbol( initial, read_symbol( input, fgetwc( input ) ) );
} }
break; break;
} }
@ -209,7 +209,6 @@ struct cons_pointer read_symbol(FILE * input, wint_t initial)
/** /**
* Read the next object on this input stream and return a cons_pointer to it. * 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

7
src/real.c
View file

@ -14,10 +14,9 @@
* @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_pointer result = allocate_cell(REALTAG); struct cons_space_object *cell = &pointer2cell( result );
struct cons_space_object *cell = &pointer2cell(result);
cell->payload.real.value = value; cell->payload.real.value = value;
return result; return result;

2
src/real.h
View file

@ -24,7 +24,7 @@ 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
} }

27
src/repl.c
View file

@ -22,21 +22,22 @@
* @param show_prompt true if prompts should be shown. * @param show_prompt true if prompts should be shown.
*/ */
void void
repl(FILE * in_stream, FILE * out_stream, FILE * error_stream, repl( FILE * in_stream, FILE * out_stream, FILE * error_stream,
bool show_prompt) bool show_prompt ) {
{ 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,
if (show_prompt) { input.offset );
fwprintf(out_stream, L"\n-> "); if ( show_prompt ) {
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 );
} }
} }

4
src/repl.h
View file

@ -25,8 +25,8 @@ 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, void repl( FILE * in_stream, FILE * out_stream,
FILE * error_stream, bool show_prompt); FILE * error_stream, bool show_prompt );
#ifdef __cplusplus #ifdef __cplusplus
} }

45
src/stack.c
View file

@ -29,14 +29,13 @@
* 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 * TODO: later, pop a frame off a free-list of stack frames
*/ */
struct stack_frame *result = malloc(sizeof(struct stack_frame)); struct stack_frame *result = malloc( sizeof( struct stack_frame ) );
result->previous = previous; result->previous = previous;
@ -47,27 +46,27 @@ struct stack_frame *make_stack_frame(struct stack_frame *previous,
result->more = NIL; result->more = NIL;
result->function = 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 int i = 0; /* still an index into args, so same name will
* do */ * do */
while (!nilp(args)) { /* iterate down the arg list filling in the while ( !nilp( args ) ) { /* iterate down the arg list filling in the
* arg slots in the frame. When there are no * arg slots in the frame. When there are no
* more slots, if there are still args, stash * more slots, if there are still args, stash
* them on more */ * them on more */
struct cons_space_object cell = pointer2cell(args); struct cons_space_object cell = pointer2cell( args );
if (i < args_in_frame) { if ( i < args_in_frame ) {
/* /*
* TODO: if we were running on real massively parallel hardware, * TODO: if we were running on real massively parallel hardware,
* each arg except the first should be handed off to another * each arg except the first should be handed off to another
* processor to be evaled in parallel * processor to be evaled in parallel
*/ */
result->arg[i] = lisp_eval(cell.payload.cons.car, env, result); result->arg[i] = lisp_eval( cell.payload.cons.car, env, result );
inc_ref(result->arg[i]); inc_ref( result->arg[i] );
args = cell.payload.cons.cdr; args = cell.payload.cons.cdr;
} else { } else {
@ -75,7 +74,7 @@ struct stack_frame *make_stack_frame(struct stack_frame *previous,
* TODO: this isn't right. These args should also each be evaled. * TODO: this isn't right. These args should also each be evaled.
*/ */
result->more = args; result->more = args;
inc_ref(result->more); inc_ref( result->more );
args = NIL; args = NIL;
} }
@ -87,36 +86,34 @@ struct stack_frame *make_stack_frame(struct stack_frame *previous,
/** /**
* 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 * TODO: later, push it back on the stack-frame freelist
*/ */
for (int i = 0; i < args_in_frame; i++) { for ( int i = 0; i < args_in_frame; i++ ) {
dec_ref(frame->arg[i]); dec_ref( frame->arg[i] );
} }
dec_ref(frame->more); dec_ref( frame->more );
free(frame); free( frame );
} }
/** /**
* Fetch a pointer to the value of the local variable at this index. * 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) { if ( index < args_in_frame ) {
result = frame->arg[index]; result = frame->arg[index];
} else { } else {
struct cons_pointer p = frame->more; struct cons_pointer p = frame->more;
for (int i = args_in_frame; i < index; i++) { for ( int i = args_in_frame; i < index; i++ ) {
p = pointer2cell(p).payload.cons.cdr; p = pointer2cell( p ).payload.cons.cdr;
} }
result = pointer2cell(p).payload.cons.car; result = pointer2cell( p ).payload.cons.car;
} }
return result; return result;

10
src/stack.h
View file

@ -24,11 +24,11 @@
#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 * struct stack_frame is defined in consspaceobject.h to break circularity