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

Sorted out some interesting buglets in read and print (although there is

Browse source 
still one I know of). More unit tests, and all pass. Not evalling yet.

Good day's work.
This commit is contained in:
Simon Brooke 2017-01-20 18:24:48 +00:00
parent 770767c11e
commit e968b30bbc
12 changed files with 325 additions and 106 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

43
src/consspaceobject.c
View file

@ -103,7 +103,6 @@ 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) {
struct cons_pointer pointer = NIL; struct cons_pointer pointer = NIL;
if ( ! ( nilp( car) && nilp( cdr))) {
pointer = allocate_cell( CONSTAG); pointer = allocate_cell( CONSTAG);
struct cons_space_object* cell = &conspages[pointer.page]->cell[pointer.offset]; struct cons_space_object* cell = &conspages[pointer.page]->cell[pointer.offset];
@ -112,7 +111,6 @@ struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer cdr)
inc_ref(cdr); inc_ref(cdr);
cell->payload.cons.car = car; cell->payload.cons.car = car;
cell->payload.cons.cdr = cdr; cell->payload.cons.cdr = cdr;
}
return pointer; return pointer;
} }
@ -138,11 +136,13 @@ struct cons_pointer make_function( struct cons_pointer src,
* has one character and a pointer to the next; in the last cell the * has one character and a pointer to the next; in the last cell the
* pointer to next is NIL. * pointer to next is NIL.
*/ */
struct cons_pointer make_string( wint_t c, struct cons_pointer tail) { struct cons_pointer make_string_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);
@ -150,12 +150,30 @@ struct cons_pointer make_string( wint_t c, struct cons_pointer tail) {
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. * Construct a cell which points to an executable Lisp special form.
*/ */
@ -185,3 +203,16 @@ struct cons_pointer c_string_to_lisp_string( char* string) {
return result; return result;
} }
/**
* Return a lisp symbol representation of this old skool ASCII string.
*/
struct cons_pointer c_string_to_lisp_symbol( char* symbol) {
struct cons_pointer result = NIL;
for ( int i = strlen( symbol); i > 0; i--) {
result = make_symbol( (wint_t)symbol[ i - 1], result);
}
return result;
}

80
src/consspaceobject.h
View file

@ -27,52 +27,78 @@
* 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
*/ */
/** /**
* An ordinary cons cell * An ordinary cons cell: 1397641027
*/ */
#define CONSTAG "CONS" #define CONSTAG "CONS"
#define CONSTV 1397641027
/** /**
* An unallocated cell on the free list - should never be encountered by a Lisp * An unallocated cell on the free list - should never be encountered by a Lisp
* function * function. 1162170950
*/ */
#define FREETAG "FREE" #define FREETAG "FREE"
#define FREETV 1162170950
/** /**
* An ordinary Lisp function - one whose arguments are pre-evaluated and passed as * An ordinary Lisp function - one whose arguments are pre-evaluated and passed as
* a stack frame. * a stack frame. 1129207110
*/ */
#define FUNCTIONTAG "FUNC" #define FUNCTIONTAG "FUNC"
#define FUNCTIONTV 1129207110
/** /**
* An integer number. * An integer number. 1381256777
*/ */
#define INTEGERTAG "INTR" #define INTEGERTAG "INTR"
#define INTEGERTV 1381256777
/** /**
* The special cons cell at address {0,0} whose car and cdr both point to itself. * The special cons cell at address {0,0} whose car and cdr both point to itself.
* 541870414
*/ */
#define NILTAG "NIL " #define NILTAG "NIL "
#define NILTV 541870414
/** /**
* An open read stream. * An open read stream.
*/ */
#define READTAG "READ" #define READTAG "READ"
/** /**
* A real number. * A real number.
*/ */
#define REALTAG "REAL" #define REALTAG "REAL"
/** /**
* A special form - one whose arguments are not pre-evaluated but passed as a * A special form - one whose arguments are not pre-evaluated but passed as a
* s-expression. * s-expression. 1296453715
*/ */
#define SPECIALTAG "SPFM" #define SPECIALTAG "SPFM"
#define SPECIALTV 1296453715
/** /**
* A string of characters, organised as a linked list. * A string of characters, organised as a linked list. 1196577875
*/ */
#define STRINGTAG "STRG" #define STRINGTAG "STRG"
#define STRINGTV 1196577875
/** /**
* The special cons cell at address {0,1} which is canonically different from NIL * 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 TRUETAG "TRUE"
#define TRUETV 1163219540
/** /**
* A pointer to an object in vector space. * A pointer to an object in vector space.
*/ */
#define VECTORPOINTTAG "VECP" #define VECTORPOINTTAG "VECP"
/** /**
* An open write stream. * An open write stream.
*/ */
@ -126,6 +152,11 @@
*/ */
#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
*/ */
@ -148,11 +179,10 @@
#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 * true if conspointer points to a write stream cell, else false.
*/ */
#define writep(conspoint) (check_tag(conspoint,WRITETAG)) #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).
@ -266,7 +296,9 @@ struct stream_payload {
/** /**
* payload of a string cell. At least at first, only one UTF character will * payload of a string cell. At least at first, only one UTF character will
* be stored in each cell. * 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 {
wint_t character; /* the actual character stored in this cell */ wint_t character; /* the actual character stored in this cell */
@ -315,7 +347,7 @@ struct stream_payload stream;
struct real_payload real; struct real_payload real;
/* if tag == SPECIALTAG */ /* if tag == SPECIALTAG */
struct special_payload special; struct special_payload special;
/* if tag == STRINGTAG */ /* 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;
@ -357,14 +389,6 @@ struct cons_pointer make_function( struct cons_pointer src,
struct cons_pointer (*executable) struct cons_pointer (*executable)
(struct stack_frame*, struct cons_pointer)); (struct stack_frame*, struct cons_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( wint_t c, struct cons_pointer tail);
/** /**
* Construct a cell which points to an executable Lisp special form. * Construct a cell which points to an executable Lisp special form.
*/ */
@ -374,9 +398,27 @@ struct cons_pointer make_special( struct cons_pointer src,
struct cons_pointer env, struct cons_pointer env,
struct stack_frame* frame)); struct stack_frame* frame));
/**
* Construct a string from this character and this tail. A string is
* 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. * Return a lisp string representation of this old skool ASCII string.
*/ */
struct cons_pointer c_string_to_lisp_string( char* string); struct cons_pointer c_string_to_lisp_string( char* string);
/**
* Return a lisp symbol representation of this old skool ASCII string.
*/
struct cons_pointer c_string_to_lisp_symbol( char* symbol);
#endif #endif

8
src/init.c
View file

@ -21,14 +21,14 @@
void bind_function( char* name, struct cons_pointer (*executable) void bind_function( char* name, struct cons_pointer (*executable)
(struct stack_frame*, struct cons_pointer)) { (struct stack_frame*, struct cons_pointer)) {
deep_bind( intern( c_string_to_lisp_string( name), oblist ), deep_bind( intern( c_string_to_lisp_symbol( name), oblist ),
make_function( NIL, executable)); make_function( NIL, executable));
} }
void bind_special( char* name, struct cons_pointer (*executable) void bind_special( char* name, struct cons_pointer (*executable)
(struct cons_pointer s_expr, struct cons_pointer env, (struct cons_pointer s_expr, struct cons_pointer env,
struct stack_frame* frame)) { struct stack_frame* frame)) {
deep_bind( intern( c_string_to_lisp_string( name), oblist ), deep_bind( intern( c_string_to_lisp_symbol( name), oblist ),
make_special( NIL, executable)); make_special( NIL, executable));
} }
@ -57,8 +57,10 @@ int main (int argc, char *argv[]) {
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);

84
src/lispops.c
View file

@ -22,6 +22,7 @@
#include <stdbool.h> #include <stdbool.h>
#include <stdio.h> #include <stdio.h>
#include <stdlib.h> #include <stdlib.h>
#include <string.h>
#include "consspaceobject.h" #include "consspaceobject.h"
#include "conspage.h" #include "conspage.h"
@ -88,6 +89,52 @@ struct cons_pointer lisp_apply( struct cons_pointer args, struct cons_pointer en
return result; 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) * (eval s_expr)
* *
@ -104,44 +151,33 @@ struct cons_pointer lisp_apply( struct cons_pointer args, struct cons_pointer en
struct cons_pointer lisp_eval( struct cons_pointer s_expr, struct cons_pointer env, struct cons_pointer lisp_eval( struct cons_pointer s_expr, struct cons_pointer env,
struct stack_frame* previous) { struct stack_frame* previous) {
struct cons_pointer result = s_expr; struct cons_pointer result = s_expr;
struct cons_space_object cell = pointer2cell( s_expr);
struct stack_frame* my_frame = struct stack_frame* my_frame =
make_stack_frame( previous, make_cons( s_expr, NIL), env); make_stack_frame( previous, make_cons( s_expr, NIL), env);
if ( consp( s_expr)) { switch ( cell.tag.value) {
/* the hard bit. Sort out what function is required and pass the case CONSTV :
* args to it. */ result = eval_cons( s_expr, env, my_frame);
struct cons_pointer fn_pointer = lisp_eval( c_car( s_expr), env, my_frame); break;
struct cons_pointer args = c_cdr( s_expr);
if ( specialp( fn_pointer)) { case SYMBOLTV :
struct cons_space_object special = pointer2cell( fn_pointer); {
result = (*special.payload.special.executable)( args, env, previous);
} else if ( functionp( fn_pointer)) {
/* 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);
} else if ( stringp( s_expr)) {
struct cons_pointer canonical = internedp( s_expr, env); struct cons_pointer canonical = internedp( s_expr, env);
if ( !nilp( canonical)) { if ( nilp( canonical)) {
result = c_assoc( canonical, env);
} else {
struct cons_pointer message = struct cons_pointer message =
c_string_to_lisp_string( "Attempt to value of unbound name."); c_string_to_lisp_string( "Attempt to take value of unbound symbol.");
result = lisp_throw( message, my_frame); result = lisp_throw( message, my_frame);
} else {
result = c_assoc( canonical, env);
} }
}
break;
/* the Clojure practice of having a map serve in the function /* 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; * 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 * also if the object is a consp it could be interpretable
* source code but in the long run I don't want an interpreter, * source code but in the long run I don't want an interpreter,
* and if I can get away without so much the better. */ * and if I can get away without so much the better. */
} }
}
free_stack_frame( my_frame); free_stack_frame( my_frame);

57
src/print.c
View file

@ -21,7 +21,7 @@
#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);
wint_t c = cell->payload.string.character; wint_t c = cell->payload.string.character;
@ -39,24 +39,34 @@ void print_string( FILE* output, struct cons_pointer pointer) {
fputc( '"', output); fputc( '"', output);
} }
/**
void print_list_contents( FILE* output, struct cons_pointer pointer) { * Print a single list cell (cons cell). TODO: does not handle dotted pairs.
if ( check_tag( pointer, CONSTAG)) { */
void print_list_contents( FILE* output, struct cons_pointer pointer,
bool initial_space) {
struct cons_space_object* cell = &pointer2cell(pointer); struct cons_space_object* cell = &pointer2cell(pointer);
print( output, cell->payload.cons.car); switch ( cell->tag.value) {
case CONSTV :
if ( !nilp( cell->payload.cons.cdr)) { if (initial_space) {
fputc( ' ', output); 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) { 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);
} }
@ -66,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]);
} }
} }

86
src/read.c
View file

@ -16,6 +16,7 @@
#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:
@ -27,7 +28,15 @@
struct cons_pointer read_number( FILE* input, wint_t initial); struct cons_pointer read_number( FILE* input, wint_t initial);
struct cons_pointer read_list( FILE* input, wint_t initial); struct cons_pointer read_list( FILE* input, wint_t initial);
struct cons_pointer read_string( FILE* input, wint_t initial); struct cons_pointer read_string( FILE* input, wint_t initial);
struct cons_pointer read_symbol( FILE* input, wint_t initial);
/**
* 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,
@ -39,21 +48,29 @@ struct cons_pointer read_continuation( FILE* input, wint_t initial) {
wint_t c; wint_t c;
for (c = initial; c == '\0' || iswblank( c); c = fgetwc( 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, fgetwc( input));
break; break;
case '"': result = read_string(input, fgetwc( input)); case '"':
result = read_string(input, fgetwc( input));
break; break;
default: default:
if ( iswdigit( c)) { if ( iswdigit( c)) {
result = read_number( input, c); result = read_number( input, c);
} } else if (iswprint( c)) {
result = read_symbol( input, c);
} else {
fprintf( stderr, "Unrecognised start of input character %c\n", c); fprintf( stderr, "Unrecognised start of input character %c\n", c);
} }
}
return result; return result;
} }
@ -83,7 +100,7 @@ struct cons_pointer read_number( FILE* input, wint_t initial) {
} }
/* push back the character read which was not a digit */ /* push back the character read which was not a digit */
fputwc( c, input); ungetwc( c, input);
return make_integer( accumulator); return make_integer( accumulator);
} }
@ -94,15 +111,14 @@ struct cons_pointer read_number( FILE* input, wint_t initial) {
* left parenthesis. * left parenthesis.
*/ */
struct cons_pointer read_list( FILE* input, wint_t initial) { struct cons_pointer read_list( FILE* input, wint_t initial) {
struct cons_pointer cdr = NIL;
struct cons_pointer result= NIL; struct cons_pointer result= NIL;
fwprintf( stderr, L"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, fgetwc( 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;
@ -110,16 +126,18 @@ struct cons_pointer read_list( FILE* input, wint_t 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, wint_t initial) { struct cons_pointer read_string( FILE* input, wint_t initial) {
struct cons_pointer cdr = NIL; struct cons_pointer cdr = NIL;
struct cons_pointer result; struct cons_pointer result;
fwprintf( stderr, L"read_string starting '%C' (%d)\n", initial, initial); fwprintf( stderr, L"read_string starting '%C' (%d)\n",
initial, initial);
switch ( initial) { switch ( initial) {
case '\0': case '\0':
@ -137,11 +155,47 @@ struct cons_pointer read_string( FILE* input, wint_t initial) {
} }
struct cons_pointer read_symbol( FILE* input, wint_t initial) {
struct cons_pointer cdr = NIL;
struct cons_pointer result;
fwprintf( stderr, L"read_symbol starting '%C' (%d)\n",
initial, initial);
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;
}
return result;
}
/** /**
* 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));
} }

11
src/stack.c
View file

@ -60,11 +60,14 @@ struct stack_frame* make_stack_frame( struct stack_frame* previous,
* arg except the first should be handed off to another processor to * arg except the first should be handed off to another processor to
* be evaled in parallel */ * be evaled in parallel */
result->arg[i] = lisp_eval( cell.payload.cons.car, env, result); result->arg[i] = lisp_eval( cell.payload.cons.car, env, result);
/* TODO: later, going to have to mess with reference counts */ inc_ref( result->arg[i]);
args = cell.payload.cons.cdr; args = cell.payload.cons.cdr;
} else { } else {
/* TODO: this isn't right. These args should also each be evaled. */ /* TODO: this isn't right. These args should also each be evaled. */
result->more = args; result->more = args;
inc_ref( result->more);
args = NIL; args = NIL;
} }
} }
@ -76,8 +79,12 @@ struct stack_frame* make_stack_frame( struct stack_frame* previous,
* Free this stack frame. * Free this stack frame.
*/ */
void free_stack_frame( struct stack_frame* frame) { void free_stack_frame( struct stack_frame* frame) {
/* TODO: later, mess with reference counts on locals */
/* TODO: later, push it back on the stack-frame freelist */ /* TODO: later, push it back on the stack-frame freelist */
for ( int i = 0; i < args_in_frame; i++) {
dec_ref( frame->arg[ i]);
}
dec_ref( frame->more);
free( frame); free( frame);
} }

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

@ -1,6 +1,6 @@
#!/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}" ]

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