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

Standardised formatting.

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

7
Makefile
View file

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

58
src/conspage.c
View file

@ -19,8 +19,6 @@
#include "consspaceobject.h"
#include "conspage.h"
/**
* Flag indicating whether conspage initialisation has been done.
*/
@ -42,38 +40,47 @@ struct cons_pointer freelist = NIL;
*/
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() {
void make_cons_page()
{
struct cons_page *result = malloc(sizeof(struct cons_page));
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];
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 */
/*
* 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 */
/*
* 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};
cell->payload.free.car = (struct cons_pointer) {
0, 1};
cell->payload.free.cdr = (struct cons_pointer) {
0, 1};
fprintf(stderr, "Allocated special cell T\n");
}
} else {
/* otherwise, standard initialisation */
/*
* otherwise, standard initialisation
*/
strncpy(&cell->tag.bytes[0], FREETAG, TAGLENGTH);
cell->payload.free.car = NIL;
cell->payload.free.cdr = freelist;
@ -84,34 +91,37 @@ void make_cons_page() {
initialised_cons_pages++;
} else {
fprintf( stderr, "FATAL: Failed to allocate memory for cons page %d\n", initialised_cons_pages);
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) {
void dump_pages(FILE * output)
{
for (int i = 0; i < initialised_cons_pages; i++) {
fprintf(output, "\nDUMPING PAGE %d\n", i);
for (int j = 0; j < CONSPAGESIZE; j++) {
dump_object( output, (struct cons_pointer){i, j});
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) {
void free_cell(struct cons_pointer pointer)
{
struct cons_space_object *cell = &pointer2cell(pointer);
if (!check_tag(pointer, FREETAG)) {
@ -132,7 +142,6 @@ void free_cell(struct cons_pointer pointer) {
}
}
/**
* Allocates a cell with the specified tag. Dangerous, primitive, low
* level.
@ -140,7 +149,8 @@ void free_cell(struct cons_pointer pointer) {
* @param tag the tag of the cell to allocate - must be a valid cons space tag.
* @return the cons pointer which refers to the cell allocated.
*/
struct cons_pointer allocate_cell( char* tag) {
struct cons_pointer allocate_cell(char *tag)
{
struct cons_pointer result = freelist;
if (result.page == NIL.page && result.offset == NIL.offset) {
@ -158,8 +168,9 @@ struct cons_pointer allocate_cell( char* tag) {
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);
fprintf(stderr,
"Allocated cell of type '%s' at %d, %d \n", tag,
result.page, result.offset);
dump_object(stderr, result);
} else {
fprintf(stderr, "WARNING: Allocating non-free cell!");
@ -169,11 +180,11 @@ struct cons_pointer allocate_cell( char* tag) {
return result;
}
/**
* initialise the cons page system; to be called exactly once during startup.
*/
void initialise_cons_pages() {
void initialise_cons_pages()
{
if (conspageinitihasbeencalled == false) {
for (int i = 0; i < NCONSPAGES; i++) {
conspages[i] = (struct cons_page *) NULL;
@ -182,6 +193,7 @@ void initialise_cons_pages() {
make_cons_page();
conspageinitihasbeencalled = true;
} else {
fprintf( stderr, "WARNING: conspageinit() called a second or subsequent time\n");
fprintf(stderr,
"WARNING: conspageinit() called a second or subsequent time\n");
}
}

5
src/conspage.h
View file

@ -3,7 +3,6 @@
#ifndef __conspage_h
#define __conspage_h
/**
* the number of cons cells on a cons page. The maximum value this can be (and consequently,
* the size which, by version 1, it will default to) is the maximum value of an unsigned 32
@ -27,7 +26,6 @@ struct cons_page {
struct cons_space_object cell[CONSPAGESIZE];
};
/**
* The (global) pointer to the (global) freelist. Not sure whether this ultimately
* belongs in this file.
@ -39,7 +37,6 @@ extern struct cons_pointer freelist;
*/
extern struct cons_page *conspages[NCONSPAGES];
/**
* Frees the cell at the specified pointer. Dangerous, primitive, low
* level.
@ -48,7 +45,6 @@ extern struct cons_page* conspages[NCONSPAGES];
*/
void free_cell(struct cons_pointer pointer);
/**
* Allocates a cell with the specified tag. Dangerous, primitive, low
* level.
@ -58,7 +54,6 @@ void free_cell(struct cons_pointer pointer);
*/
struct cons_pointer allocate_cell(char *tag);
/**
* initialise the cons page system; to be called exactly once during startup.
*/

88
src/consspaceobject.c
View file

@ -11,7 +11,9 @@
#include <stdint.h>
#include <stdlib.h>
#include <string.h>
/* wide characters */
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
@ -21,19 +23,20 @@
/**
* Check that the tag on the cell at this pointer is this tag
*/
int check_tag( struct cons_pointer pointer, char* tag) {
int check_tag(struct cons_pointer pointer, char *tag)
{
struct cons_space_object cell = pointer2cell(pointer);
return strncmp(&cell.tag.bytes[0], tag, TAGLENGTH) == 0;
}
/**
* 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) {
void inc_ref(struct cons_pointer pointer)
{
struct cons_space_object *cell = &pointer2cell(pointer);
if (cell->count < MAXREFERENCE) {
@ -41,14 +44,14 @@ void inc_ref( struct cons_pointer pointer) {
}
}
/**
* Decrement the reference count of the object at this cons pointer.
*
* If a count has reached MAXREFERENCE it cannot be decremented.
* If a count is decremented to zero the cell should be freed.
*/
void dec_ref( struct cons_pointer pointer) {
void dec_ref(struct cons_pointer pointer)
{
struct cons_space_object *cell = &pointer2cell(pointer);
if (cell->count <= MAXREFERENCE) {
@ -60,11 +63,11 @@ 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_space_object cell = pointer2cell(pointer);
fwprintf(output,
L"\tDumping %c%c%c%c (%d) at page %d, offset %d count %u\n",
@ -72,43 +75,42 @@ void dump_object( FILE* output, struct cons_pointer pointer) {
cell.tag.bytes[1],
cell.tag.bytes[2],
cell.tag.bytes[3],
cell.tag.value,
pointer.page,
pointer.offset,
cell.count);
cell.tag.value, pointer.page, pointer.offset, cell.count);
if (check_tag(pointer, CONSTAG)) {
fwprintf(output,
L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d\n",
cell.payload.cons.car.page, cell.payload.cons.car.offset,
cell.payload.cons.car.page,
cell.payload.cons.car.offset,
cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset);
} else if (check_tag(pointer, INTEGERTAG)) {
fwprintf(output,
L"\t\tInteger cell: value %ld\n",
cell.payload.integer.value);
L"\t\tInteger cell: value %ld\n", cell.payload.integer.value);
} else if (check_tag(pointer, FREETAG)) {
fwprintf(output, L"\t\tFree cell: next at page %d offset %d\n",
cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset);
} else if (check_tag(pointer, REALTAG)) {
fwprintf( output, L"\t\tReal cell: value %Lf\n", cell.payload.real.value);
fwprintf(output, L"\t\tReal cell: value %Lf\n",
cell.payload.real.value);
} else if (check_tag(pointer, STRINGTAG)) {
fwprintf(output,
L"String cell: character '%1c' (%1d) next at page %2d offset %3d\n",
cell.payload.string.character, cell.payload.string.cdr.page,
cell.payload.string.cdr.offset);
cell.payload.string.character,
cell.payload.string.cdr.page, cell.payload.string.cdr.offset);
}
}
/**
* Construct a cons cell from this pair of pointers.
*/
struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer cdr) {
struct cons_pointer make_cons(struct cons_pointer car, struct cons_pointer cdr)
{
struct cons_pointer pointer = NIL;
pointer = allocate_cell(CONSTAG);
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);
@ -121,9 +123,10 @@ struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer cdr)
/**
* Construct a cell which points to an executable Lisp special form.
*/
struct cons_pointer make_function( struct cons_pointer src,
struct cons_pointer (*executable)
(struct stack_frame*, struct cons_pointer)) {
struct cons_pointer
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);
@ -139,9 +142,9 @@ struct cons_pointer make_function( struct cons_pointer src,
* 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
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)) {
@ -153,7 +156,8 @@ struct cons_pointer make_string_like_thing( wint_t c,
cell->payload.string.cdr.page = tail.page;
cell->payload.string.cdr.offset = tail.offset;
} else {
fwprintf( stderr, L"Warning: only NIL and %s can be appended to %s\n",
fwprintf(stderr,
L"Warning: only NIL and %s can be appended to %s\n",
tag, tag);
}
@ -166,25 +170,35 @@ 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) {
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) {
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
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 env, struct stack_frame * frame))
{
struct cons_pointer pointer = allocate_cell(SPECIALTAG);
struct cons_space_object *cell = &pointer2cell(pointer);
@ -197,7 +211,8 @@ struct cons_pointer make_special( struct cons_pointer src,
/**
* Return a lisp string representation of this old skool ASCII string.
*/
struct cons_pointer c_string_to_lisp_string( char* string) {
struct cons_pointer c_string_to_lisp_string(char *string)
{
struct cons_pointer result = NIL;
for (int i = strlen(string); i > 0; i--) {
@ -210,7 +225,8 @@ struct cons_pointer c_string_to_lisp_string( char* string) {
/**
* Return a lisp symbol representation of this old skool ASCII string.
*/
struct cons_pointer c_string_to_lisp_symbol( char* symbol) {
struct cons_pointer c_string_to_lisp_symbol(char *symbol)
{
struct cons_pointer result = NIL;
for (int i = strlen(symbol); i > 0; i--) {

111
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>
@ -201,11 +203,14 @@
* An indirect pointer to a cons cell
*/
struct cons_pointer {
uint32_t page; /* the index of the page on which this cell resides */
uint32_t 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
/**
@ -215,9 +220,10 @@ struct cons_pointer {
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 */
/*
* first 8 arument bindings
*/
struct cons_pointer more; /* list of any further argument bindings */
struct cons_pointer function; /* the function to be called */
};
@ -240,7 +246,8 @@ struct cons_payload {
*/
struct function_payload {
struct cons_pointer source;
struct cons_pointer (*executable)(struct stack_frame*, struct cons_pointer);
struct cons_pointer (*executable) (struct stack_frame *,
struct cons_pointer);
};
/**
@ -309,10 +316,12 @@ struct string_payload {
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. */
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
@ -320,81 +329,119 @@ struct vectorp_payload {
* 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 */
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 */
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 */
/*
* if tag == CONSTAG
*/
struct cons_payload cons;
/* if tag == FREETAG */
/*
* if tag == FREETAG
*/
struct free_payload free;
/* if tag == FUNCTIONTAG */
/*
* if tag == FUNCTIONTAG
*/
struct function_payload function;
/* if tag == INTEGERTAG */
/*
* if tag == INTEGERTAG
*/
struct integer_payload integer;
/* if tag == NILTAG; we'll treat the special cell NIL as just a cons */
/*
* if tag == NILTAG; we'll treat the special cell NIL as just a cons
*/
struct cons_payload nil;
/* if tag == READTAG || tag == WRITETAG */
/*
* if tag == READTAG || tag == WRITETAG
*/
struct stream_payload stream;
/* if tag == REALTAG */
/*
* if tag == REALTAG
*/
struct real_payload real;
/* if tag == SPECIALTAG */
/*
* if tag == SPECIALTAG
*/
struct special_payload special;
/* if tag == STRINGTAG || tag == SYMBOLTAG */
/*
* if tag == STRINGTAG || tag == SYMBOLTAG
*/
struct string_payload string;
/* if tag == TRUETAG; we'll treat the special cell T as just a cons */
/*
* if tag == TRUETAG; we'll treat the special cell T as just a cons
*/
struct cons_payload t;
/* if tag == VECTORPTAG */
/*
* 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);
/**
* increment the reference count of the object at this cons 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);
/**
* dump the object at this cons_pointer to this output stream.
*/
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 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));

42
src/equal.c
View file

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

42
src/init.c
View file

@ -22,20 +22,33 @@
#include "repl.h"
void bind_function(char *name, struct cons_pointer (*executable)
(struct stack_frame*, struct cons_pointer)) {
(struct stack_frame *, struct cons_pointer))
{
deep_bind(intern(c_string_to_lisp_symbol(name), oblist),
make_function(NIL, executable));
}
void bind_special(char *name, struct cons_pointer (*executable)
(struct cons_pointer s_expr, struct cons_pointer env,
struct stack_frame* frame)) {
struct stack_frame * frame))
{
deep_bind(intern(c_string_to_lisp_symbol(name), oblist),
make_special(NIL, executable));
}
int main (int argc, char *argv[]) {
/* attempt to set wide character acceptance on all streams */
int main(int argc, char *argv[])
{
/*
* attempt to set wide character acceptance on all streams
*/
fwide(stdin, 1);
fwide(stdout, 1);
fwide(stderr, 1);
@ -43,10 +56,8 @@ int main (int argc, char *argv[]) {
bool dump_at_end = false;
bool show_prompt = false;
while ((option = getopt (argc, argv, "pd")) != -1)
{
switch (option)
{
while ((option = getopt(argc, argv, "pd")) != -1) {
switch (option) {
case 'd':
dump_at_end = true;
break;
@ -60,16 +71,21 @@ int main (int argc, char *argv[]) {
}
if (show_prompt) {
fprintf( stdout, "Post scarcity software environment version %s\n\n", VERSION);
fprintf(stdout,
"Post scarcity software environment version %s\n\n", VERSION);
}
initialise_cons_pages();
/* privileged variables (keywords) */
/*
* privileged variables (keywords)
*/
deep_bind(intern(c_string_to_lisp_string("nil"), oblist), NIL);
deep_bind(intern(c_string_to_lisp_string("t"), oblist), TRUE);
/* primitive function operations */
/*
* primitive function operations
*/
bind_function("assoc", &lisp_assoc);
bind_function("car", &lisp_car);
bind_function("cdr", &lisp_cdr);
@ -79,7 +95,9 @@ int main (int argc, char *argv[]) {
bind_function("read", &lisp_read);
bind_function("print", &lisp_print);
/* primitive special forms */
/*
* primitive special forms
*/
bind_special("apply", &lisp_apply);
bind_special("eval", &lisp_eval);
bind_special("quote", &lisp_quote);

8
src/integer.c
View file

@ -19,7 +19,8 @@
* as a cons-space object. Cell may in principle be any kind of number,
* but only integers and reals are so far implemented.
*/
double numeric_value( struct cons_pointer pointer) {
double numeric_value(struct cons_pointer pointer)
{
double result = NAN;
struct cons_space_object *cell = &pointer2cell(pointer);
@ -32,15 +33,14 @@ double numeric_value( struct cons_pointer pointer) {
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 make_integer(int value)
{
struct cons_pointer result = allocate_cell(INTEGERTAG);
struct cons_space_object *cell = &pointer2cell(result);
cell->payload.integer.value = value;
return result;
}

32
src/intern.c
View file

@ -43,7 +43,9 @@ 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
internedp(struct cons_pointer key, struct cons_pointer store)
{
struct cons_pointer result = NIL;
for (struct cons_pointer next = store;
@ -68,12 +70,12 @@ 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 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) {
consp(next); next = pointer2cell(next).payload.cons.cdr) {
struct cons_space_object entry =
pointer2cell(pointer2cell(next).payload.cons.car);
@ -86,40 +88,44 @@ struct cons_pointer c_assoc( struct cons_pointer key, struct cons_pointer store)
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) {
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) {
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
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 */
/*
* not currently bound
*/
result = bind(key, NIL, environment);
}

11
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,7 +27,8 @@ 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
@ -41,15 +41,16 @@ struct cons_pointer internedp( struct cons_pointer key,
* Return a new key/value store containing all the key/value pairs in this store
* with this key/value pair added to the front.
*/
struct cons_pointer 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

105
src/lispops.c
View file

@ -49,7 +49,8 @@
/**
* Implementation of car in C. If arg is not a cons, does not error but returns nil.
*/
struct cons_pointer c_car( struct cons_pointer arg) {
struct cons_pointer c_car(struct cons_pointer arg)
{
struct cons_pointer result = NIL;
if (consp(arg)) {
@ -62,7 +63,8 @@ struct cons_pointer c_car( struct cons_pointer arg) {
/**
* Implementation of cdr in C. If arg is not a cons, does not error but returns nil.
*/
struct cons_pointer c_cdr( struct cons_pointer arg) {
struct cons_pointer c_cdr(struct cons_pointer arg)
{
struct cons_pointer result = NIL;
if (consp(arg)) {
@ -78,8 +80,10 @@ struct cons_pointer c_cdr( struct cons_pointer arg) {
* I'm now confused about whether at this stage I actually need an apply special form,
* and if so how it differs from eval.
*/
struct cons_pointer lisp_apply( struct cons_pointer args, struct cons_pointer env,
struct stack_frame* frame) {
struct cons_pointer
lisp_apply(struct cons_pointer args, struct cons_pointer env,
struct stack_frame *frame)
{
struct cons_pointer result = args;
if (consp(args)) {
@ -89,8 +93,10 @@ struct cons_pointer lisp_apply( struct cons_pointer args, struct cons_pointer en
return result;
}
struct cons_pointer eval_cons( struct cons_pointer s_expr, struct cons_pointer env,
struct stack_frame* my_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);
@ -100,19 +106,23 @@ struct cons_pointer eval_cons( struct cons_pointer s_expr, struct cons_pointer e
case SPECIALTV:
{
struct cons_space_object special = pointer2cell(fn_pointer);
result = (*special.payload.special.executable)( args, env, my_frame);
result =
(*special.payload.special.executable) (args, env, my_frame);
}
break;
case FUNCTIONTV:
/* actually, this is apply */
/*
* 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. */
/*
* 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);
}
@ -124,8 +134,9 @@ struct cons_pointer eval_cons( struct cons_pointer s_expr, struct cons_pointer e
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]);
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);
@ -148,8 +159,10 @@ 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
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 =
@ -165,18 +178,21 @@ struct cons_pointer lisp_eval( struct cons_pointer s_expr, struct cons_pointer e
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.");
c_string_to_lisp_string
("Attempt to take value of unbound symbol.");
result = lisp_throw(message, my_frame);
} else {
result = c_assoc(canonical, env);
}
}
break;
/* the Clojure practice of having a map serve in the function
* place of an s-expression is a good one and I should adopt it;
* also if the object is a consp it could be interpretable
* source code but in the long run I don't want an interpreter,
* and if I can get away without so much the better. */
/*
* 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);
@ -191,8 +207,10 @@ 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) {
struct cons_pointer
lisp_quote(struct cons_pointer args, struct cons_pointer env,
struct stack_frame *frame)
{
return c_car(args);
}
@ -204,7 +222,9 @@ struct cons_pointer lisp_quote( struct cons_pointer args, struct cons_pointer en
* 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
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;
@ -226,7 +246,9 @@ 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
lisp_car(struct stack_frame *frame, struct cons_pointer env)
{
struct cons_pointer result = NIL;
if (consp(frame->arg[0])) {
@ -244,13 +266,14 @@ struct cons_pointer lisp_car(struct stack_frame* frame, struct cons_pointer env)
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
lisp_cdr(struct stack_frame *frame, struct cons_pointer env)
{
struct cons_pointer result = NIL;
if (consp(frame->arg[0])) {
@ -272,7 +295,9 @@ struct cons_pointer lisp_cdr(struct stack_frame* frame, struct cons_pointer env)
* (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) {
struct cons_pointer
lisp_assoc(struct stack_frame *frame, struct cons_pointer env)
{
return c_assoc(frame->arg[0], frame->arg[1]);
}
@ -280,7 +305,8 @@ struct cons_pointer lisp_assoc( struct stack_frame* frame, struct cons_pointer e
* (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) {
struct cons_pointer lisp_eq(struct stack_frame *frame, struct cons_pointer env)
{
return eq(frame->arg[0], frame->arg[1]) ? TRUE : NIL;
}
@ -288,7 +314,9 @@ struct cons_pointer lisp_eq( struct stack_frame* frame, struct cons_pointer env)
* (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) {
struct cons_pointer
lisp_equal(struct stack_frame *frame, struct cons_pointer env)
{
return equal(frame->arg[0], frame->arg[1]) ? TRUE : NIL;
}
@ -298,7 +326,9 @@ 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) {
struct cons_pointer
lisp_read(struct stack_frame *frame, struct cons_pointer env)
{
FILE *input = stdin;
if (readp(frame->arg[0])) {
@ -314,7 +344,9 @@ struct cons_pointer lisp_read( struct stack_frame* frame, struct cons_pointer en
* Print one complete lisp form and return NIL. If write-stream is specified and
* is a write stream, then print to that stream, else stdout.
*/
struct cons_pointer lisp_print( struct stack_frame* frame, struct cons_pointer env) {
struct cons_pointer
lisp_print(struct stack_frame *frame, struct cons_pointer env)
{
FILE *output = stdout;
if (writep(frame->arg[1])) {
@ -326,15 +358,16 @@ struct cons_pointer lisp_print( struct stack_frame* frame, struct cons_pointer e
return NIL;
}
/**
* TODO: make this do something sensible somehow.
*/
struct cons_pointer lisp_throw( struct cons_pointer message, struct stack_frame* frame) {
struct cons_pointer
lisp_throw(struct cons_pointer message, struct stack_frame *frame)
{
fprintf(stderr, "\nERROR: ");
print(stderr, message);
fprintf( stderr, "\n\nAn exception was thrown and I've no idea what to do now\n");
fprintf(stderr,
"\n\nAn exception was thrown and I've no idea what to do now\n");
exit(1);
}

48
src/lispops.h
View file

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

34
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,7 +22,8 @@
#include "integer.h"
#include "print.h"
void print_string_contents( FILE* output, struct cons_pointer pointer) {
void print_string_contents(FILE * output, struct cons_pointer pointer)
{
if (stringp(pointer) || symbolp(pointer)) {
struct cons_space_object *cell = &pointer2cell(pointer);
wint_t c = cell->payload.string.character;
@ -32,8 +35,8 @@ void print_string_contents( FILE* output, struct cons_pointer pointer) {
}
}
void print_string( FILE* output, struct cons_pointer pointer) {
void print_string(FILE * output, struct cons_pointer pointer)
{
fputwc(btowc('"'), output);
print_string_contents(output, pointer);
fputwc(btowc('"'), output);
@ -42,8 +45,10 @@ void print_string( FILE* output, struct cons_pointer pointer) {
/**
* Print a single list cell (cons cell). TODO: does not handle dotted pairs.
*/
void print_list_contents( FILE* output, struct cons_pointer pointer,
bool initial_space) {
void
print_list_contents(FILE * output, struct cons_pointer pointer,
bool initial_space)
{
struct cons_space_object *cell = &pointer2cell(pointer);
switch (cell->tag.value) {
@ -63,19 +68,21 @@ void print_list_contents( FILE* output, struct cons_pointer pointer,
}
}
void print_list( FILE* output, struct cons_pointer pointer) {
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) {
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. */
/*
* 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);
@ -99,7 +106,8 @@ void print( FILE* output, struct cons_pointer pointer) {
fwprintf(output, L"t");
break;
default:
fwprintf( stderr, L"Error: Unrecognised tag value %d (%c%c%c%c)\n",
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;

81
src/read.c
View file

@ -11,7 +11,9 @@
#include <math.h>
#include <stdbool.h>
#include <stdio.h>
/* wide characters */
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
@ -21,11 +23,11 @@
#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);
@ -35,9 +37,9 @@ struct cons_pointer read_symbol( FILE* input, wint_t initial);
/**
* quote reader macro in C (!)
*/
struct cons_pointer c_quote( struct cons_pointer arg) {
return make_cons( c_string_to_lisp_symbol( "quote"),
make_cons( arg, NIL));
struct cons_pointer c_quote(struct cons_pointer arg)
{
return make_cons(c_string_to_lisp_symbol("quote"), make_cons(arg, NIL));
}
/**
@ -45,14 +47,14 @@ struct cons_pointer c_quote( struct cons_pointer arg) {
* treating this initial character as the first character of the object
* representation.
*/
struct cons_pointer read_continuation( FILE* input, wint_t initial) {
struct cons_pointer read_continuation(FILE * input, wint_t initial)
{
struct cons_pointer result = NIL;
wint_t c;
for (c = initial;
c == '\0' || iswblank( c) || iswcntrl(c);
c = fgetwc( input));
c == '\0' || iswblank(c) || iswcntrl(c); c = fgetwc(input));
switch (c) {
case '\'':
@ -77,11 +79,11 @@ struct cons_pointer read_continuation( FILE* input, wint_t initial) {
return result;
}
/**
* read a number from this input stream, given this initial character.
*/
struct cons_pointer read_number( FILE* input, wint_t initial) {
struct cons_pointer read_number(FILE * input, wint_t initial)
{
int accumulator = 0;
int places_of_decimals = 0;
bool seen_period = false;
@ -101,24 +103,24 @@ struct cons_pointer read_number( FILE* input, wint_t initial) {
}
}
/* push back the character read which was not a digit */
/*
* push back the character read which was not a digit
*/
ungetwc(c, input);
if (seen_period) {
return make_real(accumulator / pow(10, places_of_decimals));
}
else
{
} else {
return make_integer(accumulator);
}
}
/**
* Read a list from this input stream, which no longer contains the opening
* left parenthesis.
*/
struct cons_pointer read_list( FILE* input, wint_t initial) {
struct cons_pointer read_list(FILE * input, wint_t initial)
{
struct cons_pointer result = NIL;
if (initial != ')') {
@ -132,7 +134,6 @@ struct cons_pointer read_list( FILE* input, wint_t initial) {
return result;
}
/**
* Read a string. This means either a string delimited by double quotes
* (is_quoted == true), in which case it may contain whitespace but may
@ -140,12 +141,12 @@ struct cons_pointer read_list( FILE* input, wint_t initial) {
* so delimited in which case it may not contain whitespace (unless escaped)
* but may contain a double quote character (probably not a good idea!)
*/
struct cons_pointer read_string( FILE* input, wint_t initial) {
struct cons_pointer read_string(FILE * input, wint_t initial)
{
struct cons_pointer cdr = NIL;
struct cons_pointer result;
fwprintf( stderr, L"read_string starting '%C' (%d)\n",
initial, initial);
fwprintf(stderr, L"read_string starting '%C' (%d)\n", initial, initial);
switch (initial) {
case '\0':
@ -162,32 +163,39 @@ struct cons_pointer read_string( FILE* input, wint_t initial) {
return result;
}
struct cons_pointer read_symbol( FILE* input, wint_t initial) {
struct cons_pointer read_symbol(FILE * input, wint_t initial)
{
struct cons_pointer cdr = NIL;
struct cons_pointer result;
fwprintf( stderr, L"read_symbol starting '%C' (%d)\n",
initial, initial);
fwprintf(stderr, L"read_symbol starting '%C' (%d)\n", initial, initial);
switch (initial) {
case '\0':
result = make_symbol(initial, NIL);
break;
case '"':
/* THIS IS NOT A GOOD IDEA, but is legal */
/*
* THIS IS NOT A GOOD IDEA, but is legal
*/
result = make_symbol(initial, read_symbol(input, fgetwc(input)));
break;
case ')':
/* unquoted strings may not include right-parenthesis */
/*
* unquoted strings may not include right-parenthesis
*/
result = make_symbol('\0', NIL);
/* push back the character read */
/*
* 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 */
/*
* push back the character read
*/
ungetwc(initial, input);
} else {
result = make_symbol(initial, read_symbol(input, fgetwc(input)));
@ -198,15 +206,10 @@ struct cons_pointer read_symbol( FILE* input, wint_t initial) {
return result;
}
/**
* Read the next object on this input stream and return a cons_pointer to it.
*/
struct cons_pointer read( FILE* input) {
struct cons_pointer read(FILE * input)
{
return read_continuation(input, fgetwc(input));
}

4
src/real.c
View file

@ -14,11 +14,11 @@
* @param value the value to wrap;
* @return a real number cell wrapping this value.
*/
struct cons_pointer make_real( long double value) {
struct cons_pointer 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;
}

3
src/real.h
View file

@ -26,10 +26,7 @@ extern "C" {
*/
struct cons_pointer make_real(double value);
#ifdef __cplusplus
}
#endif
#endif /* REAL_H */

8
src/repl.c
View file

@ -21,8 +21,10 @@
* @param err_stream the stream to send errors to;
* @param show_prompt true if prompts should be shown.
*/
void repl( FILE* in_stream, FILE* out_stream, FILE* error_stream,
bool show_prompt) {
void
repl(FILE * in_stream, FILE * out_stream, FILE * error_stream,
bool show_prompt)
{
while (!feof(in_stream)) {
if (show_prompt) {
fwprintf(out_stream, L"\n:: ");
@ -38,5 +40,3 @@ void repl( FILE* in_stream, FILE* out_stream, FILE* error_stream,
fwprintf(error_stream, L"\neval {%d,%d}=> ", input.page, input.offset);
}
}

7
src/repl.h
View file

@ -25,13 +25,10 @@ extern "C" {
* @param err_stream the stream to send errors to;
* @param show_prompt true if prompts should be shown.
*/
void repl( FILE* in_stream, FILE* out_stream, FILE* error_stream,
bool show_prompt);
void repl(FILE * in_stream, FILE * out_stream,
FILE * error_stream, bool show_prompt);
#ifdef __cplusplus
}
#endif
#endif /* REPL_H */

47
src/stack.c
View file

@ -31,14 +31,19 @@
*/
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 cons_pointer env)
{
/*
* TODO: later, pop a frame off a free-list of stack frames
*/
struct stack_frame *result = malloc(sizeof(struct stack_frame));
result->previous = previous;
/* clearing the frame with memset would probably be slightly quicker, but
* this is clear. */
/*
* clearing the frame with memset would probably be slightly quicker, but
* this is clear.
*/
result->more = NIL;
result->function = NIL;
@ -46,25 +51,29 @@ struct stack_frame* make_stack_frame( struct stack_frame* previous,
result->arg[i] = NIL;
}
int i = 0; /* still an index into args, so same
* name will do */
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 */
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 */
/*
* 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. */
/*
* TODO: this isn't right. These args should also each be evaled.
*/
result->more = args;
inc_ref(result->more);
@ -78,8 +87,11 @@ struct stack_frame* make_stack_frame( struct stack_frame* previous,
/**
* Free this stack frame.
*/
void free_stack_frame( struct stack_frame* frame) {
/* TODO: later, push it back on the stack-frame freelist */
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]);
}
@ -91,7 +103,8 @@ void free_stack_frame( struct stack_frame* frame) {
/**
* Fetch a pointer to the value of the local variable at this index.
*/
struct cons_pointer fetch_arg( struct stack_frame* frame, unsigned int index) {
struct cons_pointer fetch_arg(struct stack_frame *frame, unsigned int index)
{
struct cons_pointer result = NIL;
if (index < args_in_frame) {

6
src/stack.h
View file

@ -30,7 +30,9 @@ struct stack_frame* make_stack_frame( struct stack_frame* previous,
void free_stack_frame(struct stack_frame *frame);
struct cons_pointer fetch_arg(struct stack_frame *frame, unsigned int n);
/* struct stack_frame is defined in consspaceobject.h to break circularity
* TODO: refactor. */
/*
* struct stack_frame is defined in consspaceobject.h to break circularity
* TODO: refactor.
*/
#endif

1
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"