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

Merge branch 'feature/exp2' into develop

Browse source
This commit is contained in:
Simon Brooke 2017-09-13 18:02:12 +01:00
parent 5dee093e65 27f39e85ea
commit 46fff43fc7
23 changed files with 427 additions and 129 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
include/licence-header.txt Normal file
View file

@ -0,0 +1,2 @@
(c) 2017 Simon Brooke <simon@journeyman.cc>
Licensed under GPL version 2.0, or, at your option, any later version.

7
src/conspage.c
View file

@ -164,10 +164,11 @@ struct cons_pointer allocate_cell( char *tag ) {
cell->payload.cons.car = NIL;
cell->payload.cons.cdr = NIL;
#ifdef DEBUG
fprintf( stderr,
"Allocated cell of type '%s' at %d, %d \n", tag,
result.page, result.offset );
// dump_object( stderr, result );
#endif
} else {
fprintf( stderr, "WARNING: Allocating non-free cell!" );
}
@ -188,7 +189,7 @@ void initialise_cons_pages( ) {
make_cons_page( );
conspageinitihasbeencalled = true;
} else {
fprintf( stderr,
"WARNING: conspageinit() called a second or subsequent time\n" );
fwprintf( stderr,
L"WARNING: initialise_cons_pages() called a second or subsequent time\n" );
}
}

22
src/conspage.h
View file

@ -4,23 +4,27 @@
#define __conspage_h
/**
* the number of cons cells on a cons page. The maximum value this can be (and consequently,
* the size which, by version 1, it will default to) is the maximum value of an unsigned 32
* bit integer, which is to say 4294967296. However, we'll start small.
* the number of cons cells on a cons page. The maximum value this can
* be (and consequently, the size which, by version 1, it will default
* to) is the maximum value of an unsigned 32 bit integer, which is to
* say 4294967296. However, we'll start small.
*/
#define CONSPAGESIZE 8
/**
* the number of cons pages we will initially allow for. For convenience we'll set up an array
* of cons pages this big; however, later we will want a mechanism for this to be able to grow
* dynamically to the maximum we can currently allow, which is 4294967296.
* the number of cons pages we will initially allow for. For
* convenience we'll set up an array of cons pages this big; however,
* later we will want a mechanism for this to be able to grow
* dynamically to the maximum we can currently allow, which is
* 4294967296.
*/
#define NCONSPAGES 8
/**
* a cons page is essentially just an array of cons space objects. It might later have a local
* free list (i.e. list of free cells on this page) and a pointer to the next cons page, but
* my current view is that that's probably unneccessary.
* a cons page is essentially just an array of cons space objects. It
* might later have a local free list (i.e. list of free cells on this
* page) and a pointer to the next cons page, but my current view is
* that that's probably unneccessary.
*/
struct cons_page {
struct cons_space_object cell[CONSPAGESIZE];

30
src/consspaceobject.c
View file

@ -19,6 +19,7 @@
#include "conspage.h"
#include "consspaceobject.h"
#include "print.h"
/**
* Check that the tag on the cell at this pointer is this tag
@ -73,28 +74,47 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
cell.tag.bytes[3],
cell.tag.value, pointer.page, pointer.offset, cell.count );
if ( check_tag( pointer, CONSTAG ) ) {
switch ( cell.tag.value) {
case CONSTV:
fwprintf( output,
L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d\n",
cell.payload.cons.car.page,
cell.payload.cons.car.offset,
cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset );
} else if ( check_tag( pointer, INTEGERTAG ) ) {
break;
case INTEGERTV:
fwprintf( output,
L"\t\tInteger cell: value %ld\n",
cell.payload.integer.value );
} else if ( check_tag( pointer, FREETAG ) ) {
break;
case FREETV:
fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n",
cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset );
} else if ( check_tag( pointer, REALTAG ) ) {
break;
case REALTV:
fwprintf( output, L"\t\tReal cell: value %Lf\n",
cell.payload.real.value );
} else if ( check_tag( pointer, STRINGTAG ) ) {
break;
case STRINGTV:
fwprintf( output,
L"\t\tString cell: character '%1c' (%1d) next at page %2d offset %3d\n",
cell.payload.string.character,
cell.payload.string.cdr.page,
cell.payload.string.cdr.offset );
fwprintf( output, L"\t\t value:");
print(output, pointer);
fwprintf( output, L"\n");
break;
case SYMBOLTV:
fwprintf( output,
L"\t\tSymbol cell: character '%1c' (%1d) next at page %2d offset %3d\n",
cell.payload.string.character,
cell.payload.string.cdr.page,
cell.payload.string.cdr.offset );
fwprintf( output, L"\t\t value:");
print(output, pointer);
fwprintf( output, L"\n");
break;
}
}

18
src/consspaceobject.h
View file

@ -156,7 +156,7 @@
#define stringp(conspoint) (check_tag(conspoint,STRINGTAG))
/**
* true if conspointer points to a string cell, else false
* true if conspointer points to a symbol cell, else false
*/
#define symbolp(conspoint) (check_tag(conspoint,SYMBOLTAG))
@ -418,14 +418,6 @@ struct cons_pointer make_cons( struct cons_pointer car,
*/
struct cons_pointer make_function( struct cons_pointer src,
struct cons_pointer ( *executable )
( struct stack_frame *,
struct cons_pointer ) );
@ -434,14 +426,6 @@ struct cons_pointer make_function( struct cons_pointer src,
*/
struct cons_pointer make_special( struct cons_pointer src,
struct cons_pointer ( *executable )
( struct cons_pointer s_expr,
struct cons_pointer env,
struct stack_frame * frame ) );

38
src/equal.c
View file

@ -22,6 +22,21 @@ bool eq( struct cons_pointer a, struct cons_pointer b ) {
return ( ( a.page == b.page ) && ( a.offset == b.offset ) );
}
/**
* True if the objects at these two cons pointers have the same tag, else false.
* @param a a pointer to a cons-space object;
* @param b another pointer to a cons-space object.
* @return true if the objects at these two cons pointers have the same tag,
* else false.
*/
bool same_type( struct cons_pointer a, struct cons_pointer b ) {
struct cons_space_object *cell_a = &pointer2cell( a );
struct cons_space_object *cell_b = &pointer2cell( b );
return cell_a->tag.value == cell_b->tag.value;
}
/**
* Deep, and thus expensive, equality: true if these two objects have
* identical structure, else false.
@ -29,15 +44,18 @@ bool eq( struct cons_pointer a, struct cons_pointer b ) {
bool equal( struct cons_pointer a, struct cons_pointer b ) {
bool result = eq( a, b );
if ( !result ) {
if ( !result && same_type( a, b ) ) {
struct cons_space_object *cell_a = &pointer2cell( a );
struct cons_space_object *cell_b = &pointer2cell( b );
if ( consp( a ) && consp( b ) ) {
switch ( cell_a->tag.value ) {
case CONSTV:
result =
equal( cell_a->payload.cons.car, cell_b->payload.cons.car )
&& equal( cell_a->payload.cons.cdr, cell_b->payload.cons.cdr );
} else if ( stringp( a ) && stringp( b ) ) {
break;
case STRINGTV:
case SYMBOLTV:
/*
* slightly complex because a string may or may not have a '\0'
* cell at the end, but I'll ignore that for now. I think in
@ -48,17 +66,27 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
cell_b->payload.string.character
&& equal( cell_a->payload.string.cdr,
cell_b->payload.string.cdr );
} else if ( numberp( a ) && numberp( b ) ) {
break;
case INTEGERTV:
case REALTV:
{
double num_a = numeric_value( a );
double num_b = numeric_value( b );
double max =
fabs( num_a ) > fabs( num_b ) ? fabs( num_a ) : fabs( num_b );
fabs( num_a ) >
fabs( num_b ) ? fabs( num_a ) : fabs( num_b );
/*
* not more different than one part in a million - close enough
*/
result = fabs( num_a - num_b ) < ( max / 1000000.0 );
}
break;
default:
result = false;
break;
}
/*
* there's only supposed ever to be one T and one NIL cell, so each
* should be caught by eq; equality of vector-space objects is a whole

30
src/init.c
View file

@ -19,19 +19,21 @@
#include "consspaceobject.h"
#include "intern.h"
#include "lispops.h"
#include "peano.h"
#include "print.h"
#include "repl.h"
void bind_function( char *name, struct cons_pointer ( *executable )
( struct stack_frame *, struct cons_pointer ) ) {
deep_bind( intern( c_string_to_lisp_symbol( name ), oblist ),
make_function( NIL, executable ) );
deep_bind( c_string_to_lisp_symbol( name ),
make_function( NIL, executable ));
}
void bind_special( char *name, struct cons_pointer ( *executable )
( struct cons_pointer s_expr, struct cons_pointer env,
struct stack_frame * frame ) ) {
deep_bind( intern( c_string_to_lisp_symbol( name ), oblist ),
make_special( NIL, executable ) );
deep_bind( c_string_to_lisp_symbol( name ),
make_special( NIL, executable ));
}
int main( int argc, char *argv[] ) {
@ -54,14 +56,14 @@ int main( int argc, char *argv[] ) {
show_prompt = true;
break;
default:
fprintf( stderr, "Unexpected option %c\n", option );
fwprintf( stderr, L"Unexpected option %c\n", option );
break;
}
}
if ( show_prompt ) {
fprintf( stdout,
"Post scarcity software environment version %s\n\n",
fwprintf( stdout,
L"Post scarcity software environment version %s\n\n",
VERSION );
}
@ -70,8 +72,9 @@ int main( int argc, char *argv[] ) {
/*
* privileged variables (keywords)
*/
deep_bind( intern( c_string_to_lisp_string( "nil" ), oblist ), NIL );
deep_bind( intern( c_string_to_lisp_string( "t" ), oblist ), TRUE );
deep_bind( c_string_to_lisp_symbol( "nil" ), NIL );
deep_bind( c_string_to_lisp_symbol( "t" ), TRUE );
/*
* primitive function operations
@ -85,6 +88,10 @@ int main( int argc, char *argv[] ) {
bind_function( "read", &lisp_read );
bind_function( "print", &lisp_print );
bind_function( "add", &lisp_add);
bind_function( "multiply", &lisp_multiply);
bind_function( "subtract", &lisp_subtract);
/*
* primitive special forms
*/
@ -92,6 +99,11 @@ int main( int argc, char *argv[] ) {
bind_special( "eval", &lisp_eval );
bind_special( "quote", &lisp_quote );
/* bind the oblist last, at this stage. Something clever needs to be done
* here and I'm not sure what it is. */
deep_bind( c_string_to_lisp_symbol( "oblist"), oblist);
repl( stdin, stdout, stderr, show_prompt );
if ( dump_at_end ) {

4
src/integer.c
View file

@ -20,7 +20,7 @@
* as a cons-space object. Cell may in principle be any kind of number,
* but only integers and reals are so far implemented.
*/
double numeric_value( struct cons_pointer pointer ) {
long double numeric_value( struct cons_pointer pointer ) {
double result = NAN;
struct cons_space_object *cell = &pointer2cell( pointer );
@ -41,7 +41,7 @@ struct cons_pointer make_integer( long int value ) {
struct cons_space_object *cell = &pointer2cell( result );
cell->payload.integer.value = value;
dump_object( stderr, result);
dump_object( stderr, result );
return result;
}

2
src/integer.h
View file

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

28
src/lispops.c
View file

@ -102,10 +102,10 @@ eval_cons( struct cons_pointer s_expr, struct cons_pointer env,
switch ( fn_cell.tag.value ) {
case SPECIALTV:
{
struct cons_space_object special = pointer2cell( fn_pointer );
struct stack_frame *frame =
make_special_frame( my_frame, args, env );
result =
( *special.payload.special.executable ) ( args, env,
my_frame );
( *fn_cell.payload.special.executable ) ( args, env, frame );
}
break;
@ -122,7 +122,7 @@ eval_cons( struct cons_pointer s_expr, struct cons_pointer 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 );
result = ( *fn_cell.payload.function.executable ) ( frame, env );
free_stack_frame( frame );
}
break;
@ -164,15 +164,9 @@ lisp_eval( struct cons_pointer s_expr, struct cons_pointer env,
struct cons_pointer result = s_expr;
struct cons_space_object cell = pointer2cell( s_expr );
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 ) {
case CONSTV:
result = eval_cons( s_expr, env, frame );
result = eval_cons( s_expr, env, previous);
break;
case SYMBOLTV:
@ -182,7 +176,7 @@ lisp_eval( struct cons_pointer s_expr, struct cons_pointer env,
struct cons_pointer message =
c_string_to_lisp_string
( "Attempt to take value of unbound symbol." );
result = lisp_throw( message, frame );
result = lisp_throw( message, previous );
} else {
result = c_assoc( canonical, env );
}
@ -197,8 +191,6 @@ lisp_eval( struct cons_pointer s_expr, struct cons_pointer env,
*/
}
free_stack_frame( frame );
return result;
}
@ -212,7 +204,7 @@ lisp_eval( struct cons_pointer s_expr, struct cons_pointer env,
struct cons_pointer
lisp_quote( struct cons_pointer args, struct cons_pointer env,
struct stack_frame *frame ) {
return c_car( args );
return frame->arg[0];
}
/**
@ -360,10 +352,10 @@ lisp_print( struct stack_frame *frame, struct cons_pointer env ) {
*/
struct cons_pointer
lisp_throw( struct cons_pointer message, struct stack_frame *frame ) {
fprintf( stderr, "\nERROR: " );
fwprintf( stderr, L"\nERROR: " );
print( stderr, message );
fprintf( stderr,
"\n\nAn exception was thrown and I've no idea what to do now\n" );
fwprintf( stderr,
L"\n\nAn exception was thrown and I've no idea what to do now\n" );
exit( 1 );
}

149
src/peano.c Normal file
View file

@ -0,0 +1,149 @@
/**
* peano.c
*
* Basic peano arithmetic
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <ctype.h>
#include <stdbool.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <math.h>
#include "consspaceobject.h"
#include "conspage.h"
#include "equal.h"
#include "integer.h"
#include "intern.h"
#include "lispops.h"
#include "print.h"
#include "read.h"
#include "real.h"
#include "stack.h"
/**
* Add an indefinite number of numbers together
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer or real.
*/
struct cons_pointer
lisp_add(struct stack_frame *frame, struct cons_pointer env) {
struct cons_pointer result = NIL;
long int i_accumulator = 0;
long double d_accumulator = 0;
bool is_int = true;
for (int i = 0; i < args_in_frame && !nilp(frame->arg[i]); i++) {
struct cons_space_object arg = pointer2cell(frame->arg[i]);
switch (arg.tag.value) {
case INTEGERTV:
i_accumulator += arg.payload.integer.value;
d_accumulator += numeric_value( frame->arg[i]);
break;
case REALTV:
d_accumulator += arg.payload.real.value;
is_int = false;
default:
lisp_throw(
c_string_to_lisp_string("Cannot add: not a number"),
frame);
}
if (! nilp(frame->more)) {
lisp_throw(
c_string_to_lisp_string("Cannot yet add more than 8 numbers"),
frame);
}
if ( is_int) {
result = make_integer( i_accumulator);
} else {
result = make_real( d_accumulator);
}
}
return result;
}
/**
* Multiply an indefinite number of numbers together
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer or real.
*/
struct cons_pointer
lisp_multiply(struct stack_frame *frame, struct cons_pointer env) {
struct cons_pointer result = NIL;
long int i_accumulator = 1;
long double d_accumulator = 1;
bool is_int = true;
for (int i = 0; i < args_in_frame && !nilp(frame->arg[i]); i++) {
struct cons_space_object arg = pointer2cell(frame->arg[i]);
switch (arg.tag.value) {
case INTEGERTV:
i_accumulator *= arg.payload.integer.value;
d_accumulator *= numeric_value( frame->arg[i]);
break;
case REALTV:
d_accumulator *= arg.payload.real.value;
is_int = false;
default:
lisp_throw(
c_string_to_lisp_string("Cannot multiply: not a number"),
frame);
}
if (! nilp(frame->more)) {
lisp_throw(
c_string_to_lisp_string("Cannot yet multiply more than 8 numbers"),
frame);
}
if ( is_int) {
result = make_integer( i_accumulator);
} else {
result = make_real( d_accumulator);
}
}
return result;
}
/**
* Subtract one number from another.
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer or real.
*/
struct cons_pointer
lisp_subtract(struct stack_frame *frame, struct cons_pointer env) {
struct cons_pointer result = NIL;
struct cons_space_object arg0 = pointer2cell(frame->arg[0]);
struct cons_space_object arg1 = pointer2cell(frame->arg[1]);
if ( integerp(frame->arg[0]) && integerp(frame->arg[1])) {
result = make_integer(arg0.payload.integer.value - arg1.payload.integer.value);
} else if ( realp(frame->arg[0]) && realp(frame->arg[1])) {
result = make_real(arg0.payload.real.value - arg1.payload.real.value);
} else if (integerp(frame->arg[0]) && realp(frame->arg[1])) {
result = make_real( numeric_value(frame->arg[0]) - arg1.payload.real.value);
} else if (realp(frame->arg[0]) && integerp(frame->arg[1])) {
result = make_real( arg0.payload.real.value - numeric_value(frame->arg[0]));
} // else we have an error!
// and if not nilp[frame->arg[2]) we also have an error.
return result;
}

51
src/peano.h Normal file
View file

@ -0,0 +1,51 @@
/**
* peano.h
*
* Basic peano arithmetic
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include "consspaceobject.h"
#ifndef PEANO_H
#define PEANO_H
#ifdef __cplusplus
extern "C" {
#endif
/**
* Add an indefinite number of numbers together
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer or real.
*/
struct cons_pointer
lisp_add(struct stack_frame *frame, struct cons_pointer env);
/**
* Multiply an indefinite number of numbers together
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer or real.
*/
struct cons_pointer
lisp_multiply(struct stack_frame *frame, struct cons_pointer env);
/**
* Subtract one number from another.
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer or real.
*/
struct cons_pointer
lisp_subtract(struct stack_frame *frame, struct cons_pointer env);
#ifdef __cplusplus
}
#endif
#endif /* PEANO_H */

8
src/print.c
View file

@ -89,7 +89,7 @@ void print( FILE * output, struct cons_pointer pointer ) {
fwprintf( output, L"nil" );
break;
case REALTV:
fwprintf( output, L"%lf", cell.payload.real.value );
fwprintf( output, L"%Lf", cell.payload.real.value );
break;
case STRINGTV:
print_string( output, pointer );
@ -100,6 +100,12 @@ void print( FILE * output, struct cons_pointer pointer ) {
case TRUETV:
fwprintf( output, L"t" );
break;
case FUNCTIONTV:
fwprintf( output, L"(Function)");
break;
case SPECIALTV:
fwprintf( output, L"(Special form)");
break;
default:
fwprintf( stderr,
L"Error: Unrecognised tag value %d (%c%c%c%c)\n",

28
src/read.c
View file

@ -82,6 +82,7 @@ struct cons_pointer read_continuation( FILE * input, wint_t initial ) {
* read a number from this input stream, given this initial character.
*/
struct cons_pointer read_number( FILE * input, wint_t initial ) {
struct cons_pointer result = NIL;
long int accumulator = 0;
int places_of_decimals = 0;
bool seen_period = false;
@ -96,7 +97,8 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) {
} else {
accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' );
fprintf( stderr, "Added character %c, accumulator now %ld\n", c, accumulator);
fwprintf( stderr, L"Added character %c, accumulator now %ld\n", c,
accumulator );
if ( seen_period ) {
places_of_decimals++;
@ -110,10 +112,16 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) {
ungetwc( c, input );
if ( seen_period ) {
return make_real( accumulator / pow( 10, places_of_decimals ) );
long double rv = (long double)
( accumulator / pow(10, places_of_decimals) );
fwprintf( stderr, L"read_numer returning %Lf\n", rv);
result = make_real( rv);
} else {
return make_integer( accumulator );
result = make_integer( accumulator );
}
return result;
}
/**
@ -146,8 +154,6 @@ 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 );
switch ( initial ) {
case '\0':
result = make_string( initial, NIL );
@ -167,8 +173,6 @@ 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 );
@ -190,15 +194,15 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
ungetwc( initial, input );
break;
default:
if ( iswblank( initial ) || !iswprint( initial ) ) {
result = make_symbol( '\0', NIL );
if ( iswalnum( initial ) ) {
result =
make_symbol( initial, read_symbol( input, fgetwc( input ) ) );
} else {
result = NIL;
/*
* push back the character read
*/
ungetwc( initial, input );
} else {
result =
make_symbol( initial, read_symbol( input, fgetwc( input ) ) );
}
break;
}

2
src/real.h
View file

@ -24,7 +24,7 @@ extern "C" {
* @param value the value to wrap;
* @return a real number cell wrapping this value.
*/
struct cons_pointer make_real( double value );
struct cons_pointer make_real( double value );
#ifdef __cplusplus
}

14
src/repl.c
View file

@ -31,19 +31,13 @@ repl( FILE * in_stream, FILE * out_stream, FILE * error_stream,
struct cons_pointer input = read( in_stream );
fwprintf( error_stream, L"\nread {%d,%d}=> ", input.page,
input.offset );
if ( show_prompt ) {
fwprintf( out_stream, L"\n-> " );
}
print( error_stream, input);
/* OK, I think what's going wrong here is we're passing by
* value and I think we should be passing by reference.
* I'm not certain about that, and as it will be a really
* major change I'm going to think some more before making
* in */
// print( out_stream, lisp_eval(input, oblist, NULL));
print( out_stream, input );
struct cons_pointer value = lisp_eval( input, oblist, NULL );
// print( out_stream, input );
fwprintf( out_stream, L"\n" );
fwprintf( error_stream, L"\neval {%d,%d}=> ", input.page,
input.offset );
print( out_stream, value);
}
}

59
src/stack.c
View file

@ -23,6 +23,7 @@
#include "consspaceobject.h"
#include "conspage.h"
#include "lispops.h"
#include "print.h"
#include "stack.h"
/**
@ -50,16 +51,12 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous,
result->arg[i] = NIL;
}
int i = 0; /* still an index into args, so same name will
* do */
while ( !nilp( args ) ) { /* iterate down the arg list filling in the
* arg slots in the frame. When there are no
* more slots, if there are still args, stash
* them on more */
for (int i = 0; i < args_in_frame && !nilp( args ); i++ ) {
/* iterate down the arg list filling in the arg slots in the
* frame. When there are no more slots, if there are still args,
* stash them on more */
struct cons_space_object cell = pointer2cell( args );
if ( i < args_in_frame ) {
/*
* TODO: if we were running on real massively parallel hardware,
* each arg except the first should be handed off to another
@ -69,16 +66,58 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous,
inc_ref( result->arg[i] );
args = cell.payload.cons.cdr;
} else {
}
/*
* TODO: this isn't right. These args should also each be evaled.
*/
result->more = args;
inc_ref( result->more );
args = NIL;
return result;
}
/**
* A 'special' frame is exactly like a normal stack frame except that the
* arguments are unevaluated.
* @param previous the previous stack frame;
* @param args a list of the arguments to be stored in this stack frame;
* @param env the execution environment;
* @return a new special frame.
*/
struct stack_frame *make_special_frame( struct stack_frame *previous,
struct cons_pointer args,
struct cons_pointer env ) {
/*
* TODO: later, pop a frame off a free-list of stack frames
*/
struct stack_frame *result = malloc( sizeof( struct stack_frame ) );
result->previous = previous;
/*
* clearing the frame with memset would probably be slightly quicker, but
* this is clear.
*/
result->more = NIL;
result->function = NIL;
for ( int i = 0; i < args_in_frame; i++ ) {
result->arg[i] = NIL;
}
for (int i = 0; i < args_in_frame && !nilp( args ); i++ ) {
/* iterate down the arg list filling in the arg slots in the
* frame. When there are no more slots, if there are still args,
* stash them on more */
struct cons_space_object cell = pointer2cell( args );
result->arg[i] = cell.payload.cons.car;
inc_ref( result->arg[i] );
args = cell.payload.cons.cdr;
}
result->more = args;
inc_ref(args);
return result;
}

12
src/stack.h
View file

@ -30,6 +30,18 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous,
void free_stack_frame( struct stack_frame *frame );
struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int n );
/**
* A 'special' frame is exactly like a normal stack frame except that the
* arguments are unevaluated.
* @param previous the previous stack frame;
* @param args a list of the arguments to be stored in this stack frame;
* @param env the execution environment;
* @return a new special frame.
*/
struct stack_frame *make_special_frame( struct stack_frame *previous,
struct cons_pointer args,
struct cons_pointer env );
/*
* struct stack_frame is defined in consspaceobject.h to break circularity
* TODO: refactor.

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

@ -1,7 +1,7 @@
#!/bin/bash
expected='(1 2 3 ("Fred") nil 77354)'
actual=`echo '(1 2 3 ("Fred") () 77354)' | target/psse 2> /dev/null | head -1`
actual=`echo "'(1 2 3 (\"Fred\") () 77354)" | target/psse 2> /dev/null | head -1`
if [ "${expected}" = "${actual}" ]
then

2
unit-tests/quote.sh
View file

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

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

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

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

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