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

Merge branch 'master' into develop

Browse source
This commit is contained in:
simon 2017-08-14 13:06:15 +01:00
parent 84dcbdc38b 34c30f3ede
commit 48d4de668e
20 changed files with 1386 additions and 94 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

97
src/consspaceobject.c
View file

@ -11,6 +11,9 @@
#include <stdint.h>
#include <stdlib.h>
#include <string.h>
/* wide characters */
#include <wchar.h>
#include <wctype.h>
#include "conspage.h"
#include "consspaceobject.h"
@ -87,7 +90,7 @@ void dump_object( FILE* output, struct cons_pointer pointer) {
} else if ( check_tag(pointer, REALTAG)) {
fprintf( output, "\t\tReal cell: value %Lf\n", cell.payload.real.value);
} else if ( check_tag( pointer, STRINGTAG)) {
fprintf( output, "\t\tString cell: character '%c' next at page %d offset %d\n",
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);
};
@ -98,7 +101,9 @@ void dump_object( FILE* output, struct cons_pointer pointer) {
* 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 = allocate_cell( CONSTAG);
struct cons_pointer pointer = NIL;
pointer = allocate_cell( CONSTAG);
struct cons_space_object* cell = &conspages[pointer.page]->cell[pointer.offset];
@ -110,26 +115,104 @@ struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer cdr)
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);
cell->payload.function.source = src;
cell->payload.function.executable = executable;
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( char c, struct cons_pointer tail) {
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, STRINGTAG) || check_tag( tail, NILTAG)) {
pointer = allocate_cell( STRINGTAG);
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 = (uint32_t) c;
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 STRING can be appended to STRING\n");
fprintf( stderr, "Warning: only NIL and %s can be appended to %s\n",
tag, tag);
}
return 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) {
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);
}
/**
* 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);
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;
for ( int i = strlen( string); i > 0; i--) {
result = make_string( (wint_t)string[ i - 1], 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;
for ( int i = strlen( symbol); i > 0; i--) {
result = make_symbol( (wint_t)symbol[ i - 1], result);
}
return result;
}

259
src/consspaceobject.h
View file

@ -8,8 +8,12 @@
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdbool.h>
#include <stdint.h>
#include <stdio.h>
/* wide characters */
#include <wchar.h>
#include <wctype.h>
#ifndef __consspaceobject_h
#define __consspaceobject_h
@ -22,15 +26,82 @@
/**
* tag values, all of which must be 4 bytes. Must not collide with vector space tag values
*/
/**
* An ordinary cons cell: 1397641027
*/
#define CONSTAG "CONS"
#define CONSTV 1397641027
/**
* An unallocated cell on the free list - should never be encountered by a Lisp
* function. 1162170950
*/
#define FREETAG "FREE"
#define FREETV 1162170950
/**
* An ordinary Lisp function - one whose arguments are pre-evaluated and passed as
* a stack frame. 1129207110
*/
#define FUNCTIONTAG "FUNC"
#define FUNCTIONTV 1129207110
/**
* An integer number. 1381256777
*/
#define INTEGERTAG "INTR"
#define INTEGERTV 1381256777
/**
* The special cons cell at address {0,0} whose car and cdr both point to itself.
* 541870414
*/
#define NILTAG "NIL "
#define NILTV 541870414
/**
* An open read stream.
*/
#define READTAG "READ"
/**
* A real number.
*/
#define REALTAG "REAL"
/**
* A special form - one whose arguments are not pre-evaluated but passed as a
* s-expression. 1296453715
*/
#define SPECIALTAG "SPFM"
#define SPECIALTV 1296453715
/**
* A string of characters, organised as a linked list. 1196577875
*/
#define STRINGTAG "STRG"
#define STRINGTV 1196577875
/**
* A symbol is just like a string except not self-evaluating. 1112365395
*/
#define SYMBOLTAG "SYMB"
#define SYMBOLTV 1112365395
/**
* The special cons cell at address {0,1} which is canonically different from NIL.
* 1163219540
*/
#define TRUETAG "TRUE"
#define TRUETV 1163219540
/**
* A pointer to an object in vector space.
*/
#define VECTORPOINTTAG "VECP"
/**
* An open write stream.
*/
#define WRITETAG "WRIT"
/**
@ -38,6 +109,11 @@
*/
#define NIL (struct cons_pointer){ 0, 0}
/**
* a cons pointer which points to the special T cell
*/
#define TRUE (struct cons_pointer){ 0, 1}
/**
* the maximum possible value of a reference count
*/
@ -52,6 +128,7 @@
/**
* true if conspointer points to the special cell NIL, else false
* (there should only be one of these so it's slightly redundant).
*/
#define nilp(conspoint) (check_tag(conspoint,NILTAG))
@ -60,11 +137,65 @@
*/
#define consp(conspoint) (check_tag(conspoint,CONSTAG))
/**
* true if conspointer points to a function cell, else false
*/
#define functionp(conspoint) (check_tag(conspoint,FUNCTIONTAG))
/**
* true if conspointer points to a special form cell, else false
*/
#define specialp(conspoint) (check_tag(conspoint,SPECIALTAG))
/**
* true if conspointer points to a string cell, else false
*/
#define stringp(conspoint) (check_tag(conspoint,STRINGTAG))
/**
* true if conspointer points to a string cell, else false
*/
#define symbolp(conspoint) (check_tag(conspoint,SYMBOLTAG))
/**
* true if conspointer points to an integer cell, else false
*/
#define integerp(conspoint) (check_tag(conspoint,INTEGERTAG))
/**
* true if conspointer points to a read stream cell, else false
*/
#define readp(conspoint) (check_tag(conspoint,READTAG))
/**
* true if conspointer points to a real number cell, else false
*/
#define realp(conspoint) (check_tag(conspoint,REALTAG))
/**
* true if conspointer points to some sort of a number cell,
* else false
*/
#define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,REALTAG))
/**
* true if conspointer points to a write stream cell, else false.
*/
#define writep(conspoint) (check_tag(conspoint,WRITETAG))
/**
* true if conspointer points to a true cell, else false
* (there should only be one of these so it's slightly redundant).
* Also note that anything that is not NIL is truthy.
*/
#define tp(conspoint) (checktag(conspoint,TRUETAG))
/**
* true if conspoint points to something that is truthy, i.e.
* anything but NIL.
*/
#define truep(conspoint) (!checktag(conspoint,NILTAG))
/**
* An indirect pointer to a cons cell
*/
@ -73,6 +204,21 @@ struct cons_pointer {
uint32_t offset; /* the index of the cell within the page */
};
/* number of arguments stored in a stack frame */
#define args_in_frame 8
/**
* A stack frame. Yes, I know it isn't a cons-space object, but it's defined
* 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 */
};
/**
* payload of a cons cell.
@ -82,6 +228,20 @@ struct cons_payload {
struct cons_pointer cdr;
};
/**
* Payload of a function cell.
* source points to the source from which the function was compiled, or NIL
* if it is a primitive.
* executable points to a function which takes a pointer to a stack frame
* (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);
};
/**
* payload of a free cell. For the time being identical to a cons cell,
* but it may not be so in future.
@ -100,7 +260,6 @@ struct integer_payload {
long int value;
};
/**
* payload for a real number cell. Internals of this liable to change to give 128 bits
* precision, but I'm not sure of the detail.
@ -110,14 +269,57 @@ struct real_payload {
};
/**
* payload of a string cell. At least at first, only one UTF character will be stored in each cell.
* Payload of a special form cell.
* source points to the source from which the function was compiled, or NIL
* if it is a primitive.
* executable points to a function which takes a cons pointer (representing
* its argument list) and a cons pointer (representing its environment) and a
* stack frame (representing the previous stack frame) as arguments and returns
* a cons pointer (representing its result).
*
* 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);
};
/**
* payload of a read or write stream cell.
*/
struct stream_payload {
FILE * stream;
};
/**
* payload of a string cell. At least at first, only one UTF character will
* be stored in each cell. The doctrine that 'a symbol is just a string'
* didn't work; however, the payload of a symbol cell is identical to the
* payload of a string cell.
*/
struct string_payload {
uint32_t character; /* the actual character stored in this cell */
wint_t character; /* the actual character stored in this cell */
uint32_t padding; /* unused padding to word-align the cdr */
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) */
};
/**
* an object in cons space.
*/
@ -133,16 +335,24 @@ struct cons_space_object {
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 == STRINGTAG */
/* 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;
};
@ -173,11 +383,42 @@ void dump_object( FILE* output, struct cons_pointer pointer);
struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer cdr);
/**
* 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.
* Construct a cell which points to an executable Lisp special form.
*/
struct cons_pointer make_string( char c, struct cons_pointer tail);
struct cons_pointer make_function( struct cons_pointer src,
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));
/**
* 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);
/**
* 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);
/**
* Return a lisp string representation of this old skool ASCII 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);
#endif

62
src/equal.c Normal file
View file

@ -0,0 +1,62 @@
/**
* equal.c
*
* Checks for shallow and deep equality
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <math.h>
#include <stdbool.h>
#include "conspage.h"
#include "consspaceobject.h"
#include "integer.h"
/**
* 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));
}
/**
* 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);
if ( ! result) {
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);
/* 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.*/
}
return result;
}

30
src/equal.h Normal file
View file

@ -0,0 +1,30 @@
/**
* equal.h
*
* Checks for shallow and deep equality
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <math.h>
#include <stdbool.h>
#include "consspaceobject.h"
#ifndef __equal_h
#define __equal_h
/**
* 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);
/**
* 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);
#endif

42
src/init.c
View file

@ -1,8 +1,8 @@
/**
* init.c
*
* Start up and initialise the environement - just enough to get working and (ultimately)
* hand off to the executive.
* Start up and initialise the environement - just enough to get working
* and (ultimately) hand off to the executive.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
@ -14,17 +14,53 @@
#include "version.h"
#include "conspage.h"
#include "consspaceobject.h"
#include "intern.h"
#include "lispops.h"
#include "print.h"
#include "read.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_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));
}
int main (int argc, char *argv[]) {
fprintf( stderr, "Post scarcity software environment version %s\n", VERSION);
initialise_cons_pages();
/* 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 */
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);
/* primitive special forms */
bind_special( "apply", &lisp_apply);
bind_special( "eval", &lisp_eval);
bind_special( "quote", &lisp_quote);
fprintf( stderr, "\n:: ");
struct cons_pointer input = read( stdin);
fprintf( stderr, "\n{%d,%d}=> ", input.page, input.offset);
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));
dump_pages(stderr);

22
src/integer.c
View file

@ -7,10 +7,32 @@
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#define _GNU_SOURCE
#include <math.h>
#include "conspage.h"
#include "consspaceobject.h"
#include "read.h"
/**
* return the numeric value of this cell, as a C primitive double, not
* 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);
if ( integerp( pointer)) {
result = (double) cell->payload.integer.value;
} else if ( realp( pointer)) {
result = cell->payload.real.value;
}
return result;
}
/**
* Allocate an integer cell representing this value and return a cons pointer to it.
*/

2
src/integer.h
View file

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

127
src/intern.c Normal file
View file

@ -0,0 +1,127 @@
/**
* intern.c
*
* For now this implements an oblist and shallow binding; local environments can
* be consed onto the front of the oblist. Later, this won't do; bindings will happen
* in namespaces, which will probably be implemented as hash tables.
*
* Doctrine is that cons cells are immutable, and life is a lot more simple if they are;
* so when a symbol is rebound in the master oblist, what in fact we do is construct
* a new oblist without the previous binding but with the new binding. Anything which,
* prior to this action, held a pointer to the old oblist (as all current threads'
* environments must do) continues to hold a pointer to the old oblist, and consequently
* doesn't see the change. This is probably good but does mean you cannot use bindings
* on the oblist to signal between threads.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdbool.h>
#include "equal.h"
#include "conspage.h"
#include "consspaceobject.h"
/**
* The object list. What is added to this during system setup is 'global', that is,
* visible to all sessions/threads. What is added during a session/thread is local to
* that session/thread (because shallow binding). There must be some way for a user to
* make the contents of their own environment persistent between threads but I don't
* know what it is yet. At some stage there must be a way to rebind deep values so
* they're visible to all users/threads, but again I don't yet have any idea how
* that will work.
*/
struct cons_pointer oblist = NIL;
/**
* Implementation of interned? in C. The final implementation if interned? will
* deal with stores which can be association lists or hashtables or hybrids of
* the two, but that will almost certainly be implemented in lisp.
*
* If this key is lexically identical to a key in this store, return the key
* 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;
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;
}
}
return result;
}
/**
* Implementation of assoc in C. Like interned?, the final implementation will
* deal with stores which can be association lists or hashtables or hybrids of
* the two, but that will almost certainly be implemented in lisp.
*
* 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;
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;
}
}
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);
}
/**
* 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;
}
/**
* 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);
if ( nilp( canonical)) {
/* not currently bound */
result = bind( key, NIL, environment);
}
return result;
}

62
src/intern.h Normal file
View file

@ -0,0 +1,62 @@
/**
* intern.h
*
* For now this implements an oblist and shallow binding; local environments can
* be consed onto the front of the oblist. Later, this won't do; bindings will happen
* in namespaces, which will probably be implemented as hash tables.
*
* Doctrine is that cons cells are immutable, and life is a lot more simple if they are;
* so when a symbol is rebound in the master oblist, what in fact we do is construct
* a new oblist without the previous binding but with the new binding. Anything which,
* prior to this action, held a pointer to the old oblist (as all current threads'
* environments must do) continues to hold a pointer to the old oblist, and consequently
* doesn't see the change. This is probably good but does mean you cannot use bindings
* on the oblist to signal between threads.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __intern_h
#define __intern_h
extern struct cons_pointer oblist;
/**
* return the value associated with this key in this store. In the current
* 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);
/**
* 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);
/**
* 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);
/**
* 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);
/**
* 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);
#endif

340
src/lispops.c Normal file
View file

@ -0,0 +1,340 @@
/**
* lispops.c
*
* List processing operations.
*
* The general idea here is that a list processing operation is a
* function which takes two arguments, both cons_pointers:
*
* 1. args, the argument list to this function;
* 2. env, the environment in which this function should be evaluated;
*
* and returns a cons_pointer, the result.
*
* They must all have the same signature so that I can call them as
* function pointers.
*
* (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 "consspaceobject.h"
#include "conspage.h"
#include "equal.h"
#include "integer.h"
#include "intern.h"
#include "lispops.h"
#include "print.h"
#include "read.h"
#include "stack.h"
/*
* also to create in this section:
* struct cons_pointer lisp_cond( struct cons_pointer args, struct cons_pointer env,
struct stack_frame* frame);
* struct cons_pointer lisp_let( struct cons_pointer args, struct cons_pointer env,
struct stack_frame* frame);
* struct cons_pointer lisp_mapcar( struct cons_pointer args, struct cons_pointer env,
struct stack_frame* frame);
*
* and others I haven't thought of yet.
*/
/**
* 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;
}
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;
}
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.
*/
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);
}
return result;
}
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);
switch ( fn_cell.tag.value) {
case SPECIALTV :
{
struct cons_space_object special = pointer2cell( fn_pointer);
result = (*special.payload.special.executable)( args, env, my_frame);
}
break;
case FUNCTIONTV :
/* actually, this is apply */
{
struct cons_space_object function = pointer2cell( fn_pointer);
struct stack_frame* frame = make_stack_frame( my_frame, args, env);
/* the trick: pass the remaining arguments and environment to
the executable code which is the payload of the function
object. */
result = (*function.payload.function.executable)( frame, env);
free_stack_frame( frame);
}
break;
default :
{
char* buffer = malloc( 1024);
memset( buffer, '\0', 1024);
sprintf( buffer,
"Unexpected cell with tag %d (%c%c%c%c) in function position",
fn_cell.tag.value, fn_cell.tag.bytes[0], fn_cell.tag.bytes[1],
fn_cell.tag.bytes[2], fn_cell.tag.bytes[3]);
struct cons_pointer message = c_string_to_lisp_string( buffer);
free( buffer);
result = lisp_throw( message, my_frame);
}
}
return result;
}
/**
* (eval s_expr)
*
* Special form.
* If s_expr is a number, NIL, or T, returns s_expr.
* If s_expr is an unprotected string, returns the value that s_expr is bound
* to in the evaluation environment (env).
* If s_expr is a list, expects the car to be something that evaluates to a
* function or special form.
* If a function, evaluates all the other top level elements in s_expr and
* 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);
switch ( cell.tag.value) {
case CONSTV :
result = eval_cons( s_expr, env, my_frame);
break;
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);
}
}
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;
}
/**
* (quote a)
*
* Special form
* 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);
}
/**
* (cons a b)
*
* Function.
* 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;
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;
}
/**
* (car s_expr)
* 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;
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);
}
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;
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);
}
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]);
}
/**
* (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;
}
/**
* (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;
}
/**
* (read)
* (read read-stream)
* 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;
if ( readp( frame->arg[0])) {
input = pointer2cell( frame->arg[0]).payload.stream.stream;
}
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;
if ( writep( frame->arg[1])) {
output = pointer2cell( frame->arg[1]).payload.stream.stream;
}
print( output, frame->arg[0]);
return NIL;
}
/**
* 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");
exit( 1);
}

41
src/lispops.h Normal file
View file

@ -0,0 +1,41 @@
/**
* lispops.h
*
* List processing operations.
*
* The general idea here is that a list processing operation is a
* function which takes two arguments, both cons_pointers:
*
* 1. args, the argument list to this function;
* 2. env, the environment in which this function should be evaluated;
*
* and returns a cons_pointer, the result.
*
* They must all have the same signature so that I can call them as
* function pointers.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* 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);
/* 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);

67
src/print.c
View file

@ -11,6 +11,9 @@
#include <ctype.h>
#include <stdio.h>
#include <string.h>
/* wide characters */
#include <wchar.h>
#include <wctype.h>
#include "conspage.h"
#include "consspaceobject.h"
@ -18,12 +21,12 @@
#include "print.h"
void print_string_contents( FILE* output, struct cons_pointer pointer) {
if ( check_tag( pointer, STRINGTAG)) {
if ( stringp( pointer) || symbolp( pointer)) {
struct cons_space_object* cell = &pointer2cell(pointer);
char c = cell->payload.string.character;
wint_t c = cell->payload.string.character;
if ( c != '\0') {
fputc( c, output);
fputwc( c, output);
}
print_string_contents( output, cell->payload.string.cdr);
}
@ -36,41 +39,65 @@ void print_string( FILE* output, struct cons_pointer pointer) {
fputc( '"', output);
}
void print_list_contents( FILE* output, struct cons_pointer pointer) {
if ( check_tag( pointer, CONSTAG)) {
/**
* 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) {
struct cons_space_object* cell = &pointer2cell(pointer);
print( output, cell->payload.cons.car);
if ( !nilp( cell->payload.cons.cdr)) {
switch ( cell->tag.value) {
case CONSTV :
if (initial_space) {
fputc( ' ', output);
}
print_list_contents( output, cell->payload.cons.cdr);
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);
}
}
void print_list( FILE* output, struct cons_pointer pointer) {
fputc( '(', output);
print_list_contents( output, pointer);
print_list_contents( output, pointer, false);
fputc( ')', output);
}
void print( FILE* output, struct cons_pointer pointer) {
struct cons_space_object cell = pointer2cell( pointer);
if ( check_tag( pointer, CONSTAG)) {
/* 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);
} else if ( check_tag( pointer, INTEGERTAG)) {
break;
case INTEGERTV :
fprintf( output, "%ld", cell.payload.integer.value);
} else if ( check_tag( pointer, NILTAG)) {
fprintf( output, "NIL");
} else if ( check_tag( pointer, REALTAG)) {
fprintf( output, "%Lf", cell.payload.real.value);
} else if ( check_tag( pointer, STRINGTAG)) {
break;
case NILTV :
fprintf( output, "nil");
break;
case STRINGTV :
print_string( output, pointer);
} else if ( check_tag( pointer, TRUETAG)) {
fprintf( output, "T");
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]);
}
}

129
src/read.c
View file

@ -8,12 +8,15 @@
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <ctype.h>
#include <stdbool.h>
#include <stdio.h>
/* wide characters */
#include <wchar.h>
#include <wctype.h>
#include "consspaceobject.h"
#include "integer.h"
#include "intern.h"
#include "read.h"
/* for the time being things which may be read are:
@ -22,46 +25,52 @@
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, char initial);
struct cons_pointer read_list( FILE* input, char initial);
struct cons_pointer read_string( FILE* input, char 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));
}
/**
* Read the next object on this input stream and return a cons_pointer to it,
* treating this initial character as the first character of the object
* representation.
*/
struct cons_pointer read_continuation( FILE* input, char initial) {
struct cons_pointer read_continuation( FILE* input, wint_t initial) {
struct cons_pointer result = NIL;
char c;
wint_t c;
for (c = initial; c == '\0' || isblank( c); c = fgetc( input));
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 '(' :
case ')':
result = read_list(input, fgetc( input));
result = read_list(input, fgetwc( input));
break;
case '"': result = read_string(input, fgetc( input));
break;
case '0':
case '1':
case '2':
case '3':
case '4':
case '5':
case '6':
case '7':
case '8':
case '9':
// case '.':
result = read_number( input, c);
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);
}
}
return result;
}
@ -70,15 +79,15 @@ struct cons_pointer read_continuation( FILE* input, char initial) {
/**
* read a number from this input stream, given this initial character.
*/
struct cons_pointer read_number( FILE* input, char initial) {
struct cons_pointer read_number( FILE* input, wint_t initial) {
int accumulator = 0;
int places_of_decimals = 0;
bool seen_period = false;
char c;
wint_t c;
fprintf( stderr, "read_number starting '%c' (%d)\n", initial, initial);
for (c = initial; isdigit( c); c = fgetc( input)) {
for (c = initial; iswdigit( c); c = fgetwc( input)) {
if ( c == '.') {
seen_period = true;
} else {
@ -91,7 +100,7 @@ struct cons_pointer read_number( FILE* input, char initial) {
}
/* push back the character read which was not a digit */
fputc( c, input);
ungetwc( c, input);
return make_integer( accumulator);
}
@ -101,16 +110,15 @@ struct cons_pointer read_number( FILE* input, char initial) {
* Read a list from this input stream, which no longer contains the opening
* left parenthesis.
*/
struct cons_pointer read_list( FILE* input, char initial) {
struct cons_pointer cdr = NIL;
struct cons_pointer read_list( FILE* input, wint_t initial) {
struct cons_pointer result= NIL;
fprintf( stderr, "read_list starting '%c' (%d)\n", initial, initial);
if ( initial != ')' ) {
fwprintf( stderr, L"read_list starting '%C' (%d)\n", initial, initial);
struct cons_pointer car = read_continuation( input, initial);
cdr = read_list( input, fgetc( input));
result = make_cons( car, cdr);
result = make_cons( car, read_list( input, fgetwc( input)));
} else {
fprintf( stderr, "End of list detected\n");
}
return result;
@ -118,16 +126,18 @@ struct cons_pointer read_list( FILE* input, char initial) {
/**
* Read a string from this input stream, which no longer contains the opening
* double quote. Note that there is (for now) a problem with the list
* representation of a string, which is that there's no obvious representation of
* an empty string.
* 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, char initial) {
struct cons_pointer read_string( FILE* input, wint_t initial) {
struct cons_pointer cdr = NIL;
struct cons_pointer result;
fprintf( stderr, "read_string starting '%c' (%d)\n", initial, initial);
fwprintf( stderr, L"read_string starting '%C' (%d)\n",
initial, initial);
switch ( initial) {
case '\0':
@ -137,7 +147,43 @@ struct cons_pointer read_string( FILE* input, char initial) {
result = make_string( '\0', NIL);
break;
default:
result = make_string( initial, read_string( input, fgetc( input)));
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)));
}
break;
}
@ -149,9 +195,10 @@ struct cons_pointer read_string( FILE* input, char initial) {
* 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, '\0');
return read_continuation( input, fgetwc( input));
}

110
src/stack.c Normal file
View file

@ -0,0 +1,110 @@
/**
* stack.c
*
* 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
* 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.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdlib.h>
#include "consspaceobject.h"
#include "conspage.h"
#include "lispops.h"
#include "stack.h"
/**
* Allocate a new stack frame with its previous pointer set to this value,
* its arguments set up from these args, evaluated in this env.
*/
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));
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;
}
int i = 0; /* still an index into args, so same
* name will do */
while ( ! nilp( args)) { /* iterate down the arg list filling in
* the arg slots in the frame. When there
* are no more slots, if there are still
* args, stash them on more */
struct cons_space_object cell = pointer2cell( args);
if ( i < args_in_frame) {
/* TODO: if we were running on real massively parallel hardware, each
* arg except the first should be handed off to another processor to
* be evaled in parallel */
result->arg[i] = lisp_eval( cell.payload.cons.car, env, result);
inc_ref( result->arg[i]);
args = cell.payload.cons.cdr;
} else {
/* TODO: this isn't right. These args should also each be evaled. */
result->more = args;
inc_ref( result->more);
args = NIL;
}
}
return result;
}
/**
* Free this stack frame.
*/
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);
}
/**
* 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;
}
result = pointer2cell( p).payload.cons.car;
}
return result;
}

36
src/stack.h Normal file
View file

@ -0,0 +1,36 @@
/**
* stack.h
*
* 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
* 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.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include "consspaceobject.h"
#include "conspage.h"
#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);
/* struct stack_frame is defined in consspaceobject.h to break circularity
* TODO: refactor. */
#endif

4
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`
expected='(1 2 3 ("Fred") nil 77354)'
actual=`echo '(1 2 3 ("Fred") () 77354)' | target/psse 2> /dev/null`
if [ "${expected}" = "${actual}" ]
then

2
unit-tests/nil.sh
View file

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

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

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

13
unit-tests/quoted-list.sh Normal file
View file

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

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`
if [ "${expected}" = "${actual}" ]
then