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

Merge remote-tracking branch 'origin/master'

Browse source
This commit is contained in:
simon 2017-08-14 13:04:26 +01:00
parent cf62b4d088 e968b30bbc
commit 34c30f3ede
17 changed files with 1130 additions and 160 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 <stdint.h>
#include <stdlib.h> #include <stdlib.h>
#include <string.h> #include <string.h>
/* wide characters */
#include <wchar.h>
#include <wctype.h>
#include "conspage.h" #include "conspage.h"
#include "consspaceobject.h" #include "consspaceobject.h"
@ -87,7 +90,7 @@ void dump_object( FILE* output, struct cons_pointer pointer) {
} else if ( check_tag(pointer, REALTAG)) { } else if ( check_tag(pointer, REALTAG)) {
fprintf( output, "\t\tReal cell: value %Lf\n", cell.payload.real.value); fprintf( output, "\t\tReal cell: value %Lf\n", cell.payload.real.value);
} else if ( check_tag( pointer, STRINGTAG)) { } 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.character, cell.payload.string.cdr.page,
cell.payload.string.cdr.offset); 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. * 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 = allocate_cell( CONSTAG); 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];
@ -109,6 +114,21 @@ struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer cdr)
return pointer; return pointer;
} }
/**
* Construct a cell which points to an executable Lisp special form.
*/
struct cons_pointer make_function( struct cons_pointer src,
struct cons_pointer (*executable)
(struct stack_frame*, struct cons_pointer)) {
struct cons_pointer pointer = allocate_cell( FUNCTIONTAG);
struct cons_space_object* cell = &pointer2cell(pointer);
cell->payload.function.source = src;
cell->payload.function.executable = executable;
return pointer;
}
/** /**
* Construct a string from this character (which later will be UTF) and * Construct a string from this character (which later will be UTF) and
@ -116,20 +136,83 @@ struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer cdr)
* has one character and a pointer to the next; in the last cell the * has one character and a pointer to the next; in the last cell the
* pointer to next is NIL. * pointer to next is NIL.
*/ */
struct cons_pointer make_string( 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; struct cons_pointer pointer = NIL;
if ( check_tag( tail, STRINGTAG) || check_tag( tail, NILTAG)) { if ( check_tag( tail, tag) || check_tag( tail, NILTAG)) {
pointer = allocate_cell( STRINGTAG); pointer = allocate_cell( tag);
struct cons_space_object* cell = &pointer2cell(pointer); struct cons_space_object* cell = &pointer2cell(pointer);
inc_ref(tail); inc_ref(tail);
cell->payload.string.character = (uint32_t) c; cell->payload.string.character = c;
cell->payload.string.cdr.page = tail.page; cell->payload.string.cdr.page = tail.page;
cell->payload.string.cdr.offset = tail.offset; cell->payload.string.cdr.offset = tail.offset;
} else { } else {
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; 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;
}

233
src/consspaceobject.h
View file

@ -11,6 +11,9 @@
#include <stdbool.h> #include <stdbool.h>
#include <stdint.h> #include <stdint.h>
#include <stdio.h> #include <stdio.h>
/* wide characters */
#include <wchar.h>
#include <wctype.h>
#ifndef __consspaceobject_h #ifndef __consspaceobject_h
#define __consspaceobject_h #define __consspaceobject_h
@ -23,23 +26,94 @@
/** /**
* tag values, all of which must be 4 bytes. Must not collide with vector space tag values * tag values, all of which must be 4 bytes. Must not collide with vector space tag values
*/ */
#define CONSTAG "CONS" /**
#define FREETAG "FREE" * 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 FUNCTIONTAG "FUNC"
#define FUNCTIONTV 1129207110
/**
* An integer number. 1381256777
*/
#define INTEGERTAG "INTR" #define INTEGERTAG "INTR"
#define NILTAG "NIL " #define INTEGERTV 1381256777
#define READTAG "READ"
#define REALTAG "REAL" /**
#define STRINGTAG "STRG" * The special cons cell at address {0,0} whose car and cdr both point to itself.
#define TRUETAG "TRUE" * 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" #define VECTORPOINTTAG "VECP"
#define WRITETAG "WRIT"
/**
* An open write stream.
*/
#define WRITETAG "WRIT"
/** /**
* a cons pointer which points to the special NIL cell * a cons pointer which points to the special NIL cell
*/ */
#define NIL (struct cons_pointer){ 0, 0} #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 * the maximum possible value of a reference count
*/ */
@ -68,16 +142,31 @@
*/ */
#define functionp(conspoint) (check_tag(conspoint,FUNCTIONTAG)) #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 * true if conspointer points to a string cell, else false
*/ */
#define stringp(conspoint) (check_tag(conspoint,STRINGTAG)) #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 * true if conspointer points to an integer cell, else false
*/ */
#define integerp(conspoint) (check_tag(conspoint,INTEGERTAG)) #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 * true if conspointer points to a real number cell, else false
*/ */
@ -89,6 +178,11 @@
*/ */
#define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,REALTAG)) #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 * true if conspointer points to a true cell, else false
* (there should only be one of these so it's slightly redundant). * (there should only be one of these so it's slightly redundant).
@ -110,6 +204,21 @@ struct cons_pointer {
uint32_t offset; /* the index of the cell within the page */ 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. * payload of a cons cell.
@ -119,9 +228,18 @@ struct cons_payload {
struct cons_pointer cdr; 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 function_payload {
struct cons_pointer source; struct cons_pointer source;
struct cons_pointer (*executable)(struct cons_pointer, struct cons_pointer); struct cons_pointer (*executable)(struct stack_frame*, struct cons_pointer);
}; };
/** /**
@ -142,7 +260,6 @@ struct integer_payload {
long int value; long int value;
}; };
/** /**
* payload for a real number cell. Internals of this liable to change to give 128 bits * 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. * precision, but I'm not sure of the detail.
@ -152,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 { 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 */ uint32_t padding; /* unused padding to word-align the cdr */
struct cons_pointer 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. * an object in cons space.
*/ */
@ -181,12 +341,18 @@ struct cons_space_object {
struct integer_payload integer; 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; struct cons_payload nil;
/* if tag == READTAG || tag == WRITETAG */
struct stream_payload stream;
/* if tag == REALTAG */ /* if tag == REALTAG */
struct real_payload real; struct real_payload real;
/* if tag == STRINGTAG */ /* if tag == SPECIALTAG */
struct special_payload special;
/* if tag == STRINGTAG || tag == SYMBOLTAG */
struct string_payload string; 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; struct cons_payload t;
/* if tag == VECTORPTAG */
struct vectorp_payload vectorp;
} payload; } payload;
}; };
@ -217,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); 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 * Construct a cell which points to an executable Lisp special form.
* 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_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 #endif

2
src/equal.h
View file

@ -10,6 +10,8 @@
#include <math.h> #include <math.h>
#include <stdbool.h> #include <stdbool.h>
#include "consspaceobject.h"
#ifndef __equal_h #ifndef __equal_h
#define __equal_h #define __equal_h

42
src/init.c
View file

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

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

309
src/lispops.c
View file

@ -14,7 +14,6 @@
* They must all have the same signature so that I can call them as * They must all have the same signature so that I can call them as
* function pointers. * function pointers.
* *
*
* (c) 2017 Simon Brooke <simon@journeyman.cc> * (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version. * Licensed under GPL version 2.0, or, at your option, any later version.
*/ */
@ -22,28 +21,52 @@
#include <ctype.h> #include <ctype.h>
#include <stdbool.h> #include <stdbool.h>
#include <stdio.h> #include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include "consspaceobject.h" #include "consspaceobject.h"
#include "conspage.h" #include "conspage.h"
#include "equal.h"
#include "integer.h" #include "integer.h"
#include "intern.h"
#include "lispops.h"
#include "print.h"
#include "read.h" #include "read.h"
#include "stack.h"
struct cons_pointer lisp_eval( struct cons_pointer args, struct cons_pointer env); /*
struct cons_pointer lisp_cons( struct cons_pointer args, struct cons_pointer env); * also to create in this section:
struct cons_pointer lisp_car( struct cons_pointer args, struct cons_pointer env); * struct cons_pointer lisp_cond( struct cons_pointer args, struct cons_pointer env,
struct cons_pointer lisp_cdr( 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_let( struct cons_pointer args, struct cons_pointer env,
struct cons_pointer lisp_throw( 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.
*/
/** /**
* in the long run this becomes redundant because it's just (map eval * Implementation of car in C. If arg is not a cons, does not error but returns nil.
* args), but it helps bootstrapping.
*/ */
struct cons_pointer i_eval_args( struct cons_pointer args, struct cons_pointer tail, struct cons_pointer env) { struct cons_pointer c_car( struct cons_pointer arg) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
if ( ! nilp( args)) { if ( consp(arg)) {
result = make_cons( lisp_eval( lisp_car( args)), i_eval_args( lisp_cdr( args), tail)); 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; return result;
@ -51,82 +74,171 @@ struct cons_pointer i_eval_args( struct cons_pointer args, struct cons_pointer t
/** /**
* (apply fn args...) * (apply fn args...)
* I'm assuming that the function should be protected from evaluation *
* in apply because its name has already been resolved to the function * I'm now confused about whether at this stage I actually need an apply special form,
* object in read. * and if so how it differs from eval.
*/ */
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 result = args; struct cons_pointer result = args;
if ( consp( args)) { if ( consp( args)) {
lisp_eval( make_cons( lisp_car( args), i_eval_args( lisp_cdr( args), NIL))); lisp_eval( args, env, frame);
} }
return result; return result;
} }
/** struct cons_pointer eval_cons( struct cons_pointer s_expr, struct cons_pointer env,
* (eval args) struct stack_frame* my_frame) {
*/ struct cons_pointer result = NIL;
struct cons_pointer lisp_eval( struct cons_pointer args, struct cons_pointer env) { struct cons_pointer fn_pointer = lisp_eval( c_car( s_expr), env, my_frame);
struct cons_pointer result = args; struct cons_space_object fn_cell = pointer2cell( fn_pointer);
struct cons_pointer args = c_cdr( s_expr);
if ( consp( args)) {
/* the hard bit. Sort out what function is required and pass the
* args to it. */
struct cons_pointer fn_pointer lisp_car( args);
args = lisp_cdr( args);
if ( functionp( fn_pointer)) { 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 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 trick: pass the remaining arguments and environment to
the executable code which is the payload of the function the executable code which is the payload of the function
object. */ object. */
result = (*function.payload.function.executable)( args, env); result = (*function.payload.function.executable)( frame, env);
} else { free_stack_frame( frame);
/* 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; break;
* also if the object is a consp it could be interpretable
* source code but in the long run I don't want an interpreter, default :
* and if I can get away without so much the better. */ {
result = lisp_throw( args, env) char* buffer = malloc( 1024);
} memset( buffer, '\0', 1024);
sprintf( buffer,
"Unexpected cell with tag %d (%c%c%c%c) in function position",
fn_cell.tag.value, fn_cell.tag.bytes[0], fn_cell.tag.bytes[1],
fn_cell.tag.bytes[2], fn_cell.tag.bytes[3]);
struct cons_pointer message = c_string_to_lisp_string( buffer);
free( buffer);
result = lisp_throw( message, my_frame);
}
} }
return result; return result;
} }
/** /**
* Apply cons to this argsument list. Effectively, create a cons cell comprising * (eval s_expr)
* (car args) (cadr args). *
* 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 cons_pointer args, struct cons_pointer env) { struct cons_pointer lisp_cons(struct stack_frame* frame, struct cons_pointer env) {
struct cons_pointer result = NIL; struct cons_pointer car = frame->arg[0];
struct cons_pointer cdr = frame->arg[1];
struct cons_pointer result;
if ( consp( args)) { if ( nilp( car) && nilp( cdr)) {
struct cons_space_object cell = pointer2cell( args); return NIL;
struct cons_pointer a = cell.payload.cons.car; } else if ( stringp( car) && stringp( cdr) &&
struct cons_pointer d = pointer2cell( cell.payload.cons.cdr).payload.cons.car; nilp( pointer2cell( car).payload.string.cdr)) {
result = make_cons( a, d); result = make_string( pointer2cell( car).payload.string.character, cdr);
} else { } else {
lisp_throw( args); result = make_cons( car, cdr);
} }
return result; return result;
} }
/** /**
* Apply car to this argsument list. Effectively, (car (car args)) * (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 cons_pointer args, struct cons_pointer env) { struct cons_pointer lisp_car(struct stack_frame* frame, struct cons_pointer env) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
if ( consp( args)) { if ( consp( frame->arg[ 0])) {
struct cons_space_object cell = pointer2cell( args); struct cons_space_object cell = pointer2cell( frame->arg[ 0]);
result = pointer2cell( cell.payload.cons.car).payload.cons.car; 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 { } else {
lisp_throw( args); struct cons_pointer message =
c_string_to_lisp_string( "Attempt to take CAR/CDR of non sequence");
result = lisp_throw( message, frame);
} }
return result; return result;
@ -134,28 +246,95 @@ struct cons_pointer lisp_car( struct cons_pointer args, struct cons_pointer env)
/** /**
* Apply cdr to this argsument list. Effectively, (cdr (car args)) * (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 cons_pointer args, struct cons_pointer env) { struct cons_pointer lisp_cdr(struct stack_frame* frame, struct cons_pointer env) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
if ( consp( args)) { if ( consp( frame->arg[ 0])) {
struct cons_space_object cell = pointer2cell( args); struct cons_space_object cell = pointer2cell( frame->arg[ 0]);
result = pointer2cell( cell.payload.cons.cdr).payload.cons.car; 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 { } else {
lisp_throw( args); struct cons_pointer message =
c_string_to_lisp_string( "Attempt to take CAR/CDR of non sequence");
result = lisp_throw( message, frame);
} }
return result; return result;
} }
/**
* (assoc key store)
* Returns the value associated with key in store, or NIL if not found.
*/
struct cons_pointer lisp_assoc( struct stack_frame* frame, struct cons_pointer env) {
return c_assoc( frame->arg[ 0], frame->arg[ 1]);
}
/**
* (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. * TODO: make this do something sensible somehow.
*/ */
struct cons_pointer lisp_throw( struct cons_pointer args, struct cons_pointer env) { struct cons_pointer lisp_throw( struct cons_pointer message, struct stack_frame* frame) {
fprintf( stderr, "An exception was thrown and I've no idea what to do now\n"); fprintf( stderr, "\nERROR: ");
print( stderr, message);
fprintf( stderr, "\n\nAn exception was thrown and I've no idea what to do now\n");
return NIL; 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);

66
src/print.c
View file

@ -11,6 +11,9 @@
#include <ctype.h> #include <ctype.h>
#include <stdio.h> #include <stdio.h>
#include <string.h> #include <string.h>
/* wide characters */
#include <wchar.h>
#include <wctype.h>
#include "conspage.h" #include "conspage.h"
#include "consspaceobject.h" #include "consspaceobject.h"
@ -18,12 +21,12 @@
#include "print.h" #include "print.h"
void print_string_contents( FILE* output, struct cons_pointer pointer) { void print_string_contents( FILE* output, struct cons_pointer pointer) {
if ( check_tag( pointer, STRINGTAG)) { if ( stringp( pointer) || symbolp( pointer)) {
struct cons_space_object* cell = &pointer2cell(pointer); struct cons_space_object* cell = &pointer2cell(pointer);
char c = cell->payload.string.character; wint_t c = cell->payload.string.character;
if ( c != '\0') { if ( c != '\0') {
fputc( c, output); fputwc( c, output);
} }
print_string_contents( output, cell->payload.string.cdr); print_string_contents( output, cell->payload.string.cdr);
} }
@ -36,24 +39,34 @@ void print_string( FILE* output, struct cons_pointer pointer) {
fputc( '"', output); fputc( '"', output);
} }
/**
* 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);
void print_list_contents( FILE* output, struct cons_pointer pointer) { switch ( cell->tag.value) {
if ( check_tag( pointer, CONSTAG)) { case CONSTV :
struct cons_space_object* cell = &pointer2cell(pointer); if (initial_space) {
fputc( ' ', output);
}
print( output, cell->payload.cons.car); print( output, cell->payload.cons.car);
if ( !nilp( cell->payload.cons.cdr)) { print_list_contents( output, cell->payload.cons.cdr, true);
fputc( ' ', output); break;
} case NILTV:
print_list_contents( output, cell->payload.cons.cdr); break;
default:
fprintf( output, " . ");
print( output, pointer);
} }
} }
void print_list( FILE* output, struct cons_pointer pointer) { void print_list( FILE* output, struct cons_pointer pointer) {
fputc( '(', output); fputc( '(', output);
print_list_contents( output, pointer); print_list_contents( output, pointer, false);
fputc( ')', output); fputc( ')', output);
} }
@ -63,17 +76,28 @@ void print( FILE* output, struct cons_pointer pointer) {
/* Because tags have values as well as bytes, this if ... else if /* Because tags have values as well as bytes, this if ... else if
* statement can ultimately be replaced by a switch, which will * statement can ultimately be replaced by a switch, which will
* be neater. */ * be neater. */
if ( check_tag( pointer, CONSTAG)) { switch ( cell.tag.value) {
case CONSTV :
print_list( output, pointer); print_list( output, pointer);
} else if ( check_tag( pointer, INTEGERTAG)) { break;
case INTEGERTV :
fprintf( output, "%ld", cell.payload.integer.value); fprintf( output, "%ld", cell.payload.integer.value);
} else if ( check_tag( pointer, NILTAG)) { break;
fprintf( output, "NIL"); case NILTV :
} else if ( check_tag( pointer, REALTAG)) { fprintf( output, "nil");
fprintf( output, "%Lf", cell.payload.real.value); break;
} else if ( check_tag( pointer, STRINGTAG)) { case STRINGTV :
print_string( output, pointer); print_string( output, pointer);
} else if ( check_tag( pointer, TRUETAG)) { break;
fprintf( output, "T"); 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]);
} }
} }

131
src/read.c
View file

@ -8,12 +8,15 @@
* Licensed under GPL version 2.0, or, at your option, any later version. * Licensed under GPL version 2.0, or, at your option, any later version.
*/ */
#include <ctype.h>
#include <stdbool.h> #include <stdbool.h>
#include <stdio.h> #include <stdio.h>
/* wide characters */
#include <wchar.h>
#include <wctype.h>
#include "consspaceobject.h" #include "consspaceobject.h"
#include "integer.h" #include "integer.h"
#include "intern.h"
#include "read.h" #include "read.h"
/* for the time being things which may be read are: /* for the time being things which may be read are:
@ -22,45 +25,51 @@
lists lists
Can't read atoms because I don't yet know what an atom is or how it's stored. */ Can't read atoms because I don't yet know what an atom is or how it's stored. */
struct cons_pointer read_number( FILE* input, char initial); struct cons_pointer read_number( FILE* input, wint_t initial);
struct cons_pointer read_list( FILE* input, char initial); struct cons_pointer read_list( FILE* input, wint_t initial);
struct cons_pointer read_string( FILE* input, char 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, * 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 * treating this initial character as the first character of the object
* representation. * 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; 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) { switch( c) {
case '\'':
result = c_quote( read_continuation( input, fgetwc( input)));
break;
case '(' : case '(' :
case ')': result = read_list(input, fgetwc( input));
result = read_list(input, fgetc( input));
break; break;
case '"': result = read_string(input, fgetc( input)); case '"':
break; result = read_string(input, fgetwc( input));
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);
break; break;
default: default:
fprintf( stderr, "Unrecognised start of input character %c\n", c); 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; 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. * 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 accumulator = 0;
int places_of_decimals = 0; int places_of_decimals = 0;
bool seen_period = false; bool seen_period = false;
char c; wint_t c;
fprintf( stderr, "read_number starting '%c' (%d)\n", initial, initial); fprintf( stderr, "read_number starting '%c' (%d)\n", initial, initial);
for (c = initial; isdigit( c); c = fgetc( input)) { for (c = initial; iswdigit( c); c = fgetwc( input)) {
if ( c == '.') { if ( c == '.') {
seen_period = true; seen_period = true;
} else { } else {
@ -91,7 +100,7 @@ struct cons_pointer read_number( FILE* input, char initial) {
} }
/* push back the character read which was not a digit */ /* push back the character read which was not a digit */
fputc( c, input); ungetwc( c, input);
return make_integer( accumulator); 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 * Read a list from this input stream, which no longer contains the opening
* left parenthesis. * left parenthesis.
*/ */
struct cons_pointer read_list( FILE* input, char initial) { struct cons_pointer read_list( FILE* input, wint_t initial) {
struct cons_pointer cdr = NIL;
struct cons_pointer result= NIL; struct cons_pointer result= NIL;
fprintf( stderr, "read_list starting '%c' (%d)\n", initial, initial);
if ( initial != ')' ) { if ( initial != ')' ) {
fwprintf( stderr, L"read_list starting '%C' (%d)\n", initial, initial);
struct cons_pointer car = read_continuation( input, initial); struct cons_pointer car = read_continuation( input, initial);
cdr = read_list( input, fgetc( input)); result = make_cons( car, read_list( input, fgetwc( input)));
result = make_cons( car, cdr); } else {
fprintf( stderr, "End of list detected\n");
} }
return result; 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 * Read a string. This means either a string delimited by double quotes
* double quote. Note that there is (for now) a problem with the list * (is_quoted == true), in which case it may contain whitespace but may
* representation of a string, which is that there's no obvious representation of * not contain a double quote character (unless escaped), or one not
* an empty string. * 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 cdr = NIL;
struct cons_pointer result; 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) { switch ( initial) {
case '\0': case '\0':
@ -137,7 +147,43 @@ struct cons_pointer read_string( FILE* input, char initial) {
result = make_string( '\0', NIL); result = make_string( '\0', NIL);
break; break;
default: 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; break;
} }
@ -149,8 +195,9 @@ struct cons_pointer read_string( FILE* input, char initial) {
* Read the next object on this input stream and return a cons_pointer to it. * Read the next object on this input stream and return a cons_pointer to it.
*/ */
struct cons_pointer read( FILE* input) { struct cons_pointer read( FILE* input) {
return read_continuation( input, '\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 #!/bin/bash
expected='(1 2 3 ("Fred") NIL 77354)' expected='(1 2 3 ("Fred") nil 77354)'
actual=`echo '(1 2 3 ("Fred") () 77354 )' | target/psse 2> /dev/null` actual=`echo '(1 2 3 ("Fred") () 77354)' | target/psse 2> /dev/null`
if [ "${expected}" = "${actual}" ] if [ "${expected}" = "${actual}" ]
then then

2
unit-tests/nil.sh
View file

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