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

Merge branch 'release/0.0.1'

Browse source
This commit is contained in:
Simon Brooke 2017-10-15 18:31:26 +01:00
parent 34c30f3ede 05854725c8
commit 9d44915c6e
44 changed files with 1749 additions and 941 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
.gitignore vendored
View file

@ -1,6 +1,14 @@
*.o
*.d
*.o
target/
nbproject/
*~
src/\.#*
*.log

20
Makefile
View file

@ -8,16 +8,28 @@ DEPS := $(OBJS:.o=.d)
INC_DIRS := $(shell find $(SRC_DIRS) -type d)
INC_FLAGS := $(addprefix -I,$(INC_DIRS))
INDENT_FLAGS := -kr -br -brf -brs -ce -cdw -npsl -nut -prs -l79 -ts2
VERSION := "0.0.0"
CPPFLAGS ?= $(INC_FLAGS) -MMD -MP
CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g
LDFLAGS := -lm
$(TARGET): $(OBJS)
$(CC) $(LDFLAGS) $(OBJS) -DVERSION=$(VERSION) -o $@ $(LOADLIBES) $(LDLIBS)
$(TARGET): $(OBJS) Makefile
$(CC) $(LDFLAGS) $(OBJS) -DVERSION=$(VERSION) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS)
format:
indent $(INDENT_FLAGS) $(SRCS) src/*.h
test:
bash ./unit-tests.sh
.PHONY: clean
clean:
$(RM) $(TARGET) $(OBJS) $(DEPS)
$(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~
repl:
$(TARGET) -p 2> psse.log
-include $(DEPS)

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)
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)

2
include/licence-header.txt Normal file
View file

@ -0,0 +1,2 @@
(c) 2017 Simon Brooke <simon@journeyman.cc>
Licensed under GPL version 2.0, or, at your option, any later version.

207
src/conspage.c
View file

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

46
src/conspage.h
View file

@ -3,31 +3,40 @@
#ifndef __conspage_h
#define __conspage_h
/**
* the number of cons cells on a cons page. The maximum value this can be (and consequently,
* the size which, by version 1, it will default to) is the maximum value of an unsigned 32
* bit integer, which is to say 4294967296. However, we'll start small.
* the number of cons cells on a cons page. The maximum value this can
* be (and consequently, the size which, by version 1, it will default
* to) is the maximum value of an unsigned 32 bit integer, which is to
* say 4294967296. However, we'll start small.
*/
#define CONSPAGESIZE 8
/**
* the number of cons pages we will initially allow for. For convenience we'll set up an array
* of cons pages this big; however, later we will want a mechanism for this to be able to grow
* dynamically to the maximum we can currently allow, which is 4294967296.
* the number of cons pages we will initially allow for. For
* convenience we'll set up an array of cons pages this big; however,
* later we will want a mechanism for this to be able to grow
* dynamically to the maximum we can currently allow, which is
* 4294967296.
*
* Note that this means the total number of addressable cons cells is
* 1.8e19, each of 20 bytes; or 3e20 bytes in total; and there are
* up to a maximum of 4e9 of heap space objects, each of potentially
* 4e9 bytes. So we're talking about a potential total of 8e100 bytes
* of addressable memory, which is only slightly more than the
* number of atoms in the universe.
*/
#define NCONSPAGES 8
/**
* a cons page is essentially just an array of cons space objects. It might later have a local
* free list (i.e. list of free cells on this page) and a pointer to the next cons page, but
* my current view is that that's probably unneccessary.
* a cons page is essentially just an array of cons space objects. It
* might later have a local free list (i.e. list of free cells on this
* page) and a pointer to the next cons page, but my current view is
* that that's probably unneccessary.
*/
struct cons_page {
struct cons_space_object cell[CONSPAGESIZE];
struct cons_space_object cell[CONSPAGESIZE];
};
/**
* The (global) pointer to the (global) freelist. Not sure whether this ultimately
* belongs in this file.
@ -37,8 +46,7 @@ extern struct cons_pointer freelist;
/**
* An array of pointers to cons pages.
*/
extern struct cons_page* conspages[NCONSPAGES];
extern struct cons_page *conspages[NCONSPAGES];
/**
* Frees the cell at the specified pointer. Dangerous, primitive, low
@ -46,8 +54,7 @@ extern struct cons_page* conspages[NCONSPAGES];
*
* @pointer the cell to free
*/
void free_cell(struct cons_pointer pointer);
void free_cell( struct cons_pointer pointer );
/**
* Allocates a cell with the specified tag. Dangerous, primitive, low
@ -56,17 +63,16 @@ void free_cell(struct cons_pointer pointer);
* @param tag the tag of the cell to allocate - must be a valid cons space tag.
* @return the cons pointer which refers to the cell allocated.
*/
struct cons_pointer allocate_cell( char* tag);
struct cons_pointer allocate_cell( char *tag );
/**
* initialise the cons page system; to be called exactly once during startup.
*/
void initialise_cons_pages();
void initialise_cons_pages( );
/**
* dump the allocated pages to this output stream.
*/
void dump_pages( FILE* output);
void dump_pages( FILE * output );
#endif

248
src/consspaceobject.c
View file

@ -11,150 +11,176 @@
#include <stdint.h>
#include <stdlib.h>
#include <string.h>
/* wide characters */
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include "conspage.h"
#include "consspaceobject.h"
#include "print.h"
/**
* Check that the tag on the cell at this pointer is this tag
*/
int check_tag( struct cons_pointer pointer, char* tag) {
struct cons_space_object cell = pointer2cell(pointer);
return strncmp( &cell.tag.bytes[0], tag, TAGLENGTH) == 0;
int check_tag( struct cons_pointer pointer, char *tag ) {
struct cons_space_object cell = pointer2cell( pointer );
return strncmp( &cell.tag.bytes[0], tag, TAGLENGTH ) == 0;
}
/**
* increment the reference count of the object at this cons pointer.
*
* You can't roll over the reference count. Once it hits the maximum
* value you cannot increment further.
*/
void inc_ref( struct cons_pointer pointer) {
struct cons_space_object* cell = &pointer2cell( pointer);
void inc_ref( struct cons_pointer pointer ) {
struct cons_space_object *cell = &pointer2cell( pointer );
if (cell->count < MAXREFERENCE) {
cell->count ++;
}
if ( cell->count < MAXREFERENCE ) {
cell->count++;
}
}
/**
* Decrement the reference count of the object at this cons pointer.
*
* If a count has reached MAXREFERENCE it cannot be decremented.
* If a count is decremented to zero the cell should be freed.
*/
void dec_ref( struct cons_pointer pointer) {
struct cons_space_object* cell = &pointer2cell( pointer);
void dec_ref( struct cons_pointer pointer ) {
struct cons_space_object *cell = &pointer2cell( pointer );
if (cell->count <= MAXREFERENCE) {
cell->count --;
if ( cell->count <= MAXREFERENCE ) {
cell->count--;
if (cell->count == 0) {
free_cell( pointer);
if ( cell->count == 0 ) {
free_cell( pointer );
}
}
}
}
/**
* dump the object at this cons_pointer to this output stream.
*/
void dump_object( FILE* output, struct cons_pointer pointer) {
struct cons_space_object cell = pointer2cell(pointer);
fprintf( output,
"\tDumping object at page %d, offset %d with tag %c%c%c%c (%d), count %u\n",
pointer.page,
pointer.offset,
cell.tag.bytes[0],
cell.tag.bytes[1],
cell.tag.bytes[2],
cell.tag.bytes[3],
cell.tag.value,
cell.count);
void dump_object( FILE * output, struct cons_pointer pointer ) {
struct cons_space_object cell = pointer2cell( pointer );
fwprintf( output,
L"\tDumping %c%c%c%c (%d) at page %d, offset %d count %u\n",
cell.tag.bytes[0],
cell.tag.bytes[1],
cell.tag.bytes[2],
cell.tag.bytes[3],
cell.tag.value, pointer.page, pointer.offset, cell.count );
if ( check_tag(pointer, CONSTAG)) {
fprintf( output,
"\tCons cell: car at page %d offset %d, cdr at page %d offset %d\n",
cell.payload.cons.car.page, cell.payload.cons.car.offset,
cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset);
} else if ( check_tag(pointer, INTEGERTAG)) {
fprintf( output, "\t\tInteger cell: value %ld\n", cell.payload.integer.value);
} else if ( check_tag( pointer, FREETAG)) {
fprintf( output, "\t\tFree cell: next at page %d offset %d\n",
cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset);
} else if ( check_tag(pointer, REALTAG)) {
fprintf( output, "\t\tReal cell: value %Lf\n", cell.payload.real.value);
} else if ( check_tag( pointer, STRINGTAG)) {
fwprintf( output, L"\t\tString cell: character '%C' next at page %d offset %d\n",
cell.payload.string.character, cell.payload.string.cdr.page,
cell.payload.string.cdr.offset);
};
switch ( cell.tag.value ) {
case CONSTV:
fwprintf( output,
L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u\n",
cell.payload.cons.car.page,
cell.payload.cons.car.offset,
cell.payload.cons.cdr.page,
cell.payload.cons.cdr.offset, cell.count );
break;
case INTEGERTV:
fwprintf( output,
L"\t\tInteger cell: value %ld, count %u\n",
cell.payload.integer.value, cell.count );
break;
case FREETV:
fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n",
cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset );
break;
case REALTV:
fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n",
cell.payload.real.value, cell.count );
break;
case STRINGTV:
fwprintf( output,
L"\t\tString cell: character '%1c' (%1d) next at page %2d offset %3d, count %u\n",
cell.payload.string.character,
cell.payload.string.cdr.page,
cell.payload.string.cdr.offset, cell.count );
fwprintf( output, L"\t\t value: " );
print( output, pointer );
fwprintf( output, L"\n" );
break;
case SYMBOLTV:
fwprintf( output,
L"\t\tSymbol cell: character '%1c' (%1d) next at page %2d offset %3d, count %u\n",
cell.payload.string.character,
cell.payload.string.cdr.page,
cell.payload.string.cdr.offset, cell.count );
fwprintf( output, L"\t\t value:" );
print( output, pointer );
fwprintf( output, L"\n" );
break;
}
}
/**
* Construct a cons cell from this pair of pointers.
*/
struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer cdr) {
struct cons_pointer pointer = NIL;
struct cons_pointer make_cons( struct cons_pointer car,
struct cons_pointer cdr ) {
struct cons_pointer pointer = NIL;
pointer = allocate_cell( CONSTAG);
pointer = allocate_cell( CONSTAG );
struct cons_space_object* cell = &conspages[pointer.page]->cell[pointer.offset];
struct cons_space_object *cell =
&conspages[pointer.page]->cell[pointer.offset];
inc_ref(car);
inc_ref(cdr);
cell->payload.cons.car = car;
cell->payload.cons.cdr = cdr;
inc_ref( car );
inc_ref( cdr );
cell->payload.cons.car = car;
cell->payload.cons.cdr = cdr;
return pointer;
return pointer;
}
/**
* Construct a cell which points to an executable Lisp special form.
*/
struct cons_pointer make_function( struct cons_pointer src,
struct cons_pointer (*executable)
(struct stack_frame*, struct cons_pointer)) {
struct cons_pointer pointer = allocate_cell( FUNCTIONTAG);
struct cons_space_object* cell = &pointer2cell(pointer);
struct cons_pointer
make_function( struct cons_pointer src, struct cons_pointer ( *executable )
( struct stack_frame *, struct cons_pointer ) ) {
struct cons_pointer pointer = allocate_cell( FUNCTIONTAG );
struct cons_space_object *cell = &pointer2cell( pointer );
cell->payload.function.source = src;
cell->payload.function.executable = executable;
cell->payload.function.source = src;
cell->payload.function.executable = executable;
return pointer;
return pointer;
}
/**
* Construct a string from this character (which later will be UTF) and
* this tail. A string is implemented as a flat list of cells each of which
* has one character and a pointer to the next; in the last cell the
* pointer to next is NIL.
*/
struct cons_pointer make_string_like_thing( wint_t c,
struct cons_pointer tail,
char* tag) {
struct cons_pointer pointer = NIL;
if ( check_tag( tail, tag) || check_tag( tail, NILTAG)) {
pointer = allocate_cell( tag);
struct cons_space_object* cell = &pointer2cell(pointer);
struct cons_pointer
make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) {
struct cons_pointer pointer = NIL;
inc_ref(tail);
cell->payload.string.character = c;
cell->payload.string.cdr.page = tail.page;
cell->payload.string.cdr.offset = tail.offset;
} else {
fprintf( stderr, "Warning: only NIL and %s can be appended to %s\n",
tag, tag);
}
return pointer;
if ( check_tag( tail, tag ) || check_tag( tail, NILTAG ) ) {
pointer = allocate_cell( tag );
struct cons_space_object *cell = &pointer2cell( pointer );
inc_ref( tail );
cell->payload.string.character = c;
cell->payload.string.cdr.page = tail.page;
/* TODO: There's a problem here. Sometimes the offsets on
* strings are quite massively off. */
cell->payload.string.cdr.offset = tail.offset;
} else {
fwprintf( stderr,
L"Warning: only NIL and %s can be appended to %s\n",
tag, tag );
}
return pointer;
}
/**
@ -163,56 +189,54 @@ struct cons_pointer make_string_like_thing( wint_t c,
* has one character and a pointer to the next; in the last cell the
* pointer to next is NIL.
*/
struct cons_pointer make_string( wint_t c, struct cons_pointer tail) {
return make_string_like_thing( c, tail, STRINGTAG);
struct cons_pointer make_string( wint_t c, struct cons_pointer tail ) {
return make_string_like_thing( c, tail, STRINGTAG );
}
/**
* Construct a symbol from this character and this tail.
*/
struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail) {
return make_string_like_thing( c, tail, SYMBOLTAG);
struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) {
return make_string_like_thing( c, tail, SYMBOLTAG );
}
/**
* Construct a cell which points to an executable Lisp special form.
*/
struct cons_pointer make_special( struct cons_pointer src,
struct cons_pointer (*executable)
(struct cons_pointer s_expr,
struct cons_pointer env,
struct stack_frame* frame)) {
struct cons_pointer pointer = allocate_cell( SPECIALTAG);
struct cons_space_object* cell = &pointer2cell(pointer);
struct cons_pointer
make_special( struct cons_pointer src, struct cons_pointer ( *executable )
( struct stack_frame * frame, struct cons_pointer env ) ) {
struct cons_pointer pointer = allocate_cell( SPECIALTAG );
struct cons_space_object *cell = &pointer2cell( pointer );
cell->payload.special.source = src;
cell->payload.special.executable = executable;
return pointer;
cell->payload.special.source = src;
cell->payload.special.executable = executable;
return pointer;
}
/**
* Return a lisp string representation of this old skool ASCII string.
*/
struct cons_pointer c_string_to_lisp_string( char* string) {
struct cons_pointer result = NIL;
struct cons_pointer c_string_to_lisp_string( char *string ) {
struct cons_pointer result = NIL;
for ( int i = strlen( string); i > 0; i--) {
result = make_string( (wint_t)string[ i - 1], result);
}
for ( int i = strlen( string ); i > 0; i-- ) {
result = make_string( ( wint_t ) string[i - 1], result );
}
return result;
return result;
}
/**
* Return a lisp symbol representation of this old skool ASCII string.
*/
struct cons_pointer c_string_to_lisp_symbol( char* symbol) {
struct cons_pointer result = NIL;
struct cons_pointer c_string_to_lisp_symbol( char *symbol ) {
struct cons_pointer result = NIL;
for ( int i = strlen( symbol); i > 0; i--) {
result = make_symbol( (wint_t)symbol[ i - 1], result);
}
for ( int i = strlen( symbol ); i > 0; i-- ) {
result = make_symbol( ( wint_t ) symbol[i - 1], result );
}
return result;
return result;
}

208
src/consspaceobject.h
View file

@ -11,7 +11,9 @@
#include <stdbool.h>
#include <stdint.h>
#include <stdio.h>
/* wide characters */
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
@ -67,6 +69,7 @@
* A real number.
*/
#define REALTAG "REAL"
#define REALTV 1279346002
/**
* A special form - one whose arguments are not pre-evaluated but passed as a
@ -153,7 +156,7 @@
#define stringp(conspoint) (check_tag(conspoint,STRINGTAG))
/**
* true if conspointer points to a string cell, else false
* true if conspointer points to a symbol cell, else false
*/
#define symbolp(conspoint) (check_tag(conspoint,SYMBOLTAG))
@ -200,11 +203,14 @@
* An indirect pointer to a cons cell
*/
struct cons_pointer {
uint32_t page; /* the index of the page on which this cell resides */
uint32_t offset; /* the index of the cell within the page */
uint32_t page; /* the index of the page on which this cell
* resides */
uint32_t offset; /* the index of the cell within the page */
};
/* number of arguments stored in a stack frame */
/*
* number of arguments stored in a stack frame
*/
#define args_in_frame 8
/**
@ -212,20 +218,21 @@ struct cons_pointer {
* here to avoid circularity. TODO: refactor.
*/
struct stack_frame {
struct stack_frame* previous; /* the previous frame */
struct cons_pointer arg[args_in_frame];
/* first 8 arument bindings */
struct cons_pointer more; /* list of any further argument
* bindings */
struct cons_pointer function; /* the function to be called */
struct stack_frame *previous; /* the previous frame */
struct cons_pointer arg[args_in_frame];
/*
* first 8 arument bindings
*/
struct cons_pointer more; /* list of any further argument bindings */
struct cons_pointer function; /* the function to be called */
};
/**
* payload of a cons cell.
*/
struct cons_payload {
struct cons_pointer car;
struct cons_pointer cdr;
struct cons_pointer car;
struct cons_pointer cdr;
};
/**
@ -236,10 +243,11 @@ struct cons_payload {
* (representing its stack frame) and a cons pointer (representing its
* environment) as arguments and returns a cons pointer (representing its
* result).
*/
*/
struct function_payload {
struct cons_pointer source;
struct cons_pointer (*executable)(struct stack_frame*, struct cons_pointer);
struct cons_pointer source;
struct cons_pointer ( *executable ) ( struct stack_frame *,
struct cons_pointer );
};
/**
@ -247,8 +255,8 @@ struct function_payload {
* but it may not be so in future.
*/
struct free_payload {
struct cons_pointer car;
struct cons_pointer cdr;
struct cons_pointer car;
struct cons_pointer cdr;
};
/**
@ -257,7 +265,7 @@ struct free_payload {
* optional bignum object.
*/
struct integer_payload {
long int value;
long int value;
};
/**
@ -265,7 +273,7 @@ struct integer_payload {
* precision, but I'm not sure of the detail.
*/
struct real_payload {
long double value;
long double value;
};
/**
@ -279,19 +287,18 @@ struct real_payload {
*
* NOTE that this means that special forms do not appear on the lisp stack,
* which may be confusing. TODO: think about this.
*/
*/
struct special_payload {
struct cons_pointer source;
struct cons_pointer (*executable)(struct cons_pointer s_expr,
struct cons_pointer env,
struct stack_frame* frame);
struct cons_pointer source;
struct cons_pointer ( *executable ) ( struct stack_frame *,
struct cons_pointer );
};
/**
* payload of a read or write stream cell.
*/
struct stream_payload {
FILE * stream;
FILE *stream;
};
/**
@ -301,124 +308,147 @@ struct stream_payload {
* payload of a string cell.
*/
struct string_payload {
wint_t character; /* the actual character stored in this cell */
uint32_t padding; /* unused padding to word-align the cdr */
struct cons_pointer cdr;
wint_t character; /* the actual character stored in this cell */
uint32_t padding; /* unused padding to word-align the cdr */
struct cons_pointer cdr;
};
struct vectorp_payload {
union {
char bytes[TAGLENGTH]; /* the tag (type) of the vector-space
* object this cell points to, considered
* as bytes. NOTE that the vector space
* object should itself have the identical tag. */
uint32_t value; /* the tag considered as a number */
} tag;
uint64_t address; /* the address of the actual vector space
* object (TODO: will change when I actually
* implement vector space) */
union {
char bytes[TAGLENGTH]; /* the tag (type) of the
* vector-space object this cell
* points to, considered as bytes.
* NOTE that the vector space object
* should itself have the identical
* tag. */
uint32_t value; /* the tag considered as a number */
} tag;
uint64_t address; /* the address of the actual vector space
* object (TODO: will change when I actually
* implement vector space) */
};
/**
* an object in cons space.
*/
struct cons_space_object {
union {
char bytes[TAGLENGTH]; /* the tag (type) of this cell, considered as bytes */
uint32_t value; /* the tag considered as a number */
} tag;
uint32_t count; /* the count of the number of references to this cell */
struct cons_pointer access; /* cons pointer to the access control list of this cell */
union {
/* if tag == CONSTAG */
struct cons_payload cons;
/* if tag == FREETAG */
struct free_payload free;
/* if tag == FUNCTIONTAG */
struct function_payload function;
/* if tag == INTEGERTAG */
struct integer_payload integer;
/* if tag == NILTAG; we'll treat the special cell NIL as just a cons */
struct cons_payload nil;
/* if tag == READTAG || tag == WRITETAG */
struct stream_payload stream;
/* if tag == REALTAG */
struct real_payload real;
/* if tag == SPECIALTAG */
struct special_payload special;
/* if tag == STRINGTAG || tag == SYMBOLTAG */
struct string_payload string;
/* if tag == TRUETAG; we'll treat the special cell T as just a cons */
struct cons_payload t;
/* if tag == VECTORPTAG */
struct vectorp_payload vectorp;
} payload;
union {
char bytes[TAGLENGTH]; /* the tag (type) of this cell,
* considered as bytes */
uint32_t value; /* the tag considered as a number */
} tag;
uint32_t count; /* the count of the number of references to
* this cell */
struct cons_pointer access; /* cons pointer to the access control list of
* this cell */
union {
/*
* if tag == CONSTAG
*/
struct cons_payload cons;
/*
* if tag == FREETAG
*/
struct free_payload free;
/*
* if tag == FUNCTIONTAG
*/
struct function_payload function;
/*
* if tag == INTEGERTAG
*/
struct integer_payload integer;
/*
* if tag == NILTAG; we'll treat the special cell NIL as just a cons
*/
struct cons_payload nil;
/*
* if tag == READTAG || tag == WRITETAG
*/
struct stream_payload stream;
/*
* if tag == REALTAG
*/
struct real_payload real;
/*
* if tag == SPECIALTAG
*/
struct special_payload special;
/*
* if tag == STRINGTAG || tag == SYMBOLTAG
*/
struct string_payload string;
/*
* if tag == TRUETAG; we'll treat the special cell T as just a cons
*/
struct cons_payload t;
/*
* if tag == VECTORPTAG
*/
struct vectorp_payload vectorp;
} payload;
};
/**
* Check that the tag on the cell at this pointer is this tag
*/
int check_tag( struct cons_pointer pointer, char* tag);
int check_tag( struct cons_pointer pointer, char *tag );
/**
* increment the reference count of the object at this cons pointer
*/
void inc_ref( struct cons_pointer pointer);
void inc_ref( struct cons_pointer pointer );
/**
* decrement the reference count of the object at this cons pointer
*/
void dec_ref( struct cons_pointer pointer);
void dec_ref( struct cons_pointer pointer );
/**
* dump the object at this cons_pointer to this output stream.
*/
void dump_object( FILE* output, struct cons_pointer pointer);
void dump_object( FILE * output, struct cons_pointer pointer );
struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer cdr);
struct cons_pointer make_cons( struct cons_pointer car,
struct cons_pointer cdr );
/**
* Construct a cell which points to an executable Lisp special form.
*/
struct cons_pointer make_function( struct cons_pointer src,
struct cons_pointer (*executable)
(struct stack_frame*, struct cons_pointer));
struct cons_pointer ( *executable )
( struct stack_frame *,
struct cons_pointer ) );
/**
* Construct a cell which points to an executable Lisp special form.
*/
struct cons_pointer make_special( struct cons_pointer src,
struct cons_pointer (*executable)
(struct cons_pointer s_expr,
struct cons_pointer env,
struct stack_frame* frame));
struct cons_pointer ( *executable )
( struct stack_frame *,
struct cons_pointer ) );
/**
* Construct a string from this character and this tail. A string is
* implemented as a flat list of cells each of which has one character and a
* pointer to the next; in the last cell the pointer to next is NIL.
*/
struct cons_pointer make_string( wint_t c, struct cons_pointer tail);
struct cons_pointer make_string( wint_t c, struct cons_pointer tail );
/**
* Construct a symbol from this character and this tail. A symbol is identical
* to a string except for having a different tag.
*/
struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail);
struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail );
/**
* Return a lisp string representation of this old skool ASCII string.
*/
struct cons_pointer c_string_to_lisp_string( char* string);
struct cons_pointer c_string_to_lisp_string( char *string );
/**
* Return a lisp symbol representation of this old skool ASCII string.
*/
struct cons_pointer c_string_to_lisp_symbol( char* symbol);
struct cons_pointer c_string_to_lisp_symbol( char *symbol );
#endif

98
src/equal.c
View file

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

4
src/equal.h
View file

@ -19,12 +19,12 @@
* Shallow, and thus cheap, equality: true if these two objects are
* the same object, else false.
*/
bool eq( struct cons_pointer a, struct cons_pointer b);
bool eq( struct cons_pointer a, struct cons_pointer b );
/**
* Deep, and thus expensive, equality: true if these two objects have
* identical structure, else false.
*/
bool equal( struct cons_pointer a, struct cons_pointer b);
bool equal( struct cons_pointer a, struct cons_pointer b );
#endif

125
src/init.c
View file

@ -9,60 +9,109 @@
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdbool.h>
#include <stdio.h>
#include <unistd.h>
#include <wchar.h>
#include "version.h"
#include "conspage.h"
#include "consspaceobject.h"
#include "intern.h"
#include "lispops.h"
#include "peano.h"
#include "print.h"
#include "read.h"
#include "repl.h"
void bind_function( char* name, struct cons_pointer (*executable)
(struct stack_frame*, struct cons_pointer)) {
deep_bind( intern( c_string_to_lisp_symbol( name), oblist ),
make_function( NIL, executable));
void bind_function( char *name, struct cons_pointer ( *executable )
( struct stack_frame *, struct cons_pointer ) ) {
deep_bind( c_string_to_lisp_symbol( name ),
make_function( NIL, executable ) );
}
void bind_special( char* name, struct cons_pointer (*executable)
(struct cons_pointer s_expr, struct cons_pointer env,
struct stack_frame* frame)) {
deep_bind( intern( c_string_to_lisp_symbol( name), oblist ),
make_special( NIL, executable));
void bind_special( char *name, struct cons_pointer ( *executable )
( struct stack_frame * frame, struct cons_pointer env ) ) {
deep_bind( c_string_to_lisp_symbol( name ),
make_special( NIL, executable ) );
}
int main (int argc, char *argv[]) {
fprintf( stderr, "Post scarcity software environment version %s\n", VERSION);
initialise_cons_pages();
int main( int argc, char *argv[] ) {
/*
* attempt to set wide character acceptance on all streams
*/
fwide( stdin, 1 );
fwide( stdout, 1 );
fwide( stderr, 1 );
int option;
bool dump_at_end = false;
bool show_prompt = false;
/* privileged variables (keywords) */
deep_bind( intern( c_string_to_lisp_string( "nil"), oblist), NIL);
deep_bind( intern( c_string_to_lisp_string( "t"), oblist), TRUE);
while ( ( option = getopt( argc, argv, "pd" ) ) != -1 ) {
switch ( option ) {
case 'd':
dump_at_end = true;
break;
case 'p':
show_prompt = true;
break;
default:
fwprintf( stderr, L"Unexpected option %c\n", option );
break;
}
}
/* primitive function operations */
bind_function( "assoc", &lisp_assoc);
bind_function( "car", &lisp_car);
bind_function( "cdr", &lisp_cdr);
bind_function( "cons", &lisp_cons);
bind_function( "eq", &lisp_eq);
bind_function( "equal", &lisp_equal);
bind_function( "read", &lisp_read);
bind_function( "print", &lisp_print);
if ( show_prompt ) {
fwprintf( stdout,
L"Post scarcity software environment version %s\n\n",
VERSION );
}
/* primitive special forms */
bind_special( "apply", &lisp_apply);
bind_special( "eval", &lisp_eval);
bind_special( "quote", &lisp_quote);
initialise_cons_pages( );
fprintf( stderr, "\n:: ");
struct cons_pointer input = read( stdin);
fprintf( stderr, "\nread {%d,%d}=> ", input.page, input.offset);
print( stdout, input);
fprintf( stderr, "\neval {%d,%d}=> ", input.page, input.offset);
// print( stdout, lisp_eval( input, oblist, NULL));
/*
* privileged variables (keywords)
*/
dump_pages(stderr);
return(0);
deep_bind( c_string_to_lisp_symbol( "nil" ), NIL );
deep_bind( c_string_to_lisp_symbol( "t" ), TRUE );
/*
* primitive function operations
*/
bind_function( "assoc", &lisp_assoc );
bind_function( "car", &lisp_car );
bind_function( "cdr", &lisp_cdr );
bind_function( "cons", &lisp_cons );
bind_function( "eq", &lisp_eq );
bind_function( "equal", &lisp_equal );
bind_function( "read", &lisp_read );
bind_function( "print", &lisp_print );
bind_function( "type", &lisp_type );
bind_function( "add", &lisp_add );
bind_function( "+", &lisp_add );
bind_function( "multiply", &lisp_multiply );
bind_function( "*", &lisp_multiply );
bind_function( "subtract", &lisp_subtract );
bind_function( "-", &lisp_subtract );
bind_function( "apply", &lisp_apply );
/*
* primitive special forms
*/
bind_special( "eval", &lisp_eval );
bind_special( "quote", &lisp_quote );
/* bind the oblist last, at this stage. Something clever needs to be done
* here and I'm not sure what it is. */
deep_bind( c_string_to_lisp_symbol( "oblist" ), oblist );
repl( stdin, stdout, stderr, show_prompt );
if ( dump_at_end ) {
dump_pages( stdout );
}
return ( 0 );
}

33
src/integer.c
View file

@ -9,6 +9,7 @@
#define _GNU_SOURCE
#include <math.h>
#include <stdio.h>
#include "conspage.h"
#include "consspaceobject.h"
@ -19,28 +20,28 @@
* as a cons-space object. Cell may in principle be any kind of number,
* but only integers and reals are so far implemented.
*/
double numeric_value( struct cons_pointer pointer) {
double result = NAN;
struct cons_space_object* cell = &pointer2cell(pointer);
long double numeric_value( struct cons_pointer pointer ) {
double result = NAN;
struct cons_space_object *cell = &pointer2cell( pointer );
if ( integerp( pointer)) {
result = (double) cell->payload.integer.value;
} else if ( realp( pointer)) {
result = cell->payload.real.value;
}
if ( integerp( pointer ) ) {
result = cell->payload.integer.value * 1.0;
} else if ( realp( pointer ) ) {
result = cell->payload.real.value;
}
return result;
return result;
}
/**
* Allocate an integer cell representing this value and return a cons pointer to it.
*/
struct cons_pointer make_integer( int value) {
struct cons_pointer result = allocate_cell( INTEGERTAG);
struct cons_space_object* cell = &pointer2cell(result);
cell->payload.integer.value = value;
struct cons_pointer make_integer( long int value ) {
struct cons_pointer result = allocate_cell( INTEGERTAG );
struct cons_space_object *cell = &pointer2cell( result );
cell->payload.integer.value = value;
return result;
dump_object( stderr, result );
return result;
}

4
src/integer.h
View file

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

84
src/intern.c
View file

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

16
src/intern.h
View file

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

405
src/lispops.c
View file

@ -37,11 +37,11 @@
/*
* also to create in this section:
* struct cons_pointer lisp_cond( struct cons_pointer args, struct cons_pointer env,
struct stack_frame* frame);
struct stack_frame* frame);
* struct cons_pointer lisp_let( struct cons_pointer args, struct cons_pointer env,
struct stack_frame* frame);
struct stack_frame* frame);
* struct cons_pointer lisp_mapcar( struct cons_pointer args, struct cons_pointer env,
struct stack_frame* frame);
struct stack_frame* frame);
*
* and others I haven't thought of yet.
*/
@ -49,90 +49,86 @@
/**
* Implementation of car in C. If arg is not a cons, does not error but returns nil.
*/
struct cons_pointer c_car( struct cons_pointer arg) {
struct cons_pointer result = NIL;
if ( consp(arg)) {
result = pointer2cell( arg).payload.cons.car;
}
struct cons_pointer c_car( struct cons_pointer arg ) {
struct cons_pointer result = NIL;
return result;
if ( consp( arg ) ) {
result = pointer2cell( arg ).payload.cons.car;
}
return result;
}
/**
* Implementation of cdr in C. If arg is not a cons, does not error but returns nil.
*/
struct cons_pointer c_cdr( struct cons_pointer arg) {
struct cons_pointer result = NIL;
if ( consp(arg)) {
result = pointer2cell( arg).payload.cons.cdr;
}
struct cons_pointer c_cdr( struct cons_pointer arg ) {
struct cons_pointer result = NIL;
return result;
if ( consp( arg ) ) {
result = pointer2cell( arg ).payload.cons.cdr;
}
return result;
}
/**
* (apply fn args...)
*
* I'm now confused about whether at this stage I actually need an apply special form,
* and if so how it differs from eval.
* Internal guts of apply.
* @param frame the stack frame, expected to have only one argument, a list
* comprising something that evaluates to a function and its arguments.
* @param env The evaluation environment.
* @return the result of evaluating the function with its arguments.
*/
struct cons_pointer lisp_apply( struct cons_pointer args, struct cons_pointer env,
struct stack_frame* frame) {
struct cons_pointer result = args;
if ( consp( args)) {
lisp_eval( args, env, frame);
}
struct cons_pointer
c_apply( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer result = NIL;
return result;
}
struct stack_frame *fn_frame = make_empty_frame( frame, env );
fn_frame->arg[0] = c_car( frame->arg[0] );
inc_ref( fn_frame->arg[0] );
struct cons_pointer fn_pointer = lisp_eval( fn_frame, env );
free_stack_frame( fn_frame );
struct cons_pointer eval_cons( struct cons_pointer s_expr, struct cons_pointer env,
struct stack_frame* my_frame) {
struct cons_pointer result = NIL;
struct cons_pointer fn_pointer = lisp_eval( c_car( s_expr), env, my_frame);
struct cons_space_object fn_cell = pointer2cell( fn_pointer);
struct cons_pointer args = c_cdr( s_expr);
struct cons_space_object fn_cell = pointer2cell( fn_pointer );
struct cons_pointer args = c_cdr( frame->arg[0] );
switch ( fn_cell.tag.value) {
case SPECIALTV :
{
struct cons_space_object special = pointer2cell( fn_pointer);
result = (*special.payload.special.executable)( args, env, my_frame);
switch ( fn_cell.tag.value ) {
case SPECIALTV:
{
struct stack_frame *next = make_special_frame( frame, args, env );
result = ( *fn_cell.payload.special.executable ) ( next, env );
free_stack_frame( next );
}
break;
case FUNCTIONTV:
/*
* actually, this is apply
*/
{
struct stack_frame *next = make_stack_frame( frame, args, env );
result = ( *fn_cell.payload.special.executable ) ( next, env );
free_stack_frame( next );
}
break;
default:
{
char *buffer = malloc( 1024 );
memset( buffer, '\0', 1024 );
sprintf( buffer,
"Unexpected cell with tag %d (%c%c%c%c) in function position",
fn_cell.tag.value, fn_cell.tag.bytes[0],
fn_cell.tag.bytes[1], fn_cell.tag.bytes[2],
fn_cell.tag.bytes[3] );
struct cons_pointer message = c_string_to_lisp_string( buffer );
free( buffer );
result = lisp_throw( message, frame );
}
}
break;
case FUNCTIONTV :
/* actually, this is apply */
{
struct cons_space_object function = pointer2cell( fn_pointer);
struct stack_frame* frame = make_stack_frame( my_frame, args, env);
/* the trick: pass the remaining arguments and environment to
the executable code which is the payload of the function
object. */
result = (*function.payload.function.executable)( frame, env);
free_stack_frame( frame);
}
break;
default :
{
char* buffer = malloc( 1024);
memset( buffer, '\0', 1024);
sprintf( buffer,
"Unexpected cell with tag %d (%c%c%c%c) in function position",
fn_cell.tag.value, fn_cell.tag.bytes[0], fn_cell.tag.bytes[1],
fn_cell.tag.bytes[2], fn_cell.tag.bytes[3]);
struct cons_pointer message = c_string_to_lisp_string( buffer);
free( buffer);
result = lisp_throw( message, my_frame);
}
}
return result;
return result;
}
/**
@ -148,42 +144,75 @@ struct cons_pointer eval_cons( struct cons_pointer s_expr, struct cons_pointer e
* passes them in a stack frame as arguments to the function.
* If a special form, passes the cdr of s_expr to the special form as argument.
*/
struct cons_pointer lisp_eval( struct cons_pointer s_expr, struct cons_pointer env,
struct stack_frame* previous) {
struct cons_pointer result = s_expr;
struct cons_space_object cell = pointer2cell( s_expr);
struct stack_frame* my_frame =
make_stack_frame( previous, make_cons( s_expr, NIL), env);
struct cons_pointer
lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer result = frame->arg[0];
struct cons_space_object cell = pointer2cell( frame->arg[0] );
switch ( cell.tag.value) {
case CONSTV :
result = eval_cons( s_expr, env, my_frame);
break;
fputws( L"Eval: ", stderr );
dump_frame( stderr, frame );
case SYMBOLTV :
{
struct cons_pointer canonical = internedp( s_expr, env);
if ( nilp( canonical)) {
struct cons_pointer message =
c_string_to_lisp_string( "Attempt to take value of unbound symbol.");
result = lisp_throw( message, my_frame);
} else {
result = c_assoc( canonical, env);
}
switch ( cell.tag.value ) {
case CONSTV:
result = c_apply( frame, env );
break;
case SYMBOLTV:
{
struct cons_pointer canonical = internedp( frame->arg[0], env );
if ( nilp( canonical ) ) {
struct cons_pointer message =
c_string_to_lisp_string
( "Attempt to take value of unbound symbol." );
result = lisp_throw( message, frame );
} else {
result = c_assoc( canonical, env );
}
}
break;
/*
* the Clojure practice of having a map serve in the function place of
* an s-expression is a good one and I should adopt it; also if the
* object is a consp it could be interpretable source code but in the
* long run I don't want an interpreter, and if I can get away without
* so much the better.
*/
}
break;
/* the Clojure practice of having a map serve in the function
* place of an s-expression is a good one and I should adopt it;
* also if the object is a consp it could be interpretable
* source code but in the long run I don't want an interpreter,
* and if I can get away without so much the better. */
}
free_stack_frame( my_frame);
return result;
fputws( L"Eval returning ", stderr );
print( stderr, result );
fputws( L"\n", stderr );
return result;
}
/**
* (apply fn args)
*
* function. Apply the function which is the result of evaluating the
* first argoment to the list of arguments which is the result of evaluating
* the second argument
*/
struct cons_pointer
lisp_apply( struct stack_frame *frame, struct cons_pointer env ) {
fputws( L"Apply: ", stderr );
dump_frame( stderr, frame );
frame->arg[0] = make_cons( frame->arg[0], frame->arg[1] );
inc_ref( frame->arg[0] );
frame->arg[1] = NIL;
struct cons_pointer result = c_apply( frame, env );
fputws( L"Apply returning ", stderr );
print( stderr, result );
fputws( L"\n", stderr );
return result;
}
/**
* (quote a)
*
@ -191,9 +220,9 @@ struct cons_pointer lisp_eval( struct cons_pointer s_expr, struct cons_pointer e
* Returns its argument (strictly first argument - only one is expected but
* this isn't at this stage checked) unevaluated.
*/
struct cons_pointer lisp_quote( struct cons_pointer args, struct cons_pointer env,
struct stack_frame* frame) {
return c_car( args);
struct cons_pointer
lisp_quote( struct stack_frame *frame, struct cons_pointer env ) {
return frame->arg[0];
}
/**
@ -203,22 +232,24 @@ struct cons_pointer lisp_quote( struct cons_pointer args, struct cons_pointer en
* Returns a cell constructed from a and b. If a is of type string but its
* cdr is nill, and b is of type string, then returns a new string cell;
* otherwise returns a new cons cell.
*/
struct cons_pointer lisp_cons(struct stack_frame* frame, struct cons_pointer env) {
struct cons_pointer car = frame->arg[0];
struct cons_pointer cdr = frame->arg[1];
struct cons_pointer result;
*/
struct cons_pointer
lisp_cons( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer car = frame->arg[0];
struct cons_pointer cdr = frame->arg[1];
struct cons_pointer result;
if ( nilp( car) && nilp( cdr)) {
return NIL;
} else if ( stringp( car) && stringp( cdr) &&
nilp( pointer2cell( car).payload.string.cdr)) {
result = make_string( pointer2cell( car).payload.string.character, cdr);
} else {
result = make_cons( car, cdr);
}
if ( nilp( car ) && nilp( cdr ) ) {
return NIL;
} else if ( stringp( car ) && stringp( cdr ) &&
nilp( pointer2cell( car ).payload.string.cdr ) ) {
result =
make_string( pointer2cell( car ).payload.string.character, cdr );
} else {
result = make_cons( car, cdr );
}
return result;
return result;
}
/**
@ -226,70 +257,74 @@ struct cons_pointer lisp_cons(struct stack_frame* frame, struct cons_pointer env
* Returns the first item (head) of a sequence. Valid for cons cells,
* strings, and TODO read streams and other things which can be considered as sequences.
*/
struct cons_pointer lisp_car(struct stack_frame* frame, struct cons_pointer env) {
struct cons_pointer result = NIL;
struct cons_pointer
lisp_car( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer result = NIL;
if ( consp( frame->arg[ 0])) {
struct cons_space_object cell = pointer2cell( frame->arg[ 0]);
result = cell.payload.cons.car;
} else if ( stringp( frame->arg[ 0])) {
struct cons_space_object cell = pointer2cell( frame->arg[ 0]);
result = make_string( cell.payload.string.character, NIL);
} else {
struct cons_pointer message =
c_string_to_lisp_string( "Attempt to take CAR/CDR of non sequence");
result = lisp_throw( message, frame);
}
if ( consp( frame->arg[0] ) ) {
struct cons_space_object cell = pointer2cell( frame->arg[0] );
result = cell.payload.cons.car;
} else if ( stringp( frame->arg[0] ) ) {
struct cons_space_object cell = pointer2cell( frame->arg[0] );
result = make_string( cell.payload.string.character, NIL );
} else {
struct cons_pointer message =
c_string_to_lisp_string( "Attempt to take CAR of non sequence" );
result = lisp_throw( message, frame );
}
return result;
return result;
}
/**
* (cdr s_expr)
* Returns the remainder of a sequence when the head is removed. Valid for cons cells,
* strings, and TODO read streams and other things which can be considered as sequences.
*/
struct cons_pointer lisp_cdr(struct stack_frame* frame, struct cons_pointer env) {
struct cons_pointer result = NIL;
struct cons_pointer
lisp_cdr( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer result = NIL;
if ( consp( frame->arg[ 0])) {
struct cons_space_object cell = pointer2cell( frame->arg[ 0]);
result = cell.payload.cons.car;
} else if ( stringp( frame->arg[ 0])) {
struct cons_space_object cell = pointer2cell( frame->arg[ 0]);
result = cell.payload.string.cdr;
} else {
struct cons_pointer message =
c_string_to_lisp_string( "Attempt to take CAR/CDR of non sequence");
result = lisp_throw( message, frame);
}
if ( consp( frame->arg[0] ) ) {
struct cons_space_object cell = pointer2cell( frame->arg[0] );
result = cell.payload.cons.cdr;
} else if ( stringp( frame->arg[0] ) ) {
struct cons_space_object cell = pointer2cell( frame->arg[0] );
result = cell.payload.string.cdr;
} else {
struct cons_pointer message =
c_string_to_lisp_string( "Attempt to take CDR of non sequence" );
result = lisp_throw( message, frame );
}
return result;
return result;
}
/**
* (assoc key store)
* Returns the value associated with key in store, or NIL if not found.
*/
struct cons_pointer lisp_assoc( struct stack_frame* frame, struct cons_pointer env) {
return c_assoc( frame->arg[ 0], frame->arg[ 1]);
struct cons_pointer
lisp_assoc( struct stack_frame *frame, struct cons_pointer env ) {
return c_assoc( frame->arg[0], frame->arg[1] );
}
/**
* (eq a b)
* Returns T if a and b are pointers to the same object, else NIL
*/
struct cons_pointer lisp_eq( struct stack_frame* frame, struct cons_pointer env) {
return eq( frame->arg[ 0], frame->arg[ 1]) ? TRUE : NIL;
struct cons_pointer lisp_eq( struct stack_frame *frame,
struct cons_pointer env ) {
return eq( frame->arg[0], frame->arg[1] ) ? TRUE : NIL;
}
/**
* (eq a b)
* Returns T if a and b are pointers to structurally identical objects, else NIL
*/
struct cons_pointer lisp_equal( struct stack_frame* frame, struct cons_pointer env) {
return equal( frame->arg[ 0], frame->arg[ 1]) ? TRUE : NIL;
struct cons_pointer
lisp_equal( struct stack_frame *frame, struct cons_pointer env ) {
return equal( frame->arg[0], frame->arg[1] ) ? TRUE : NIL;
}
/**
@ -298,43 +333,67 @@ struct cons_pointer lisp_equal( struct stack_frame* frame, struct cons_pointer e
* Read one complete lisp form and return it. If read-stream is specified and
* is a read stream, then read from that stream, else stdin.
*/
struct cons_pointer lisp_read( struct stack_frame* frame, struct cons_pointer env) {
FILE* input = stdin;
struct cons_pointer
lisp_read( struct stack_frame *frame, struct cons_pointer env ) {
FILE *input = stdin;
if ( readp( frame->arg[0])) {
input = pointer2cell( frame->arg[0]).payload.stream.stream;
}
if ( readp( frame->arg[0] ) ) {
input = pointer2cell( frame->arg[0] ).payload.stream.stream;
}
return read( input);
return read( input );
}
/**
* (print expr)
* (print expr write-stream)
* Print one complete lisp form and return NIL. If write-stream is specified and
* is a write stream, then print to that stream, else stdout.
*/
struct cons_pointer lisp_print( struct stack_frame* frame, struct cons_pointer env) {
FILE* output = stdout;
struct cons_pointer
lisp_print( struct stack_frame *frame, struct cons_pointer env ) {
FILE *output = stdout;
if ( writep( frame->arg[1])) {
output = pointer2cell( frame->arg[1]).payload.stream.stream;
}
if ( writep( frame->arg[1] ) ) {
output = pointer2cell( frame->arg[1] ).payload.stream.stream;
}
print( output, frame->arg[0]);
return NIL;
print( output, frame->arg[0] );
return NIL;
}
/**
* Get the Lisp type of the single argument.
* @param frame My stack frame.
* @param env My environment (ignored).
* @return As a Lisp string, the tag of the object which is the argument.
*/
struct cons_pointer
lisp_type( struct stack_frame *frame, struct cons_pointer env ) {
char *buffer = malloc( TAGLENGTH + 1 );
memset( buffer, 0, TAGLENGTH + 1 );
struct cons_space_object cell = pointer2cell( frame->arg[0] );
strncpy( buffer, cell.tag.bytes, TAGLENGTH );
struct cons_pointer result = c_string_to_lisp_string( buffer );
free( buffer );
return result;
}
/**
* TODO: make this do something sensible somehow.
*/
struct cons_pointer lisp_throw( struct cons_pointer message, struct stack_frame* frame) {
fprintf( stderr, "\nERROR: ");
print( stderr, message);
fprintf( stderr, "\n\nAn exception was thrown and I've no idea what to do now\n");
struct cons_pointer
lisp_throw( struct cons_pointer message, struct stack_frame *frame ) {
fwprintf( stderr, L"\nERROR: " );
print( stderr, message );
fwprintf( stderr,
L"\n\nAn exception was thrown and I've no idea what to do now\n" );
exit( 1);
exit( 1 );
}

59
src/lispops.h
View file

@ -19,23 +19,46 @@
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
/* special forms */
struct cons_pointer lisp_eval( struct cons_pointer args, struct cons_pointer env,
struct stack_frame* frame);
struct cons_pointer lisp_apply( struct cons_pointer args, struct cons_pointer env,
struct stack_frame* frame);
struct cons_pointer lisp_quote( struct cons_pointer args, struct cons_pointer env,
struct stack_frame* frame);
/*
* special forms
*/
struct cons_pointer lisp_eval( struct stack_frame *frame,
struct cons_pointer env );
struct cons_pointer lisp_apply( struct stack_frame *frame,
struct cons_pointer env );
struct cons_pointer lisp_quote( struct stack_frame *frame,
struct cons_pointer env );
/* functions */
struct cons_pointer lisp_cons( struct stack_frame* frame, struct cons_pointer env);
struct cons_pointer lisp_car( struct stack_frame* frame, struct cons_pointer env);
struct cons_pointer lisp_cdr( struct stack_frame* frame, struct cons_pointer env);
struct cons_pointer lisp_assoc( struct stack_frame* frame, struct cons_pointer env);
struct cons_pointer lisp_eq( struct stack_frame* frame, struct cons_pointer env);
struct cons_pointer lisp_equal( struct stack_frame* frame, struct cons_pointer env);
struct cons_pointer lisp_read( struct stack_frame* frame, struct cons_pointer env);
struct cons_pointer lisp_print( struct stack_frame* frame, struct cons_pointer env);
/*
* functions
*/
struct cons_pointer lisp_cons( struct stack_frame *frame,
struct cons_pointer env );
struct cons_pointer lisp_car( struct stack_frame *frame,
struct cons_pointer env );
struct cons_pointer lisp_cdr( struct stack_frame *frame,
struct cons_pointer env );
struct cons_pointer lisp_assoc( struct stack_frame *frame,
struct cons_pointer env );
struct cons_pointer lisp_eq( struct stack_frame *frame,
struct cons_pointer env );
struct cons_pointer lisp_equal( struct stack_frame *frame,
struct cons_pointer env );
struct cons_pointer lisp_read( struct stack_frame *frame,
struct cons_pointer env );
struct cons_pointer lisp_print( struct stack_frame *frame,
struct cons_pointer env );
/**
* Get the Lisp type of the single argument.
* @param frame My stack frame.
* @param env My environment (ignored).
* @return As a Lisp string, the tag of the object which is the argument.
*/
struct cons_pointer
lisp_type( struct stack_frame *frame, struct cons_pointer env );
/* neither, at this stage, really */
struct cons_pointer lisp_throw( struct cons_pointer message, struct stack_frame* frame);
/*
* neither, at this stage, really
*/
struct cons_pointer lisp_throw( struct cons_pointer message,
struct stack_frame *frame );

151
src/peano.c Normal file
View file

@ -0,0 +1,151 @@
/**
* peano.c
*
* Basic peano arithmetic
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <ctype.h>
#include <stdbool.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <math.h>
#include "consspaceobject.h"
#include "conspage.h"
#include "equal.h"
#include "integer.h"
#include "intern.h"
#include "lispops.h"
#include "print.h"
#include "read.h"
#include "real.h"
#include "stack.h"
/**
* Add an indefinite number of numbers together
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer or real.
*/
struct cons_pointer
lisp_add( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer result = NIL;
long int i_accumulator = 0;
long double d_accumulator = 0;
bool is_int = true;
for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) {
struct cons_space_object current = pointer2cell( frame->arg[i] );
switch ( current.tag.value ) {
case INTEGERTV:
i_accumulator += current.payload.integer.value;
d_accumulator += numeric_value( frame->arg[i] );
break;
case REALTV:
d_accumulator += current.payload.real.value;
is_int = false;
break;
default:
lisp_throw( c_string_to_lisp_string( "Cannot add: not a number" ),
frame );
}
if ( !nilp( frame->more ) ) {
lisp_throw( c_string_to_lisp_string
( "Cannot yet add more than 8 numbers" ), frame );
}
if ( is_int ) {
result = make_integer( i_accumulator );
} else {
result = make_real( d_accumulator );
}
}
return result;
}
/**
* Multiply an indefinite number of numbers together
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer or real.
*/
struct cons_pointer
lisp_multiply( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer result = NIL;
long int i_accumulator = 1;
long double d_accumulator = 1;
bool is_int = true;
for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) {
struct cons_space_object arg = pointer2cell( frame->arg[i] );
switch ( arg.tag.value ) {
case INTEGERTV:
i_accumulator *= arg.payload.integer.value;
d_accumulator *= numeric_value( frame->arg[i] );
break;
case REALTV:
d_accumulator *= arg.payload.real.value;
is_int = false;
break;
default:
lisp_throw( c_string_to_lisp_string
( "Cannot multiply: not a number" ), frame );
}
if ( !nilp( frame->more ) ) {
lisp_throw( c_string_to_lisp_string
( "Cannot yet multiply more than 8 numbers" ), frame );
}
if ( is_int ) {
result = make_integer( i_accumulator );
} else {
result = make_real( d_accumulator );
}
}
return result;
}
/**
* Subtract one number from another.
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer or real.
*/
struct cons_pointer
lisp_subtract( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer result = NIL;
struct cons_space_object arg0 = pointer2cell( frame->arg[0] );
struct cons_space_object arg1 = pointer2cell( frame->arg[1] );
if ( integerp( frame->arg[0] ) && integerp( frame->arg[1] ) ) {
result =
make_integer( arg0.payload.integer.value -
arg1.payload.integer.value );
} else if ( realp( frame->arg[0] ) && realp( frame->arg[1] ) ) {
result =
make_real( arg0.payload.real.value - arg1.payload.real.value );
} else if ( integerp( frame->arg[0] ) && realp( frame->arg[1] ) ) {
result =
make_real( numeric_value( frame->arg[0] ) -
arg1.payload.real.value );
} else if ( realp( frame->arg[0] ) && integerp( frame->arg[1] ) ) {
result =
make_real( arg0.payload.real.value -
numeric_value( frame->arg[0] ) );
} // else we have an error!
// and if not nilp[frame->arg[2]) we also have an error.
return result;
}

49
src/peano.h Normal file
View file

@ -0,0 +1,49 @@
/**
* peano.h
*
* Basic peano arithmetic
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include "consspaceobject.h"
#ifndef PEANO_H
#define PEANO_H
#ifdef __cplusplus
extern "C" {
#endif
/**
* Add an indefinite number of numbers together
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer or real.
*/
struct cons_pointer
lisp_add( struct stack_frame *frame, struct cons_pointer env );
/**
* Multiply an indefinite number of numbers together
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer or real.
*/
struct cons_pointer
lisp_multiply( struct stack_frame *frame, struct cons_pointer env );
/**
* Subtract one number from another.
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer or real.
*/
struct cons_pointer
lisp_subtract( struct stack_frame *frame, struct cons_pointer env );
#ifdef __cplusplus
}
#endif
#endif /* PEANO_H */

145
src/print.c
View file

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

2
src/print.h
View file

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

298
src/read.c
View file

@ -8,34 +8,39 @@
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <math.h>
#include <stdbool.h>
#include <stdio.h>
/* wide characters */
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include "consspaceobject.h"
#include "integer.h"
#include "intern.h"
#include "print.h"
#include "read.h"
#include "real.h"
/* for the time being things which may be read are:
strings
numbers - either integer or real, but not yet including ratios or bignums
lists
Can't read atoms because I don't yet know what an atom is or how it's stored. */
/*
* for the time being things which may be read are: strings numbers - either
* integer or real, but not yet including ratios or bignums lists Can't read
* atoms because I don't yet know what an atom is or how it's stored.
*/
struct cons_pointer read_number( FILE* input, wint_t initial);
struct cons_pointer read_list( FILE* input, wint_t initial);
struct cons_pointer read_string( FILE* input, wint_t initial);
struct cons_pointer read_symbol( FILE* input, wint_t initial);
struct cons_pointer read_number( FILE * input, wint_t initial );
struct cons_pointer read_list( FILE * input, wint_t initial );
struct cons_pointer read_string( FILE * input, wint_t initial );
struct cons_pointer read_symbol( FILE * input, wint_t initial );
/**
* quote reader macro in C (!)
*/
struct cons_pointer c_quote( struct cons_pointer arg) {
return make_cons( c_string_to_lisp_symbol( "quote"),
make_cons( arg, NIL));
struct cons_pointer c_quote( struct cons_pointer arg ) {
return make_cons( c_string_to_lisp_symbol( "quote" ),
make_cons( arg, NIL ) );
}
/**
@ -43,162 +48,189 @@ struct cons_pointer c_quote( struct cons_pointer arg) {
* treating this initial character as the first character of the object
* representation.
*/
struct cons_pointer read_continuation( FILE* input, wint_t initial) {
struct cons_pointer result = NIL;
struct cons_pointer read_continuation( FILE * input, wint_t initial ) {
struct cons_pointer result = NIL;
wint_t c;
wint_t c;
for (c = initial;
c == '\0' || iswblank( c) || iswcntrl(c);
c = fgetwc( input));
switch( c) {
case '\'':
result = c_quote( read_continuation( input, fgetwc( input)));
break;
case '(' :
result = read_list(input, fgetwc( input));
break;
case '"':
result = read_string(input, fgetwc( input));
break;
default:
if ( iswdigit( c)) {
result = read_number( input, c);
} else if (iswprint( c)) {
result = read_symbol( input, c);
} else {
fprintf( stderr, "Unrecognised start of input character %c\n", c);
for ( c = initial;
c == '\0' || iswblank( c ) || iswcntrl( c ); c = fgetwc( input ) );
switch ( c ) {
case '\'':
result = c_quote( read_continuation( input, fgetwc( input ) ) );
break;
case '(':
result = read_list( input, fgetwc( input ) );
break;
case '"':
result = read_string( input, fgetwc( input ) );
break;
default:
if ( c == '.' ) {
wint_t next = fgetwc( input );
if ( iswdigit( next ) ) {
ungetwc( next, input );
result = read_number( input, c );
} else if ( iswblank( next ) ) {
/* dotted pair. TODO: this isn't right, we
* really need to backtrack up a level. */
result = read_continuation( input, fgetwc( input ) );
} else {
read_symbol( input, c );
}
} else if ( iswdigit( c ) ) {
result = read_number( input, c );
} else if ( iswprint( c ) ) {
result = read_symbol( input, c );
} else {
fwprintf( stderr, L"Unrecognised start of input character %c\n",
c );
}
}
}
return result;
return result;
}
/**
* read a number from this input stream, given this initial character.
*/
struct cons_pointer read_number( FILE* input, wint_t initial) {
int accumulator = 0;
int places_of_decimals = 0;
bool seen_period = false;
wint_t c;
struct cons_pointer read_number( FILE * input, wint_t initial ) {
struct cons_pointer result = NIL;
long int accumulator = 0;
int places_of_decimals = 0;
bool seen_period = false;
wint_t c;
fprintf( stderr, "read_number starting '%c' (%d)\n", initial, initial);
for (c = initial; iswdigit( c); c = fgetwc( input)) {
if ( c == '.') {
seen_period = true;
} else {
accumulator = accumulator * 10 + ((int)c - (int)'0');
fwprintf( stderr, L"read_number starting '%c' (%d)\n", initial, initial );
if ( seen_period) {
places_of_decimals ++;
}
for ( c = initial; iswdigit( c ) || c == btowc( '.' );
c = fgetwc( input ) ) {
if ( c == btowc( '.' ) ) {
seen_period = true;
} else {
accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' );
fwprintf( stderr, L"Added character %c, accumulator now %ld\n", c,
accumulator );
if ( seen_period ) {
places_of_decimals++;
}
}
}
}
/* push back the character read which was not a digit */
ungetwc( c, input);
/*
* push back the character read which was not a digit
*/
ungetwc( c, input );
return make_integer( accumulator);
if ( seen_period ) {
long double rv = ( long double )
( accumulator / pow( 10, places_of_decimals ) );
fwprintf( stderr, L"read_numer returning %Lf\n", rv );
result = make_real( rv );
} else {
result = make_integer( accumulator );
}
return result;
}
/**
* Read a list from this input stream, which no longer contains the opening
* left parenthesis.
*/
struct cons_pointer read_list( FILE* input, wint_t initial) {
struct cons_pointer result= NIL;
struct cons_pointer read_list( FILE * input, wint_t initial ) {
struct cons_pointer result = NIL;
if ( initial != ')' ) {
fwprintf( stderr, L"read_list starting '%C' (%d)\n", initial, initial);
struct cons_pointer car = read_continuation( input, initial);
result = make_cons( car, read_list( input, fgetwc( input)));
} else {
fprintf( stderr, "End of list detected\n");
}
if ( initial != ')' ) {
fwprintf( stderr, L"read_list starting '%C' (%d)\n", initial,
initial );
struct cons_pointer car = read_continuation( input, initial );
result = make_cons( car, read_list( input, fgetwc( input ) ) );
} else {
fwprintf( stderr, L"End of list detected\n" );
}
return result;
return result;
}
/**
* Read a string. This means either a string delimited by double quotes
/**
* Read a string. This means either a string delimited by double quotes
* (is_quoted == true), in which case it may contain whitespace but may
* not contain a double quote character (unless escaped), or one not
* so delimited in which case it may not contain whitespace (unless escaped)
* but may contain a double quote character (probably not a good idea!)
*/
struct cons_pointer read_string( FILE* input, wint_t initial) {
struct cons_pointer cdr = NIL;
struct cons_pointer result;
struct cons_pointer read_string( FILE * input, wint_t initial ) {
struct cons_pointer cdr = NIL;
struct cons_pointer result;
fwprintf( stderr, L"read_string starting '%C' (%d)\n",
initial, initial);
switch ( initial) {
case '\0':
result = make_string( initial, NIL);
break;
case '"':
result = make_string( '\0', NIL);
break;
default:
result = make_string( initial, read_string( input, fgetwc( input)));
break;
}
return result;
}
struct cons_pointer read_symbol( FILE* input, wint_t initial) {
struct cons_pointer cdr = NIL;
struct cons_pointer result;
fwprintf( stderr, L"read_symbol starting '%C' (%d)\n",
initial, initial);
switch ( initial) {
case '\0':
result = make_symbol( initial, NIL);
break;
case '"':
/* THIS IS NOT A GOOD IDEA, but is legal */
result = make_symbol( initial, read_symbol( input, fgetwc( input)));
break;
case ')' :
/* unquoted strings may not include right-parenthesis */
result = make_symbol( '\0', NIL);
/* push back the character read */
ungetwc( initial, input);
break;
default:
if ( iswblank( initial) || !iswprint( initial)) {
result = make_symbol( '\0', NIL);
/* push back the character read */
ungetwc( initial, input);
} else {
result = make_symbol( initial, read_symbol( input, fgetwc( input)));
switch ( initial ) {
case '\0':
result = make_string( initial, NIL );
break;
case '"':
result = make_string( '\0', NIL );
break;
default:
result = make_string( initial, read_string( input, fgetwc( input ) ) );
break;
}
break;
}
return result;
return result;
}
struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
struct cons_pointer cdr = NIL;
struct cons_pointer result;
switch ( initial ) {
case '\0':
result = make_symbol( initial, NIL );
break;
case '"':
/*
* THIS IS NOT A GOOD IDEA, but is legal
*/
result = make_symbol( initial, read_symbol( input, fgetwc( input ) ) );
break;
case ')':
/*
* unquoted strings may not include right-parenthesis
*/
result = make_symbol( '\0', NIL );
/*
* push back the character read
*/
ungetwc( initial, input );
break;
default:
if ( iswprint( initial ) && !iswblank( initial ) ) {
result =
make_symbol( initial, read_symbol( input, fgetwc( input ) ) );
} else {
result = NIL;
/*
* push back the character read
*/
ungetwc( initial, input );
}
break;
}
fputws( L"Read symbol '", stderr );
print( stderr, result );
fputws( L"'\n", stderr );
return result;
}
/**
* Read the next object on this input stream and return a cons_pointer to it.
*/
struct cons_pointer read( FILE* input) {
return read_continuation( input, fgetwc( input));
struct cons_pointer read( FILE * input ) {
return read_continuation( input, fgetwc( input ) );
}

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.
*/
struct cons_pointer read( FILE* input);
struct cons_pointer read( FILE * input );
#endif

23
src/real.c Normal file
View file

@ -0,0 +1,23 @@
/*
* To change this license header, choose License Headers in Project Properties.
* To change this template file, choose Tools | Templates
* and open the template in the editor.
*/
#include "conspage.h"
#include "consspaceobject.h"
#include "read.h"
/**
* Allocate a real number cell representing this value and return a cons
* pointer to it.
* @param value the value to wrap;
* @return a real number cell wrapping this value.
*/
struct cons_pointer make_real( long double value ) {
struct cons_pointer result = allocate_cell( REALTAG );
struct cons_space_object *cell = &pointer2cell( result );
cell->payload.real.value = value;
return result;
}

32
src/real.h Normal file
View file

@ -0,0 +1,32 @@
/*
* To change this license header, choose License Headers in Project Properties.
* To change this template file, choose Tools | Templates
* and open the template in the editor.
*/
/*
* File: real.h
* Author: simon
*
* Created on 14 August 2017, 17:25
*/
#ifndef REAL_H
#define REAL_H
#ifdef __cplusplus
extern "C" {
#endif
/**
* Allocate a real number cell representing this value and return a cons
* pointer to it.
* @param value the value to wrap;
* @return a real number cell wrapping this value.
*/
struct cons_pointer make_real( long double value );
#ifdef __cplusplus
}
#endif
#endif /* REAL_H */

47
src/repl.c Normal file
View file

@ -0,0 +1,47 @@
/*
* To change this license header, choose License Headers in Project Properties.
* To change this template file, choose Tools | Templates
* and open the template in the editor.
*/
#include <stdbool.h>
#include <stdio.h>
#include <wchar.h>
#include "conspage.h"
#include "consspaceobject.h"
#include "intern.h"
#include "lispops.h"
#include "read.h"
#include "print.h"
#include "stack.h"
/**
* The read/eval/print loop
* @param in_stream the stream to read from;
* @param out_stream the stream to write to;
* @param err_stream the stream to send errors to;
* @param show_prompt true if prompts should be shown.
*/
void
repl( FILE * in_stream, FILE * out_stream, FILE * error_stream,
bool show_prompt ) {
while ( !feof( in_stream ) ) {
if ( show_prompt ) {
fwprintf( out_stream, L"\n:: " );
}
struct cons_pointer input = read( in_stream );
fwprintf( error_stream, L"\nread {%d,%d}=> ", input.page,
input.offset );
print( error_stream, input );
struct stack_frame *frame = make_empty_frame( NULL, oblist );
frame->arg[0] = input;
struct cons_pointer value = lisp_eval( frame, oblist );
free_stack_frame( frame );
// print( out_stream, input );
fwprintf( out_stream, L"\n" );
fwprintf( error_stream, L"\neval {%d,%d}=> ", input.page,
input.offset );
print( out_stream, value );
}
}

34
src/repl.h Normal file
View file

@ -0,0 +1,34 @@
/*
* To change this license header, choose License Headers in Project Properties.
* To change this template file, choose Tools | Templates
* and open the template in the editor.
*/
/*
* File: repl.h
* Author: simon
*
* Created on 14 August 2017, 14:40
*/
#ifndef REPL_H
#define REPL_H
#ifdef __cplusplus
extern "C" {
#endif
/**
* The read/eval/print loop
* @param in_stream the stream to read from;
* @param out_stream the stream to write to;
* @param err_stream the stream to send errors to;
* @param show_prompt true if prompts should be shown.
*/
void repl( FILE * in_stream, FILE * out_stream,
FILE * error_stream, bool show_prompt );
#ifdef __cplusplus
}
#endif
#endif /* REPL_H */

202
src/stack.c
View file

@ -4,13 +4,13 @@
* The Lisp evaluation stack.
*
* Stack frames could be implemented in cons space; indeed, the stack
* could simply be an assoc list consed onto the front of the environment.
* But such a stack would be costly to search. The design sketched here,
* with stack frames as special objects, SHOULD be substantially more
* could simply be an assoc list consed onto the front of the environment.
* But such a stack would be costly to search. The design sketched here,
* with stack frames as special objects, SHOULD be substantially more
* efficient, but does imply we need to generalise the idea of cons pages
* with freelists to a more general 'equal sized object pages', so that
* allocating/freeing stack frames can be more efficient.
*
*
* Stack frames are not yet a first class object; they have no VECP pointer
* in cons space.
*
@ -23,88 +23,160 @@
#include "consspaceobject.h"
#include "conspage.h"
#include "lispops.h"
#include "print.h"
#include "stack.h"
/**
* Make an empty stack frame, and return it.
* @param previous the current top-of-stack;
* @param env the environment in which evaluation happens.
* @return the new frame.
*/
struct stack_frame *make_empty_frame( struct stack_frame *previous,
struct cons_pointer env ) {
struct stack_frame *result = malloc( sizeof( struct stack_frame ) );
/*
* TODO: later, pop a frame off a free-list of stack frames
*/
result->previous = previous;
/*
* clearing the frame with memset would probably be slightly quicker, but
* this is clear.
*/
result->more = NIL;
result->function = NIL;
for ( int i = 0; i < args_in_frame; i++ ) {
result->arg[i] = NIL;
}
return result;
}
/**
* Allocate a new stack frame with its previous pointer set to this value,
* its arguments set up from these args, evaluated in this env.
* @param previous the current top-of-stack;
* @args the arguments to load into this frame;
* @param env the environment in which evaluation happens.
* @return the new frame.
*/
struct stack_frame* make_stack_frame( struct stack_frame* previous,
struct cons_pointer args,
struct cons_pointer env) {
/* TODO: later, pop a frame off a free-list of stack frames */
struct stack_frame* result = malloc( sizeof( struct stack_frame));
struct stack_frame *make_stack_frame( struct stack_frame *previous,
struct cons_pointer args,
struct cons_pointer env ) {
struct stack_frame *result = make_empty_frame( previous, env );
result->previous = previous;
for ( int i = 0; i < args_in_frame && !nilp( args ); i++ ) {
/* iterate down the arg list filling in the arg slots in the
* frame. When there are no more slots, if there are still args,
* stash them on more */
struct cons_space_object cell = pointer2cell( args );
/* clearing the frame with memset would probably be slightly quicker, but
* this is clear. */
result->more = NIL;
result->function = NIL;
/*
* TODO: if we were running on real massively parallel hardware,
* each arg except the first should be handed off to another
* processor to be evaled in parallel; but see notes here:
* https://github.com/simon-brooke/post-scarcity/wiki/parallelism
*/
struct stack_frame *arg_frame = make_empty_frame( previous, env );
arg_frame->arg[0] = cell.payload.cons.car;
inc_ref( arg_frame->arg[0] );
result->arg[i] = lisp_eval( arg_frame, env );
inc_ref( result->arg[i] );
free_stack_frame( arg_frame );
for ( int i = 0; i < args_in_frame; i++) {
result->arg[i] = NIL;
}
int i = 0; /* still an index into args, so same
* name will do */
while ( ! nilp( args)) { /* iterate down the arg list filling in
* the arg slots in the frame. When there
* are no more slots, if there are still
* args, stash them on more */
struct cons_space_object cell = pointer2cell( args);
if ( i < args_in_frame) {
/* TODO: if we were running on real massively parallel hardware, each
* arg except the first should be handed off to another processor to
* be evaled in parallel */
result->arg[i] = lisp_eval( cell.payload.cons.car, env, result);
inc_ref( result->arg[i]);
args = cell.payload.cons.cdr;
} else {
/* TODO: this isn't right. These args should also each be evaled. */
result->more = args;
inc_ref( result->more);
args = NIL;
args = cell.payload.cons.cdr;
}
}
/*
* TODO: this isn't right. These args should also each be evaled.
*/
result->more = args;
inc_ref( result->more );
return result;
return result;
}
/**
* A 'special' frame is exactly like a normal stack frame except that the
* arguments are unevaluated.
* @param previous the previous stack frame;
* @param args a list of the arguments to be stored in this stack frame;
* @param env the execution environment;
* @return a new special frame.
*/
struct stack_frame *make_special_frame( struct stack_frame *previous,
struct cons_pointer args,
struct cons_pointer env ) {
struct stack_frame *result = make_empty_frame( previous, env );
for ( int i = 0; i < args_in_frame && !nilp( args ); i++ ) {
/* iterate down the arg list filling in the arg slots in the
* frame. When there are no more slots, if there are still args,
* stash them on more */
struct cons_space_object cell = pointer2cell( args );
result->arg[i] = cell.payload.cons.car;
inc_ref( result->arg[i] );
args = cell.payload.cons.cdr;
}
result->more = args;
inc_ref( args );
return result;
}
/**
* Free this stack frame.
*/
void free_stack_frame( struct stack_frame* frame) {
/* TODO: later, push it back on the stack-frame freelist */
for ( int i = 0; i < args_in_frame; i++) {
dec_ref( frame->arg[ i]);
}
dec_ref( frame->more);
free( frame);
void free_stack_frame( struct stack_frame *frame ) {
/*
* TODO: later, push it back on the stack-frame freelist
*/
for ( int i = 0; i < args_in_frame; i++ ) {
dec_ref( frame->arg[i] );
}
dec_ref( frame->more );
free( frame );
}
/**
* Dump a stackframe to this stream for debugging
* @param output the stream
* @param frame the frame
*/
void dump_frame( FILE * output, struct stack_frame *frame ) {
fputws( L"Dumping stack frame\n", output );
for ( int arg = 0; arg < args_in_frame; arg++ ) {
fwprintf( output, L"Arg %d:", arg );
print( output, frame->arg[arg] );
fputws( L"\n", output );
}
}
/**
* Fetch a pointer to the value of the local variable at this index.
*/
struct cons_pointer fetch_arg( struct stack_frame* frame, unsigned int index) {
struct cons_pointer result = NIL;
if ( index < args_in_frame) {
result = frame->arg[ index];
} else {
struct cons_pointer p = frame->more;
for ( int i = args_in_frame; i < index; i++) {
p = pointer2cell( p).payload.cons.cdr;
struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int index ) {
struct cons_pointer result = NIL;
if ( index < args_in_frame ) {
result = frame->arg[index];
} else {
struct cons_pointer p = frame->more;
for ( int i = args_in_frame; i < index; i++ ) {
p = pointer2cell( p ).payload.cons.cdr;
}
result = pointer2cell( p ).payload.cons.car;
}
result = pointer2cell( p).payload.cons.car;
}
return result;
return result;
}

45
src/stack.h
View file

@ -24,13 +24,44 @@
#ifndef __stack_h
#define __stack_h
struct stack_frame* make_stack_frame( struct stack_frame* previous,
struct cons_pointer args,
struct cons_pointer env);
void free_stack_frame( struct stack_frame* frame);
struct cons_pointer fetch_arg( struct stack_frame* frame, unsigned int n);
/**
* Make an empty stack frame, and return it.
* @param previous the current top-of-stack;
* @param env the environment in which evaluation happens.
* @return the new frame.
*/
struct stack_frame *make_empty_frame( struct stack_frame *previous,
struct cons_pointer env );
/* struct stack_frame is defined in consspaceobject.h to break circularity
* TODO: refactor. */
struct stack_frame *make_stack_frame( struct stack_frame *previous,
struct cons_pointer args,
struct cons_pointer env );
void free_stack_frame( struct stack_frame *frame );
/**
* Dump a stackframe to this stream for debugging
* @param output the stream
* @param frame the frame
*/
void dump_frame( FILE * output, struct stack_frame *frame );
struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int n );
/**
* A 'special' frame is exactly like a normal stack frame except that the
* arguments are unevaluated.
* @param previous the previous stack frame;
* @param args a list of the arguments to be stored in this stack frame;
* @param env the execution environment;
* @return a new special frame.
*/
struct stack_frame *make_special_frame( struct stack_frame *previous,
struct cons_pointer args,
struct cons_pointer env );
/*
* struct stack_frame is defined in consspaceobject.h to break circularity
* TODO: refactor.
*/
#endif

3
src/version.h
View file

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

26
unit-tests/add.sh Normal file
View file

@ -0,0 +1,26 @@
#!/bin/bash
expected='5'
actual=`echo "(add 2 3)" | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
exit 0
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi
expected='5.5000'
actual=`echo "(add 2.5 3)" | target/psse 2> /dev/null | head -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
exit 0
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi

13
unit-tests/apply.sh Normal file
View file

@ -0,0 +1,13 @@
#!/bin/bash
expected='1'
actual=`echo "(apply 'add '(1))"| target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
exit 0
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi

2
unit-tests/complex-list.sh
View file

@ -1,7 +1,7 @@
#!/bin/bash
expected='(1 2 3 ("Fred") nil 77354)'
actual=`echo '(1 2 3 ("Fred") () 77354)' | target/psse 2> /dev/null`
actual=`echo "'(1 2 3 (\"Fred\") () 77354)" | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]
then

19
unit-tests/empty-list.sh.bash Normal file
View file

@ -0,0 +1,19 @@
#!/bin/bash
#
# File: empty-list.sh.bash
# Author: simon
#
# Created on 14-Aug-2017, 15:06:40
#
expected=nil
actual=`echo "'()" | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
exit 0
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi

2
unit-tests/empty-string.sh
View file

@ -1,7 +1,7 @@
#!/bin/bash
expected="\"\""
actual=`echo '""' | target/psse 2> /dev/null`
actual=`echo '""' | target/psse 2> /dev/null | head -2 | tail -1`
if [ "$expected" = "$actual" ]
then

2
unit-tests/fred.sh
View file

@ -1,7 +1,7 @@
#!/bin/bash
expected='"Fred"'
actual=`echo ${expected} | target/psse 2> /dev/null`
actual=`echo ${expected} | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]
then

2
unit-tests/integer-allocation.sh
View file

@ -2,7 +2,7 @@
value=354
expected="Integer cell: value ${value}"
echo ${value} | target/psse 2>&1 | grep "${expected}" > /dev/null
echo ${value} | target/psse -d 2>&1 | grep "${expected}" > /dev/null
if [ $? -eq 0 ]
then

2
unit-tests/integer.sh
View file

@ -1,7 +1,7 @@
#!/bin/bash
expected="354"
actual=`echo ${expected} | target/psse 2> /dev/null`
actual=`echo ${expected} | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]
then

2
unit-tests/nil.sh
View file

@ -1,7 +1,7 @@
#!/bin/bash
expected=nil
actual=`echo '()' | target/psse 2> /dev/null`
actual=`echo 'nil' | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]
then

4
unit-tests/quote.sh
View file

@ -1,7 +1,7 @@
#!/bin/bash
expected='(quote Fred)'
actual=`echo "'Fred" | target/psse 2> /dev/null`
expected='Fred'
actual=`echo "'Fred" | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]
then

4
unit-tests/quoted-list.sh
View file

@ -1,7 +1,7 @@
#!/bin/bash
expected='(quote (123 (4 (5 nil)) Fred))'
actual=`echo "'(123 (4 (5 ())) Fred)" | target/psse 2> /dev/null`
expected='(123 (4 (5 nil)) Fred)'
actual=`echo "'(123 (4 (5 ())) Fred)" | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]
then

2
unit-tests/simple-list.sh
View file

@ -1,7 +1,7 @@
#!/bin/bash
expected="(1 2 3)"
actual=`echo '(1 2 3)' | target/psse 2> /dev/null`
actual=`echo "'(1 2 3)" | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]
then

2
unit-tests/string-allocation.sh
View file

@ -2,7 +2,7 @@
value='"Fred"'
expected="String cell: character 'F'"
echo ${value} | target/psse 2>&1 | grep "${expected}" > /dev/null
echo ${value} | target/psse -d 2>&1 | grep "${expected}" > /dev/null
if [ $? -eq 0 ]
then

2
unit-tests/string-with-spaces.sh
View file

@ -1,7 +1,7 @@
#!/bin/bash
expected='"Strings should be able to include spaces (and other stuff)!"'
actual=`echo ${expected} | target/psse 2> /dev/null`
actual=`echo ${expected} | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]
then