Merge branch 'exp1' into develop
This commit is contained in:
commit
00257ec076
6
Makefile
6
Makefile
|
@ -8,14 +8,14 @@ DEPS := $(OBJS:.o=.d)
|
||||||
|
|
||||||
INC_DIRS := $(shell find $(SRC_DIRS) -type d)
|
INC_DIRS := $(shell find $(SRC_DIRS) -type d)
|
||||||
INC_FLAGS := $(addprefix -I,$(INC_DIRS))
|
INC_FLAGS := $(addprefix -I,$(INC_DIRS))
|
||||||
INDENT_FLAGS := -kr -nut -l79 -ts2
|
INDENT_FLAGS := -kr -br -brf -brs -ce -cdw -npsl -nut -prs -l79 -ts2
|
||||||
|
|
||||||
VERSION := "0.0.0"
|
VERSION := "0.0.0"
|
||||||
|
|
||||||
CPPFLAGS ?= $(INC_FLAGS) -MMD -MP
|
CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g
|
||||||
LDFLAGS := -lm
|
LDFLAGS := -lm
|
||||||
|
|
||||||
$(TARGET): $(OBJS)
|
$(TARGET): $(OBJS) Makefile
|
||||||
$(CC) $(LDFLAGS) $(OBJS) -DVERSION=$(VERSION) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS)
|
$(CC) $(LDFLAGS) $(OBJS) -DVERSION=$(VERSION) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS)
|
||||||
|
|
||||||
format:
|
format:
|
||||||
|
|
|
@ -45,8 +45,7 @@ struct cons_page *conspages[NCONSPAGES];
|
||||||
* Initialise all cells and prepend each to the freelist; if pageno is zero, do not prepend
|
* Initialise all cells and prepend each to the freelist; if pageno is zero, do not prepend
|
||||||
* cells 0 and 1 to the freelist but initialise them as NIL and T respectively.
|
* cells 0 and 1 to the freelist but initialise them as NIL and T respectively.
|
||||||
*/
|
*/
|
||||||
void make_cons_page()
|
void make_cons_page( ) {
|
||||||
{
|
|
||||||
struct cons_page *result = malloc( sizeof( struct cons_page ) );
|
struct cons_page *result = malloc( sizeof( struct cons_page ) );
|
||||||
|
|
||||||
if ( result != NULL ) {
|
if ( result != NULL ) {
|
||||||
|
@ -102,8 +101,7 @@ void make_cons_page()
|
||||||
/**
|
/**
|
||||||
* dump the allocated pages to this output stream.
|
* dump the allocated pages to this output stream.
|
||||||
*/
|
*/
|
||||||
void dump_pages(FILE * output)
|
void dump_pages( FILE * output ) {
|
||||||
{
|
|
||||||
for ( int i = 0; i < initialised_cons_pages; i++ ) {
|
for ( int i = 0; i < initialised_cons_pages; i++ ) {
|
||||||
fprintf( output, "\nDUMPING PAGE %d\n", i );
|
fprintf( output, "\nDUMPING PAGE %d\n", i );
|
||||||
|
|
||||||
|
@ -120,8 +118,7 @@ void dump_pages(FILE * output)
|
||||||
*
|
*
|
||||||
* @pointer the cell to free
|
* @pointer the cell to free
|
||||||
*/
|
*/
|
||||||
void free_cell(struct cons_pointer pointer)
|
void free_cell( struct cons_pointer pointer ) {
|
||||||
{
|
|
||||||
struct cons_space_object *cell = &pointer2cell( pointer );
|
struct cons_space_object *cell = &pointer2cell( pointer );
|
||||||
|
|
||||||
if ( !check_tag( pointer, FREETAG ) ) {
|
if ( !check_tag( pointer, FREETAG ) ) {
|
||||||
|
@ -149,8 +146,7 @@ void free_cell(struct cons_pointer pointer)
|
||||||
* @param tag the tag of the cell to allocate - must be a valid cons space tag.
|
* @param tag the tag of the cell to allocate - must be a valid cons space tag.
|
||||||
* @return the cons pointer which refers to the cell allocated.
|
* @return the cons pointer which refers to the cell allocated.
|
||||||
*/
|
*/
|
||||||
struct cons_pointer allocate_cell(char *tag)
|
struct cons_pointer allocate_cell( char *tag ) {
|
||||||
{
|
|
||||||
struct cons_pointer result = freelist;
|
struct cons_pointer result = freelist;
|
||||||
|
|
||||||
if ( result.page == NIL.page && result.offset == NIL.offset ) {
|
if ( result.page == NIL.page && result.offset == NIL.offset ) {
|
||||||
|
@ -183,8 +179,7 @@ struct cons_pointer allocate_cell(char *tag)
|
||||||
/**
|
/**
|
||||||
* initialise the cons page system; to be called exactly once during startup.
|
* initialise the cons page system; to be called exactly once during startup.
|
||||||
*/
|
*/
|
||||||
void initialise_cons_pages()
|
void initialise_cons_pages( ) {
|
||||||
{
|
|
||||||
if ( conspageinitihasbeencalled == false ) {
|
if ( conspageinitihasbeencalled == false ) {
|
||||||
for ( int i = 0; i < NCONSPAGES; i++ ) {
|
for ( int i = 0; i < NCONSPAGES; i++ ) {
|
||||||
conspages[i] = ( struct cons_page * ) NULL;
|
conspages[i] = ( struct cons_page * ) NULL;
|
||||||
|
|
|
@ -23,8 +23,7 @@
|
||||||
/**
|
/**
|
||||||
* Check that the tag on the cell at this pointer is this tag
|
* Check that the tag on the cell at this pointer is this tag
|
||||||
*/
|
*/
|
||||||
int check_tag(struct cons_pointer pointer, char *tag)
|
int check_tag( struct cons_pointer pointer, char *tag ) {
|
||||||
{
|
|
||||||
struct cons_space_object cell = pointer2cell( pointer );
|
struct cons_space_object cell = pointer2cell( pointer );
|
||||||
return strncmp( &cell.tag.bytes[0], tag, TAGLENGTH ) == 0;
|
return strncmp( &cell.tag.bytes[0], tag, TAGLENGTH ) == 0;
|
||||||
}
|
}
|
||||||
|
@ -35,8 +34,7 @@ int check_tag(struct cons_pointer pointer, char *tag)
|
||||||
* You can't roll over the reference count. Once it hits the maximum
|
* You can't roll over the reference count. Once it hits the maximum
|
||||||
* value you cannot increment further.
|
* value you cannot increment further.
|
||||||
*/
|
*/
|
||||||
void inc_ref(struct cons_pointer pointer)
|
void inc_ref( struct cons_pointer pointer ) {
|
||||||
{
|
|
||||||
struct cons_space_object *cell = &pointer2cell( pointer );
|
struct cons_space_object *cell = &pointer2cell( pointer );
|
||||||
|
|
||||||
if ( cell->count < MAXREFERENCE ) {
|
if ( cell->count < MAXREFERENCE ) {
|
||||||
|
@ -50,8 +48,7 @@ void inc_ref(struct cons_pointer pointer)
|
||||||
* If a count has reached MAXREFERENCE it cannot be decremented.
|
* If a count has reached MAXREFERENCE it cannot be decremented.
|
||||||
* If a count is decremented to zero the cell should be freed.
|
* If a count is decremented to zero the cell should be freed.
|
||||||
*/
|
*/
|
||||||
void dec_ref(struct cons_pointer pointer)
|
void dec_ref( struct cons_pointer pointer ) {
|
||||||
{
|
|
||||||
struct cons_space_object *cell = &pointer2cell( pointer );
|
struct cons_space_object *cell = &pointer2cell( pointer );
|
||||||
|
|
||||||
if ( cell->count <= MAXREFERENCE ) {
|
if ( cell->count <= MAXREFERENCE ) {
|
||||||
|
@ -66,8 +63,7 @@ void dec_ref(struct cons_pointer pointer)
|
||||||
/**
|
/**
|
||||||
* dump the object at this cons_pointer to this output stream.
|
* dump the object at this cons_pointer to this output stream.
|
||||||
*/
|
*/
|
||||||
void dump_object(FILE * output, struct cons_pointer pointer)
|
void dump_object( FILE * output, struct cons_pointer pointer ) {
|
||||||
{
|
|
||||||
struct cons_space_object cell = pointer2cell( pointer );
|
struct cons_space_object cell = pointer2cell( pointer );
|
||||||
fwprintf( output,
|
fwprintf( output,
|
||||||
L"\tDumping %c%c%c%c (%d) at page %d, offset %d count %u\n",
|
L"\tDumping %c%c%c%c (%d) at page %d, offset %d count %u\n",
|
||||||
|
@ -85,7 +81,8 @@ void dump_object(FILE * output, struct cons_pointer pointer)
|
||||||
cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset );
|
cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset );
|
||||||
} else if ( check_tag( pointer, INTEGERTAG ) ) {
|
} else if ( check_tag( pointer, INTEGERTAG ) ) {
|
||||||
fwprintf( output,
|
fwprintf( output,
|
||||||
L"\t\tInteger cell: value %ld\n", cell.payload.integer.value);
|
L"\t\tInteger cell: value %ld\n",
|
||||||
|
cell.payload.integer.value );
|
||||||
} else if ( check_tag( pointer, FREETAG ) ) {
|
} else if ( check_tag( pointer, FREETAG ) ) {
|
||||||
fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n",
|
fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n",
|
||||||
cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset );
|
cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset );
|
||||||
|
@ -96,15 +93,16 @@ void dump_object(FILE * output, struct cons_pointer pointer)
|
||||||
fwprintf( output,
|
fwprintf( output,
|
||||||
L"String cell: character '%1c' (%1d) next at page %2d offset %3d\n",
|
L"String cell: character '%1c' (%1d) next at page %2d offset %3d\n",
|
||||||
cell.payload.string.character,
|
cell.payload.string.character,
|
||||||
cell.payload.string.cdr.page, cell.payload.string.cdr.offset);
|
cell.payload.string.cdr.page,
|
||||||
|
cell.payload.string.cdr.offset );
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
/**
|
/**
|
||||||
* 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 = NIL;
|
struct cons_pointer pointer = NIL;
|
||||||
|
|
||||||
pointer = allocate_cell( CONSTAG );
|
pointer = allocate_cell( CONSTAG );
|
||||||
|
@ -125,8 +123,7 @@ struct cons_pointer make_cons(struct cons_pointer car, struct cons_pointer cdr)
|
||||||
*/
|
*/
|
||||||
struct cons_pointer
|
struct cons_pointer
|
||||||
make_function( struct cons_pointer src, struct cons_pointer ( *executable )
|
make_function( struct cons_pointer src, struct cons_pointer ( *executable )
|
||||||
(struct stack_frame *, struct cons_pointer))
|
( struct stack_frame *, struct cons_pointer ) ) {
|
||||||
{
|
|
||||||
struct cons_pointer pointer = allocate_cell( FUNCTIONTAG );
|
struct cons_pointer pointer = allocate_cell( FUNCTIONTAG );
|
||||||
struct cons_space_object *cell = &pointer2cell( pointer );
|
struct cons_space_object *cell = &pointer2cell( pointer );
|
||||||
|
|
||||||
|
@ -143,8 +140,7 @@ make_function(struct cons_pointer src, struct cons_pointer (*executable)
|
||||||
* pointer to next is NIL.
|
* pointer to next is NIL.
|
||||||
*/
|
*/
|
||||||
struct cons_pointer
|
struct cons_pointer
|
||||||
make_string_like_thing(wint_t c, struct cons_pointer tail, char *tag)
|
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, tag ) || check_tag( tail, NILTAG ) ) {
|
if ( check_tag( tail, tag ) || check_tag( tail, NILTAG ) ) {
|
||||||
|
@ -170,16 +166,14 @@ make_string_like_thing(wint_t c, struct cons_pointer tail, char *tag)
|
||||||
* 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( wint_t c, struct cons_pointer tail ) {
|
||||||
{
|
|
||||||
return make_string_like_thing( c, tail, STRINGTAG );
|
return make_string_like_thing( c, tail, STRINGTAG );
|
||||||
}
|
}
|
||||||
|
|
||||||
/**
|
/**
|
||||||
* Construct a symbol from this character and this tail.
|
* Construct a symbol from this character and this tail.
|
||||||
*/
|
*/
|
||||||
struct cons_pointer make_symbol(wint_t c, struct cons_pointer tail)
|
struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) {
|
||||||
{
|
|
||||||
return make_string_like_thing( c, tail, SYMBOLTAG );
|
return make_string_like_thing( c, tail, SYMBOLTAG );
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -197,8 +191,7 @@ make_special(struct cons_pointer src, struct cons_pointer (*executable)
|
||||||
|
|
||||||
|
|
||||||
( struct cons_pointer s_expr,
|
( struct cons_pointer s_expr,
|
||||||
struct cons_pointer env, struct stack_frame * frame))
|
struct cons_pointer env, struct stack_frame * frame ) ) {
|
||||||
{
|
|
||||||
struct cons_pointer pointer = allocate_cell( SPECIALTAG );
|
struct cons_pointer pointer = allocate_cell( SPECIALTAG );
|
||||||
struct cons_space_object *cell = &pointer2cell( pointer );
|
struct cons_space_object *cell = &pointer2cell( pointer );
|
||||||
|
|
||||||
|
@ -211,8 +204,7 @@ make_special(struct cons_pointer src, struct cons_pointer (*executable)
|
||||||
/**
|
/**
|
||||||
* 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 ) {
|
||||||
{
|
|
||||||
struct cons_pointer result = NIL;
|
struct cons_pointer result = NIL;
|
||||||
|
|
||||||
for ( int i = strlen( string ); i > 0; i-- ) {
|
for ( int i = strlen( string ); i > 0; i-- ) {
|
||||||
|
@ -225,8 +217,7 @@ struct cons_pointer c_string_to_lisp_string(char *string)
|
||||||
/**
|
/**
|
||||||
* Return a lisp symbol representation of this old skool ASCII string.
|
* Return a lisp symbol representation of this old skool ASCII string.
|
||||||
*/
|
*/
|
||||||
struct cons_pointer c_string_to_lisp_symbol(char *symbol)
|
struct cons_pointer c_string_to_lisp_symbol( char *symbol ) {
|
||||||
{
|
|
||||||
struct cons_pointer result = NIL;
|
struct cons_pointer result = NIL;
|
||||||
|
|
||||||
for ( int i = strlen( symbol ); i > 0; i-- ) {
|
for ( int i = strlen( symbol ); i > 0; i-- ) {
|
||||||
|
|
12
src/equal.c
12
src/equal.c
|
@ -18,8 +18,7 @@
|
||||||
* Shallow, and thus cheap, equality: true if these two objects are
|
* Shallow, and thus cheap, equality: true if these two objects are
|
||||||
* the same object, else false.
|
* the same object, else false.
|
||||||
*/
|
*/
|
||||||
bool eq(struct cons_pointer a, struct cons_pointer b)
|
bool eq( struct cons_pointer a, struct cons_pointer b ) {
|
||||||
{
|
|
||||||
return ( ( a.page == b.page ) && ( a.offset == b.offset ) );
|
return ( ( a.page == b.page ) && ( a.offset == b.offset ) );
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -27,8 +26,7 @@ bool eq(struct cons_pointer a, struct cons_pointer b)
|
||||||
* Deep, and thus expensive, equality: true if these two objects have
|
* Deep, and thus expensive, equality: true if these two objects have
|
||||||
* identical structure, else false.
|
* identical structure, else false.
|
||||||
*/
|
*/
|
||||||
bool equal(struct cons_pointer a, struct cons_pointer b)
|
bool equal( struct cons_pointer a, struct cons_pointer b ) {
|
||||||
{
|
|
||||||
bool result = eq( a, b );
|
bool result = eq( a, b );
|
||||||
|
|
||||||
if ( !result ) {
|
if ( !result ) {
|
||||||
|
@ -36,7 +34,8 @@ bool equal(struct cons_pointer a, struct cons_pointer b)
|
||||||
struct cons_space_object *cell_b = &pointer2cell( b );
|
struct cons_space_object *cell_b = &pointer2cell( b );
|
||||||
|
|
||||||
if ( consp( a ) && consp( b ) ) {
|
if ( consp( a ) && consp( b ) ) {
|
||||||
result = equal(cell_a->payload.cons.car, cell_b->payload.cons.car)
|
result =
|
||||||
|
equal( cell_a->payload.cons.car, cell_b->payload.cons.car )
|
||||||
&& equal( cell_a->payload.cons.cdr, cell_b->payload.cons.cdr );
|
&& equal( cell_a->payload.cons.cdr, cell_b->payload.cons.cdr );
|
||||||
} else if ( stringp( a ) && stringp( b ) ) {
|
} else if ( stringp( a ) && stringp( b ) ) {
|
||||||
/*
|
/*
|
||||||
|
@ -52,7 +51,8 @@ bool equal(struct cons_pointer a, struct cons_pointer b)
|
||||||
} else if ( numberp( a ) && numberp( b ) ) {
|
} else if ( numberp( a ) && numberp( b ) ) {
|
||||||
double num_a = numeric_value( a );
|
double num_a = numeric_value( a );
|
||||||
double num_b = numeric_value( b );
|
double num_b = numeric_value( b );
|
||||||
double max = fabs(num_a) > fabs(num_b) ? fabs(num_a) : fabs(num_b);
|
double max =
|
||||||
|
fabs( num_a ) > fabs( num_b ) ? fabs( num_a ) : fabs( num_b );
|
||||||
|
|
||||||
/*
|
/*
|
||||||
* not more different than one part in a million - close enough
|
* not more different than one part in a million - close enough
|
||||||
|
|
12
src/init.c
12
src/init.c
|
@ -22,8 +22,7 @@
|
||||||
#include "repl.h"
|
#include "repl.h"
|
||||||
|
|
||||||
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_symbol( name ), oblist ),
|
deep_bind( intern( c_string_to_lisp_symbol( name ), oblist ),
|
||||||
make_function( NIL, executable ) );
|
make_function( NIL, executable ) );
|
||||||
}
|
}
|
||||||
|
@ -38,14 +37,12 @@ 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_symbol( name ), oblist ),
|
deep_bind( intern( c_string_to_lisp_symbol( name ), oblist ),
|
||||||
make_special( NIL, executable ) );
|
make_special( NIL, executable ) );
|
||||||
}
|
}
|
||||||
|
|
||||||
int main(int argc, char *argv[])
|
int main( int argc, char *argv[] ) {
|
||||||
{
|
|
||||||
/*
|
/*
|
||||||
* attempt to set wide character acceptance on all streams
|
* attempt to set wide character acceptance on all streams
|
||||||
*/
|
*/
|
||||||
|
@ -72,7 +69,8 @@ int main(int argc, char *argv[])
|
||||||
|
|
||||||
if ( show_prompt ) {
|
if ( show_prompt ) {
|
||||||
fprintf( stdout,
|
fprintf( stdout,
|
||||||
"Post scarcity software environment version %s\n\n", VERSION);
|
"Post scarcity software environment version %s\n\n",
|
||||||
|
VERSION );
|
||||||
}
|
}
|
||||||
|
|
||||||
initialise_cons_pages( );
|
initialise_cons_pages( );
|
||||||
|
|
|
@ -9,6 +9,7 @@
|
||||||
|
|
||||||
#define _GNU_SOURCE
|
#define _GNU_SOURCE
|
||||||
#include <math.h>
|
#include <math.h>
|
||||||
|
#include <stdio.h>
|
||||||
|
|
||||||
#include "conspage.h"
|
#include "conspage.h"
|
||||||
#include "consspaceobject.h"
|
#include "consspaceobject.h"
|
||||||
|
@ -19,13 +20,12 @@
|
||||||
* as a cons-space object. Cell may in principle be any kind of number,
|
* as a cons-space object. Cell may in principle be any kind of number,
|
||||||
* but only integers and reals are so far implemented.
|
* but only integers and reals are so far implemented.
|
||||||
*/
|
*/
|
||||||
double numeric_value(struct cons_pointer pointer)
|
double numeric_value( struct cons_pointer pointer ) {
|
||||||
{
|
|
||||||
double result = NAN;
|
double result = NAN;
|
||||||
struct cons_space_object *cell = &pointer2cell( pointer );
|
struct cons_space_object *cell = &pointer2cell( pointer );
|
||||||
|
|
||||||
if ( integerp( pointer ) ) {
|
if ( integerp( pointer ) ) {
|
||||||
result = (double) cell->payload.integer.value;
|
result = cell->payload.integer.value * 1.0;
|
||||||
} else if ( realp( pointer ) ) {
|
} else if ( realp( pointer ) ) {
|
||||||
result = cell->payload.real.value;
|
result = cell->payload.real.value;
|
||||||
}
|
}
|
||||||
|
@ -36,11 +36,12 @@ double numeric_value(struct cons_pointer pointer)
|
||||||
/**
|
/**
|
||||||
* Allocate an integer cell representing this value and return a cons pointer to it.
|
* Allocate an integer cell representing this value and return a cons pointer to it.
|
||||||
*/
|
*/
|
||||||
struct cons_pointer make_integer(int value)
|
struct cons_pointer make_integer( long int value ) {
|
||||||
{
|
|
||||||
struct cons_pointer result = allocate_cell( INTEGERTAG );
|
struct cons_pointer result = allocate_cell( INTEGERTAG );
|
||||||
struct cons_space_object *cell = &pointer2cell( result );
|
struct cons_space_object *cell = &pointer2cell( result );
|
||||||
cell->payload.integer.value = value;
|
cell->payload.integer.value = value;
|
||||||
|
|
||||||
|
dump_object( stderr, result);
|
||||||
|
|
||||||
return result;
|
return result;
|
||||||
}
|
}
|
||||||
|
|
|
@ -16,6 +16,6 @@ double numeric_value(struct cons_pointer pointer);
|
||||||
/**
|
/**
|
||||||
* Allocate an integer cell representing this value and return a cons pointer to it.
|
* Allocate an integer cell representing this value and return a cons pointer to it.
|
||||||
*/
|
*/
|
||||||
struct cons_pointer make_integer(int value);
|
struct cons_pointer make_integer( long int value );
|
||||||
|
|
||||||
#endif
|
#endif
|
||||||
|
|
16
src/intern.c
16
src/intern.c
|
@ -44,8 +44,7 @@ struct cons_pointer oblist = NIL;
|
||||||
* will work); otherwise return NIL.
|
* will work); otherwise return NIL.
|
||||||
*/
|
*/
|
||||||
struct cons_pointer
|
struct cons_pointer
|
||||||
internedp(struct cons_pointer key, struct cons_pointer store)
|
internedp( struct cons_pointer key, struct cons_pointer store ) {
|
||||||
{
|
|
||||||
struct cons_pointer result = NIL;
|
struct cons_pointer result = NIL;
|
||||||
|
|
||||||
for ( struct cons_pointer next = store;
|
for ( struct cons_pointer next = store;
|
||||||
|
@ -70,8 +69,8 @@ internedp(struct cons_pointer key, struct cons_pointer store)
|
||||||
* If this key is lexically identical to a key in this store, return the value
|
* If this key is lexically identical to a key in this store, return the value
|
||||||
* of that key from the store; otherwise return NIL.
|
* of that key from the store; otherwise return NIL.
|
||||||
*/
|
*/
|
||||||
struct cons_pointer c_assoc(struct cons_pointer key, struct cons_pointer store)
|
struct cons_pointer c_assoc( struct cons_pointer key,
|
||||||
{
|
struct cons_pointer store ) {
|
||||||
struct cons_pointer result = NIL;
|
struct cons_pointer result = NIL;
|
||||||
|
|
||||||
for ( struct cons_pointer next = store;
|
for ( struct cons_pointer next = store;
|
||||||
|
@ -94,8 +93,7 @@ struct cons_pointer c_assoc(struct cons_pointer key, struct cons_pointer store)
|
||||||
*/
|
*/
|
||||||
struct cons_pointer
|
struct cons_pointer
|
||||||
bind( struct cons_pointer key, struct cons_pointer value,
|
bind( struct cons_pointer key, struct cons_pointer value,
|
||||||
struct cons_pointer store)
|
struct cons_pointer store ) {
|
||||||
{
|
|
||||||
return make_cons( make_cons( key, value ), store );
|
return make_cons( make_cons( key, value ), store );
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -105,8 +103,7 @@ bind(struct cons_pointer key, struct cons_pointer value,
|
||||||
* there it may not be especially useful).
|
* there it may not be especially useful).
|
||||||
*/
|
*/
|
||||||
struct cons_pointer
|
struct cons_pointer
|
||||||
deep_bind(struct cons_pointer key, struct cons_pointer value)
|
deep_bind( struct cons_pointer key, struct cons_pointer value ) {
|
||||||
{
|
|
||||||
oblist = bind( key, value, oblist );
|
oblist = bind( key, value, oblist );
|
||||||
return oblist;
|
return oblist;
|
||||||
}
|
}
|
||||||
|
@ -117,8 +114,7 @@ deep_bind(struct cons_pointer key, struct cons_pointer value)
|
||||||
* with the value NIL.
|
* with the value NIL.
|
||||||
*/
|
*/
|
||||||
struct cons_pointer
|
struct cons_pointer
|
||||||
intern(struct cons_pointer key, struct cons_pointer environment)
|
intern( struct cons_pointer key, struct cons_pointer environment ) {
|
||||||
{
|
|
||||||
struct cons_pointer result = environment;
|
struct cons_pointer result = environment;
|
||||||
struct cons_pointer canonical = internedp( key, environment );
|
struct cons_pointer canonical = internedp( key, environment );
|
||||||
|
|
||||||
|
|
|
@ -42,7 +42,8 @@ struct cons_pointer internedp(struct cons_pointer key,
|
||||||
* with this key/value pair added to the front.
|
* with this key/value pair added to the front.
|
||||||
*/
|
*/
|
||||||
struct cons_pointer bind( struct cons_pointer key,
|
struct cons_pointer bind( struct cons_pointer key,
|
||||||
struct cons_pointer value, struct cons_pointer store);
|
struct cons_pointer value,
|
||||||
|
struct cons_pointer store );
|
||||||
|
|
||||||
/**
|
/**
|
||||||
* Binds this key to this value in the global oblist, but doesn't affect the
|
* Binds this key to this value in the global oblist, but doesn't affect the
|
||||||
|
|
|
@ -49,8 +49,7 @@
|
||||||
/**
|
/**
|
||||||
* Implementation of car in C. If arg is not a cons, does not error but returns nil.
|
* Implementation of car in C. If arg is not a cons, does not error but returns nil.
|
||||||
*/
|
*/
|
||||||
struct cons_pointer c_car(struct cons_pointer arg)
|
struct cons_pointer c_car( struct cons_pointer arg ) {
|
||||||
{
|
|
||||||
struct cons_pointer result = NIL;
|
struct cons_pointer result = NIL;
|
||||||
|
|
||||||
if ( consp( arg ) ) {
|
if ( consp( arg ) ) {
|
||||||
|
@ -63,8 +62,7 @@ struct cons_pointer c_car(struct cons_pointer arg)
|
||||||
/**
|
/**
|
||||||
* Implementation of cdr in C. If arg is not a cons, does not error but returns nil.
|
* Implementation of cdr in C. If arg is not a cons, does not error but returns nil.
|
||||||
*/
|
*/
|
||||||
struct cons_pointer c_cdr(struct cons_pointer arg)
|
struct cons_pointer c_cdr( struct cons_pointer arg ) {
|
||||||
{
|
|
||||||
struct cons_pointer result = NIL;
|
struct cons_pointer result = NIL;
|
||||||
|
|
||||||
if ( consp( arg ) ) {
|
if ( consp( arg ) ) {
|
||||||
|
@ -82,8 +80,7 @@ struct cons_pointer c_cdr(struct cons_pointer arg)
|
||||||
*/
|
*/
|
||||||
struct cons_pointer
|
struct cons_pointer
|
||||||
lisp_apply( struct cons_pointer args, struct cons_pointer env,
|
lisp_apply( struct cons_pointer args, struct cons_pointer env,
|
||||||
struct stack_frame *frame)
|
struct stack_frame *frame ) {
|
||||||
{
|
|
||||||
struct cons_pointer result = args;
|
struct cons_pointer result = args;
|
||||||
|
|
||||||
if ( consp( args ) ) {
|
if ( consp( args ) ) {
|
||||||
|
@ -95,10 +92,10 @@ lisp_apply(struct cons_pointer args, struct cons_pointer env,
|
||||||
|
|
||||||
struct cons_pointer
|
struct cons_pointer
|
||||||
eval_cons( struct cons_pointer s_expr, struct cons_pointer env,
|
eval_cons( struct cons_pointer s_expr, struct cons_pointer env,
|
||||||
struct stack_frame *my_frame)
|
struct stack_frame *my_frame ) {
|
||||||
{
|
|
||||||
struct cons_pointer result = NIL;
|
struct cons_pointer result = NIL;
|
||||||
struct cons_pointer fn_pointer = lisp_eval(c_car(s_expr), env, my_frame);
|
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_space_object fn_cell = pointer2cell( fn_pointer );
|
||||||
struct cons_pointer args = c_cdr( s_expr );
|
struct cons_pointer args = c_cdr( s_expr );
|
||||||
|
|
||||||
|
@ -107,7 +104,8 @@ eval_cons(struct cons_pointer s_expr, struct cons_pointer env,
|
||||||
{
|
{
|
||||||
struct cons_space_object special = pointer2cell( fn_pointer );
|
struct cons_space_object special = pointer2cell( fn_pointer );
|
||||||
result =
|
result =
|
||||||
(*special.payload.special.executable) (args, env, my_frame);
|
( *special.payload.special.executable ) ( args, env,
|
||||||
|
my_frame );
|
||||||
}
|
}
|
||||||
break;
|
break;
|
||||||
|
|
||||||
|
@ -117,7 +115,8 @@ eval_cons(struct cons_pointer s_expr, struct cons_pointer env,
|
||||||
*/
|
*/
|
||||||
{
|
{
|
||||||
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);
|
struct stack_frame *frame =
|
||||||
|
make_stack_frame( my_frame, args, env );
|
||||||
|
|
||||||
/*
|
/*
|
||||||
* the trick: pass the remaining arguments and environment to the
|
* the trick: pass the remaining arguments and environment to the
|
||||||
|
@ -161,16 +160,19 @@ eval_cons(struct cons_pointer s_expr, struct cons_pointer env,
|
||||||
*/
|
*/
|
||||||
struct cons_pointer
|
struct cons_pointer
|
||||||
lisp_eval( struct cons_pointer s_expr, struct cons_pointer env,
|
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 cons_space_object cell = pointer2cell( s_expr );
|
||||||
struct stack_frame *my_frame =
|
|
||||||
make_stack_frame(previous, make_cons(s_expr, NIL), env);
|
fprintf( stderr, "In eval; about to make stack frame" );
|
||||||
|
|
||||||
|
struct stack_frame *frame = make_stack_frame( previous, s_expr, env );
|
||||||
|
|
||||||
|
fprintf( stderr, "In eval; stack frame made" );
|
||||||
|
|
||||||
switch ( cell.tag.value ) {
|
switch ( cell.tag.value ) {
|
||||||
case CONSTV:
|
case CONSTV:
|
||||||
result = eval_cons(s_expr, env, my_frame);
|
result = eval_cons( s_expr, env, frame );
|
||||||
break;
|
break;
|
||||||
|
|
||||||
case SYMBOLTV:
|
case SYMBOLTV:
|
||||||
|
@ -180,7 +182,7 @@ lisp_eval(struct cons_pointer s_expr, struct cons_pointer env,
|
||||||
struct cons_pointer message =
|
struct cons_pointer message =
|
||||||
c_string_to_lisp_string
|
c_string_to_lisp_string
|
||||||
( "Attempt to take value of unbound symbol." );
|
( "Attempt to take value of unbound symbol." );
|
||||||
result = lisp_throw(message, my_frame);
|
result = lisp_throw( message, frame );
|
||||||
} else {
|
} else {
|
||||||
result = c_assoc( canonical, env );
|
result = c_assoc( canonical, env );
|
||||||
}
|
}
|
||||||
|
@ -195,7 +197,7 @@ lisp_eval(struct cons_pointer s_expr, struct cons_pointer env,
|
||||||
*/
|
*/
|
||||||
}
|
}
|
||||||
|
|
||||||
free_stack_frame(my_frame);
|
free_stack_frame( frame );
|
||||||
|
|
||||||
return result;
|
return result;
|
||||||
}
|
}
|
||||||
|
@ -209,8 +211,7 @@ lisp_eval(struct cons_pointer s_expr, struct cons_pointer env,
|
||||||
*/
|
*/
|
||||||
struct cons_pointer
|
struct cons_pointer
|
||||||
lisp_quote( struct cons_pointer args, struct cons_pointer env,
|
lisp_quote( struct cons_pointer args, struct cons_pointer env,
|
||||||
struct stack_frame *frame)
|
struct stack_frame *frame ) {
|
||||||
{
|
|
||||||
return c_car( args );
|
return c_car( args );
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -223,8 +224,7 @@ lisp_quote(struct cons_pointer args, struct cons_pointer env,
|
||||||
* otherwise returns a new cons cell.
|
* otherwise returns a new cons cell.
|
||||||
*/
|
*/
|
||||||
struct cons_pointer
|
struct cons_pointer
|
||||||
lisp_cons(struct stack_frame *frame, struct cons_pointer env)
|
lisp_cons( struct stack_frame *frame, struct cons_pointer env ) {
|
||||||
{
|
|
||||||
struct cons_pointer car = frame->arg[0];
|
struct cons_pointer car = frame->arg[0];
|
||||||
struct cons_pointer cdr = frame->arg[1];
|
struct cons_pointer cdr = frame->arg[1];
|
||||||
struct cons_pointer result;
|
struct cons_pointer result;
|
||||||
|
@ -233,7 +233,8 @@ lisp_cons(struct stack_frame *frame, struct cons_pointer env)
|
||||||
return NIL;
|
return NIL;
|
||||||
} else if ( stringp( car ) && stringp( cdr ) &&
|
} else if ( stringp( car ) && stringp( cdr ) &&
|
||||||
nilp( pointer2cell( car ).payload.string.cdr ) ) {
|
nilp( pointer2cell( car ).payload.string.cdr ) ) {
|
||||||
result = make_string(pointer2cell(car).payload.string.character, cdr);
|
result =
|
||||||
|
make_string( pointer2cell( car ).payload.string.character, cdr );
|
||||||
} else {
|
} else {
|
||||||
result = make_cons( car, cdr );
|
result = make_cons( car, cdr );
|
||||||
}
|
}
|
||||||
|
@ -247,8 +248,7 @@ lisp_cons(struct stack_frame *frame, struct cons_pointer env)
|
||||||
* strings, and TODO read streams and other things which can be considered as sequences.
|
* strings, and TODO read streams and other things which can be considered as sequences.
|
||||||
*/
|
*/
|
||||||
struct cons_pointer
|
struct cons_pointer
|
||||||
lisp_car(struct stack_frame *frame, struct cons_pointer env)
|
lisp_car( struct stack_frame *frame, struct cons_pointer env ) {
|
||||||
{
|
|
||||||
struct cons_pointer result = NIL;
|
struct cons_pointer result = NIL;
|
||||||
|
|
||||||
if ( consp( frame->arg[0] ) ) {
|
if ( consp( frame->arg[0] ) ) {
|
||||||
|
@ -259,7 +259,8 @@ lisp_car(struct stack_frame *frame, struct cons_pointer env)
|
||||||
result = make_string( cell.payload.string.character, NIL );
|
result = make_string( cell.payload.string.character, NIL );
|
||||||
} else {
|
} else {
|
||||||
struct cons_pointer message =
|
struct cons_pointer message =
|
||||||
c_string_to_lisp_string("Attempt to take CAR/CDR of non sequence");
|
c_string_to_lisp_string
|
||||||
|
( "Attempt to take CAR/CDR of non sequence" );
|
||||||
result = lisp_throw( message, frame );
|
result = lisp_throw( message, frame );
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -272,8 +273,7 @@ lisp_car(struct stack_frame *frame, struct cons_pointer env)
|
||||||
* strings, and TODO read streams and other things which can be considered as sequences.
|
* strings, and TODO read streams and other things which can be considered as sequences.
|
||||||
*/
|
*/
|
||||||
struct cons_pointer
|
struct cons_pointer
|
||||||
lisp_cdr(struct stack_frame *frame, struct cons_pointer env)
|
lisp_cdr( struct stack_frame *frame, struct cons_pointer env ) {
|
||||||
{
|
|
||||||
struct cons_pointer result = NIL;
|
struct cons_pointer result = NIL;
|
||||||
|
|
||||||
if ( consp( frame->arg[0] ) ) {
|
if ( consp( frame->arg[0] ) ) {
|
||||||
|
@ -284,7 +284,8 @@ lisp_cdr(struct stack_frame *frame, struct cons_pointer env)
|
||||||
result = cell.payload.string.cdr;
|
result = cell.payload.string.cdr;
|
||||||
} else {
|
} else {
|
||||||
struct cons_pointer message =
|
struct cons_pointer message =
|
||||||
c_string_to_lisp_string("Attempt to take CAR/CDR of non sequence");
|
c_string_to_lisp_string
|
||||||
|
( "Attempt to take CAR/CDR of non sequence" );
|
||||||
result = lisp_throw( message, frame );
|
result = lisp_throw( message, frame );
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -296,8 +297,7 @@ lisp_cdr(struct stack_frame *frame, struct cons_pointer env)
|
||||||
* Returns the value associated with key in store, or NIL if not found.
|
* Returns the value associated with key in store, or NIL if not found.
|
||||||
*/
|
*/
|
||||||
struct cons_pointer
|
struct cons_pointer
|
||||||
lisp_assoc(struct stack_frame *frame, struct cons_pointer env)
|
lisp_assoc( struct stack_frame *frame, struct cons_pointer env ) {
|
||||||
{
|
|
||||||
return c_assoc( frame->arg[0], frame->arg[1] );
|
return c_assoc( frame->arg[0], frame->arg[1] );
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -305,8 +305,8 @@ lisp_assoc(struct stack_frame *frame, struct cons_pointer env)
|
||||||
* (eq a b)
|
* (eq a b)
|
||||||
* Returns T if a and b are pointers to the same object, else NIL
|
* Returns T if a and b are pointers to the same object, else NIL
|
||||||
*/
|
*/
|
||||||
struct cons_pointer lisp_eq(struct stack_frame *frame, struct cons_pointer env)
|
struct cons_pointer lisp_eq( struct stack_frame *frame,
|
||||||
{
|
struct cons_pointer env ) {
|
||||||
return eq( frame->arg[0], frame->arg[1] ) ? TRUE : NIL;
|
return eq( frame->arg[0], frame->arg[1] ) ? TRUE : NIL;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -315,8 +315,7 @@ struct cons_pointer lisp_eq(struct stack_frame *frame, struct cons_pointer env)
|
||||||
* Returns T if a and b are pointers to structurally identical objects, else NIL
|
* Returns T if a and b are pointers to structurally identical objects, else NIL
|
||||||
*/
|
*/
|
||||||
struct cons_pointer
|
struct cons_pointer
|
||||||
lisp_equal(struct stack_frame *frame, struct cons_pointer env)
|
lisp_equal( struct stack_frame *frame, struct cons_pointer env ) {
|
||||||
{
|
|
||||||
return equal( frame->arg[0], frame->arg[1] ) ? TRUE : NIL;
|
return equal( frame->arg[0], frame->arg[1] ) ? TRUE : NIL;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -327,8 +326,7 @@ lisp_equal(struct stack_frame *frame, struct cons_pointer env)
|
||||||
* is a read stream, then read from that stream, else stdin.
|
* is a read stream, then read from that stream, else stdin.
|
||||||
*/
|
*/
|
||||||
struct cons_pointer
|
struct cons_pointer
|
||||||
lisp_read(struct stack_frame *frame, struct cons_pointer env)
|
lisp_read( struct stack_frame *frame, struct cons_pointer env ) {
|
||||||
{
|
|
||||||
FILE *input = stdin;
|
FILE *input = stdin;
|
||||||
|
|
||||||
if ( readp( frame->arg[0] ) ) {
|
if ( readp( frame->arg[0] ) ) {
|
||||||
|
@ -345,8 +343,7 @@ lisp_read(struct stack_frame *frame, struct cons_pointer env)
|
||||||
* is a write stream, then print to that stream, else stdout.
|
* is a write stream, then print to that stream, else stdout.
|
||||||
*/
|
*/
|
||||||
struct cons_pointer
|
struct cons_pointer
|
||||||
lisp_print(struct stack_frame *frame, struct cons_pointer env)
|
lisp_print( struct stack_frame *frame, struct cons_pointer env ) {
|
||||||
{
|
|
||||||
FILE *output = stdout;
|
FILE *output = stdout;
|
||||||
|
|
||||||
if ( writep( frame->arg[1] ) ) {
|
if ( writep( frame->arg[1] ) ) {
|
||||||
|
@ -362,8 +359,7 @@ lisp_print(struct stack_frame *frame, struct cons_pointer env)
|
||||||
* TODO: make this do something sensible somehow.
|
* TODO: make this do something sensible somehow.
|
||||||
*/
|
*/
|
||||||
struct cons_pointer
|
struct cons_pointer
|
||||||
lisp_throw(struct cons_pointer message, struct stack_frame *frame)
|
lisp_throw( struct cons_pointer message, struct stack_frame *frame ) {
|
||||||
{
|
|
||||||
fprintf( stderr, "\nERROR: " );
|
fprintf( stderr, "\nERROR: " );
|
||||||
print( stderr, message );
|
print( stderr, message );
|
||||||
fprintf( stderr,
|
fprintf( stderr,
|
||||||
|
|
15
src/print.c
15
src/print.c
|
@ -22,8 +22,7 @@
|
||||||
#include "integer.h"
|
#include "integer.h"
|
||||||
#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 ( stringp( pointer ) || symbolp( pointer ) ) {
|
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;
|
||||||
|
@ -35,8 +34,7 @@ void print_string_contents(FILE * output, struct cons_pointer pointer)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
void print_string(FILE * output, struct cons_pointer pointer)
|
void print_string( FILE * output, struct cons_pointer pointer ) {
|
||||||
{
|
|
||||||
fputwc( btowc( '"' ), output );
|
fputwc( btowc( '"' ), output );
|
||||||
print_string_contents( output, pointer );
|
print_string_contents( output, pointer );
|
||||||
fputwc( btowc( '"' ), output );
|
fputwc( btowc( '"' ), output );
|
||||||
|
@ -47,8 +45,7 @@ void print_string(FILE * output, struct cons_pointer pointer)
|
||||||
*/
|
*/
|
||||||
void
|
void
|
||||||
print_list_contents( FILE * output, struct cons_pointer pointer,
|
print_list_contents( FILE * output, struct cons_pointer pointer,
|
||||||
bool initial_space)
|
bool initial_space ) {
|
||||||
{
|
|
||||||
struct cons_space_object *cell = &pointer2cell( pointer );
|
struct cons_space_object *cell = &pointer2cell( pointer );
|
||||||
|
|
||||||
switch ( cell->tag.value ) {
|
switch ( cell->tag.value ) {
|
||||||
|
@ -68,15 +65,13 @@ print_list_contents(FILE * output, struct cons_pointer pointer,
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
void print_list(FILE * output, struct cons_pointer pointer)
|
void print_list( FILE * output, struct cons_pointer pointer ) {
|
||||||
{
|
|
||||||
fputwc( btowc( '(' ), output );
|
fputwc( btowc( '(' ), output );
|
||||||
print_list_contents( output, pointer, false );
|
print_list_contents( output, pointer, false );
|
||||||
fputwc( btowc( ')' ), output );
|
fputwc( btowc( ')' ), output );
|
||||||
}
|
}
|
||||||
|
|
||||||
void print(FILE * output, struct cons_pointer pointer)
|
void print( FILE * output, struct cons_pointer pointer ) {
|
||||||
{
|
|
||||||
struct cons_space_object cell = pointer2cell( pointer );
|
struct cons_space_object cell = pointer2cell( pointer );
|
||||||
|
|
||||||
/*
|
/*
|
||||||
|
|
37
src/read.c
37
src/read.c
|
@ -37,9 +37,9 @@ struct cons_pointer read_symbol(FILE * input, wint_t initial);
|
||||||
/**
|
/**
|
||||||
* quote reader macro in C (!)
|
* quote reader macro in C (!)
|
||||||
*/
|
*/
|
||||||
struct cons_pointer c_quote(struct cons_pointer arg)
|
struct cons_pointer c_quote( struct cons_pointer arg ) {
|
||||||
{
|
return make_cons( c_string_to_lisp_symbol( "quote" ),
|
||||||
return make_cons(c_string_to_lisp_symbol("quote"), make_cons(arg, NIL));
|
make_cons( arg, NIL ) );
|
||||||
}
|
}
|
||||||
|
|
||||||
/**
|
/**
|
||||||
|
@ -47,8 +47,7 @@ struct cons_pointer c_quote(struct cons_pointer arg)
|
||||||
* 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, wint_t initial)
|
struct cons_pointer read_continuation( FILE * input, wint_t initial ) {
|
||||||
{
|
|
||||||
struct cons_pointer result = NIL;
|
struct cons_pointer result = NIL;
|
||||||
|
|
||||||
wint_t c;
|
wint_t c;
|
||||||
|
@ -82,21 +81,23 @@ struct cons_pointer read_continuation(FILE * input, wint_t 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, wint_t initial)
|
struct cons_pointer read_number( FILE * input, wint_t initial ) {
|
||||||
{
|
long int accumulator = 0;
|
||||||
int accumulator = 0;
|
|
||||||
int places_of_decimals = 0;
|
int places_of_decimals = 0;
|
||||||
bool seen_period = false;
|
bool seen_period = false;
|
||||||
wint_t 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; iswdigit(c) || c == btowc('.'); c = fgetwc(input)) {
|
for ( c = initial; iswdigit( c ) || c == btowc( '.' );
|
||||||
|
c = fgetwc( input ) ) {
|
||||||
if ( c == btowc( '.' ) ) {
|
if ( c == btowc( '.' ) ) {
|
||||||
seen_period = true;
|
seen_period = true;
|
||||||
} else {
|
} else {
|
||||||
accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' );
|
accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' );
|
||||||
|
|
||||||
|
fprintf( stderr, "Added character %c, accumulator now %ld\n", c, accumulator);
|
||||||
|
|
||||||
if ( seen_period ) {
|
if ( seen_period ) {
|
||||||
places_of_decimals++;
|
places_of_decimals++;
|
||||||
}
|
}
|
||||||
|
@ -119,12 +120,12 @@ struct cons_pointer read_number(FILE * input, wint_t 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, wint_t initial)
|
struct cons_pointer read_list( FILE * input, wint_t initial ) {
|
||||||
{
|
|
||||||
struct cons_pointer result = NIL;
|
struct cons_pointer result = NIL;
|
||||||
|
|
||||||
if ( initial != ')' ) {
|
if ( initial != ')' ) {
|
||||||
fwprintf(stderr, L"read_list starting '%C' (%d)\n", initial, 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 );
|
||||||
result = make_cons( car, read_list( input, fgetwc( input ) ) );
|
result = make_cons( car, read_list( input, fgetwc( input ) ) );
|
||||||
} else {
|
} else {
|
||||||
|
@ -141,8 +142,7 @@ struct cons_pointer read_list(FILE * input, wint_t initial)
|
||||||
* so delimited in which case it may not contain whitespace (unless escaped)
|
* so delimited in which case it may not contain whitespace (unless escaped)
|
||||||
* but may contain a double quote character (probably not a good idea!)
|
* 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;
|
||||||
|
|
||||||
|
@ -163,8 +163,7 @@ struct cons_pointer read_string(FILE * input, wint_t initial)
|
||||||
return result;
|
return result;
|
||||||
}
|
}
|
||||||
|
|
||||||
struct cons_pointer read_symbol(FILE * input, wint_t initial)
|
struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
|
||||||
{
|
|
||||||
struct cons_pointer cdr = NIL;
|
struct cons_pointer cdr = NIL;
|
||||||
struct cons_pointer result;
|
struct cons_pointer result;
|
||||||
|
|
||||||
|
@ -198,7 +197,8 @@ struct cons_pointer read_symbol(FILE * input, wint_t initial)
|
||||||
*/
|
*/
|
||||||
ungetwc( initial, input );
|
ungetwc( initial, input );
|
||||||
} else {
|
} else {
|
||||||
result = make_symbol(initial, read_symbol(input, fgetwc(input)));
|
result =
|
||||||
|
make_symbol( initial, read_symbol( input, fgetwc( input ) ) );
|
||||||
}
|
}
|
||||||
break;
|
break;
|
||||||
}
|
}
|
||||||
|
@ -209,7 +209,6 @@ struct cons_pointer read_symbol(FILE * input, wint_t 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, fgetwc( input ) );
|
return read_continuation( input, fgetwc( input ) );
|
||||||
}
|
}
|
||||||
|
|
|
@ -14,8 +14,7 @@
|
||||||
* @param value the value to wrap;
|
* @param value the value to wrap;
|
||||||
* @return a real number cell wrapping this value.
|
* @return a real number cell wrapping this value.
|
||||||
*/
|
*/
|
||||||
struct cons_pointer make_real(long double value)
|
struct cons_pointer make_real( long double value ) {
|
||||||
{
|
|
||||||
struct cons_pointer result = allocate_cell( REALTAG );
|
struct cons_pointer result = allocate_cell( REALTAG );
|
||||||
struct cons_space_object *cell = &pointer2cell( result );
|
struct cons_space_object *cell = &pointer2cell( result );
|
||||||
cell->payload.real.value = value;
|
cell->payload.real.value = value;
|
||||||
|
|
|
@ -23,20 +23,21 @@
|
||||||
*/
|
*/
|
||||||
void
|
void
|
||||||
repl( FILE * in_stream, FILE * out_stream, FILE * error_stream,
|
repl( FILE * in_stream, FILE * out_stream, FILE * error_stream,
|
||||||
bool show_prompt)
|
bool show_prompt ) {
|
||||||
{
|
|
||||||
while ( !feof( in_stream ) ) {
|
while ( !feof( in_stream ) ) {
|
||||||
if ( show_prompt ) {
|
if ( show_prompt ) {
|
||||||
fwprintf( out_stream, L"\n:: " );
|
fwprintf( out_stream, L"\n:: " );
|
||||||
}
|
}
|
||||||
struct cons_pointer input = read( in_stream );
|
struct cons_pointer input = read( in_stream );
|
||||||
fwprintf(error_stream, L"\nread {%d,%d}=> ", input.page, input.offset);
|
fwprintf( error_stream, L"\nread {%d,%d}=> ", input.page,
|
||||||
|
input.offset );
|
||||||
if ( show_prompt ) {
|
if ( show_prompt ) {
|
||||||
fwprintf( out_stream, L"\n-> " );
|
fwprintf( out_stream, L"\n-> " );
|
||||||
}
|
}
|
||||||
// print( out_stream, lisp_eval(input, oblist, NULL));
|
// print( out_stream, lisp_eval(input, oblist, NULL));
|
||||||
print( out_stream, input );
|
print( out_stream, input );
|
||||||
fwprintf( out_stream, L"\n" );
|
fwprintf( out_stream, L"\n" );
|
||||||
fwprintf(error_stream, L"\neval {%d,%d}=> ", input.page, input.offset);
|
fwprintf( error_stream, L"\neval {%d,%d}=> ", input.page,
|
||||||
|
input.offset );
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
|
@ -31,8 +31,7 @@
|
||||||
*/
|
*/
|
||||||
struct stack_frame *make_stack_frame( struct stack_frame *previous,
|
struct stack_frame *make_stack_frame( struct stack_frame *previous,
|
||||||
struct cons_pointer args,
|
struct cons_pointer args,
|
||||||
struct cons_pointer env)
|
struct cons_pointer env ) {
|
||||||
{
|
|
||||||
/*
|
/*
|
||||||
* TODO: later, pop a frame off a free-list of stack frames
|
* TODO: later, pop a frame off a free-list of stack frames
|
||||||
*/
|
*/
|
||||||
|
@ -87,8 +86,7 @@ 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, push it back on the stack-frame freelist
|
* TODO: later, push it back on the stack-frame freelist
|
||||||
*/
|
*/
|
||||||
|
@ -103,8 +101,7 @@ void free_stack_frame(struct stack_frame *frame)
|
||||||
/**
|
/**
|
||||||
* Fetch a pointer to the value of the local variable at this index.
|
* Fetch a pointer to the value of the local variable at this index.
|
||||||
*/
|
*/
|
||||||
struct cons_pointer fetch_arg(struct stack_frame *frame, unsigned int index)
|
struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int index ) {
|
||||||
{
|
|
||||||
struct cons_pointer result = NIL;
|
struct cons_pointer result = NIL;
|
||||||
|
|
||||||
if ( index < args_in_frame ) {
|
if ( index < args_in_frame ) {
|
||||||
|
|
Loading…
Reference in a new issue