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 pointer = NIL;
if ( ! ( nilp( car) && nilp( cdr))) {
pointer = allocate_cell( CONSTAG);
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);
cell->payload.cons.car = car;
cell->payload.cons.cdr = cdr;
}
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
* 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;
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);
@ -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.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.
*/
@ -185,3 +203,16 @@ struct cons_pointer c_string_to_lisp_string( char* string) {
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
*/
/**
* An ordinary cons cell
* 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
* function. 1162170950
*/
#define FREETAG "FREE"
#define FREETV 1162170950
/**
* An ordinary Lisp function - one whose arguments are pre-evaluated and passed as
* a stack frame.
* a stack frame. 1129207110
*/
#define FUNCTIONTAG "FUNC"
#define FUNCTIONTV 1129207110
/**
* An integer number.
* 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.
* s-expression. 1296453715
*/
#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 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 TRUETV 1163219540
/**
* A pointer to an object in vector space.
*/
#define VECTORPOINTTAG "VECP"
/**
* An open write stream.
*/
@ -126,6 +152,11 @@
*/
#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
*/
@ -148,11 +179,10 @@
#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))
/**
* true if conspointer points to a true cell, else false
* (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
* 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 {
wint_t character; /* the actual character stored in this cell */
@ -315,7 +347,7 @@ struct stream_payload stream;
struct real_payload real;
/* if tag == SPECIALTAG */
struct special_payload special;
/* if tag == STRINGTAG */
/* 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;
@ -357,14 +389,6 @@ struct cons_pointer make_function( struct cons_pointer src,
struct cons_pointer (*executable)
(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.
*/
@ -374,9 +398,27 @@ struct cons_pointer make_special( struct cons_pointer src,
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

8
src/init.c
View file

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

84
src/lispops.c
View file

@ -22,6 +22,7 @@
#include <stdbool.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include "consspaceobject.h"
#include "conspage.h"
@ -88,6 +89,52 @@ struct cons_pointer lisp_apply( struct cons_pointer args, struct cons_pointer en
return result;
}
struct cons_pointer eval_cons( struct cons_pointer s_expr, struct cons_pointer env,
struct stack_frame* my_frame) {
struct cons_pointer 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)
*
@ -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 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);
if ( consp( s_expr)) {
/* the hard bit. Sort out what function is required and pass the
* args to it. */
struct cons_pointer fn_pointer = lisp_eval( c_car( s_expr), env, my_frame);
struct cons_pointer args = c_cdr( s_expr);
switch ( cell.tag.value) {
case CONSTV :
result = eval_cons( s_expr, env, my_frame);
break;
if ( specialp( fn_pointer)) {
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)) {
case SYMBOLTV :
{
struct cons_pointer canonical = internedp( s_expr, env);
if ( !nilp( canonical)) {
result = c_assoc( canonical, env);
} else {
if ( nilp( canonical)) {
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);
} 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);

57
src/print.c
View file

@ -21,7 +21,7 @@
#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);
wint_t c = cell->payload.string.character;
@ -39,24 +39,34 @@ 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);
}
@ -66,17 +76,28 @@ void print( FILE* output, struct cons_pointer pointer) {
/* Because tags have values as well as bytes, this if ... else if
* statement can ultimately be replaced by a switch, which will
* be neater. */
if ( check_tag( pointer, CONSTAG)) {
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]);
}
}

86
src/read.c
View file

@ -16,6 +16,7 @@
#include "consspaceobject.h"
#include "integer.h"
#include "intern.h"
#include "read.h"
/* 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_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,
@ -39,21 +48,29 @@ struct cons_pointer read_continuation( FILE* input, wint_t initial) {
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) {
case '\'':
result = c_quote( read_continuation( input, fgetwc( input)));
break;
case '(' :
case ')':
result = read_list(input, fgetwc( input));
break;
case '"': result = read_string(input, fgetwc( input));
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;
}
@ -83,7 +100,7 @@ struct cons_pointer read_number( FILE* input, wint_t initial) {
}
/* push back the character read which was not a digit */
fputwc( c, input);
ungetwc( c, input);
return make_integer( accumulator);
}
@ -94,15 +111,14 @@ struct cons_pointer read_number( FILE* input, wint_t initial) {
* left parenthesis.
*/
struct cons_pointer read_list( FILE* input, wint_t initial) {
struct cons_pointer cdr = NIL;
struct cons_pointer result= NIL;
fwprintf( stderr, L"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, fgetwc( 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;
@ -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
* 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, wint_t initial) {
struct cons_pointer cdr = NIL;
struct cons_pointer result;
fwprintf( stderr, L"read_string starting '%C' (%d)\n", initial, initial);
fwprintf( stderr, L"read_string starting '%C' (%d)\n",
initial, initial);
switch ( initial) {
case '\0':
@ -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.
*/
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
* be evaled in parallel */
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;
} else {
/* TODO: this isn't right. These args should also each be evaled. */
result->more = args;
inc_ref( result->more);
args = NIL;
}
}
@ -76,8 +79,12 @@ struct stack_frame* make_stack_frame( struct stack_frame* previous,
* Free this stack 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 */
for ( int i = 0; i < args_in_frame; i++) {
dec_ref( frame->arg[ i]);
}
dec_ref( frame->more);
free( frame);
}

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

@ -1,6 +1,6 @@
#!/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`
if [ "${expected}" = "${actual}" ]

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