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

Reverse

Browse source
This commit is contained in:
Simon Brooke 2018-12-25 14:44:38 +00:00
parent 9e5af35aa0
commit 9ff2f14c7d
7 changed files with 151 additions and 6 deletions
Download patch file Download diff file Expand all files Collapse all files

1
src/init.c
View file

@ -95,6 +95,7 @@ int main( int argc, char *argv[] ) {
bind_function( "oblist", &lisp_oblist );
bind_function( "print", &lisp_print );
bind_function( "progn", &lisp_progn );
bind_function( "reverse", &lisp_reverse );
bind_function( "set", &lisp_set );
bind_function( "subtract", &lisp_subtract );
bind_function( "type", &lisp_type );

2
src/memory/consspaceobject.h
View file

@ -234,6 +234,8 @@
*/
#define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,RATIOTAG)||check_tag(conspoint,REALTAG)||check_tag(conspoint,BIGNUMTAG))
#define sequencep(conspoint) (check_tag(conspoint,CONSTAG)||check_tag(conspoint,STRINGTAG)||check_tag(conspoint,SYMBOLTAG))
/**
* true if thr conspointer points to a vector pointer.
*/

53
src/ops/lispops.c
View file

@ -169,11 +169,13 @@ lisp_nlambda( struct stack_frame *frame, struct cons_pointer env ) {
}
void log_binding( struct cons_pointer name, struct cons_pointer val ) {
print( stderr, c_string_to_lisp_string( "\n\tBinding " ) );
#ifdef DEBUG
fputws( L"\n\tBinding ", stderr );
print( stderr, name );
print( stderr, c_string_to_lisp_string( " to " ) );
fputws( L" to ", stderr);
print( stderr, val );
fputws( L"\"\n", stderr );
#endif
}
/**
@ -279,8 +281,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer exep = NIL;
struct stack_frame *next =
make_stack_frame( frame, args, env, &exep );
#ifdef DEBUG
fputws( L"Stack frame for lambda\n", stderr );
dump_frame( stderr, next );
#endif
result = eval_lambda( fn_cell, next, env );
if ( exceptionp( result ) ) {
/* if we're returning an exception, we should NOT free the
@ -296,8 +300,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
{
struct stack_frame *next =
make_special_frame( frame, args, env );
#ifdef DEBUG
fputws( L"Stack frame for nlambda\n", stderr );
dump_frame( stderr, next );
#endif
result = eval_lambda( fn_cell, next, env );
if ( !exceptionp( result ) ) {
/* if we're returning an exception, we should NOT free the
@ -376,8 +382,10 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer result = frame->arg[0];
struct cons_space_object cell = pointer2cell( frame->arg[0] );
#ifdef DEBUG
fputws( L"Eval: ", stderr );
dump_frame( stderr, frame );
#endif
switch ( cell.tag.value ) {
case CONSTV:
@ -415,9 +423,11 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
break;
}
#ifdef DEBUG
fputws( L"Eval returning ", stderr );
print( stderr, result );
fputws( L"\n", stderr );
#endif
return result;
}
@ -432,17 +442,20 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
*/
struct cons_pointer
lisp_apply( struct stack_frame *frame, struct cons_pointer env ) {
#ifdef DEBUG
fputws( L"Apply: ", stderr );
dump_frame( stderr, frame );
#endif
set_reg( frame, 0, make_cons( frame->arg[0], frame->arg[1] ) );
set_reg( frame, 1, NIL );
struct cons_pointer result = c_apply( frame, env );
#ifdef DEBUG
fputws( L"Apply returning ", stderr );
print( stderr, result );
fputws( L"\n", stderr );
#endif
return result;
}
@ -641,6 +654,40 @@ lisp_read( struct stack_frame *frame, struct cons_pointer env ) {
}
/**
* reverse a sequence.
*/
struct cons_pointer c_reverse( struct cons_pointer arg) {
struct cons_pointer result = NIL;
for (struct cons_pointer p = arg; sequencep(p); p = c_cdr(p)) {
struct cons_space_object o = pointer2cell(p);
switch (o.tag.value) {
case CONSTV:
result = make_cons(o.payload.cons.car, result);
break;
case STRINGTV:
result = make_string(o.payload.string.character, result);
break;
case SYMBOLTV:
result = make_symbol(o.payload.string.character, result);
break;
}
}
return result;
}
/**
* (reverse sequence)
* Return a sequence like this sequence but with the members in the reverse order.
*/
struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer env ) {
return c_reverse( frame->arg[0]);
}
/**
* (print expr)
* (print expr write-stream)

7
src/ops/lispops.h
View file

@ -40,6 +40,7 @@ struct cons_pointer c_car( struct cons_pointer arg );
*/
struct cons_pointer c_cdr( struct cons_pointer arg );
struct cons_pointer c_reverse( struct cons_pointer arg);
/**
* Useful building block; evaluate this single form in the context of this
@ -117,10 +118,12 @@ struct cons_pointer lisp_eq( struct stack_frame *frame,
struct cons_pointer env );
struct cons_pointer lisp_equal( struct stack_frame *frame,
struct cons_pointer env );
struct cons_pointer lisp_read( struct stack_frame *frame,
struct cons_pointer env );
struct cons_pointer lisp_print( struct stack_frame *frame,
struct cons_pointer env );
struct cons_pointer lisp_read( struct stack_frame *frame,
struct cons_pointer env );
struct cons_pointer lisp_reverse( struct stack_frame *frame,
struct cons_pointer env );
/**
* Function: Get the Lisp type of the single argument.
* @param frame My stack frame.

4
src/ops/read.c
View file

@ -148,6 +148,8 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input,
initial = fgetwc( input );
}
#ifdef DEBUG
fwprintf( stderr, L"read_number starting '%c' (%d)\n", initial, initial );
#endif
@ -164,7 +166,7 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input,
} else if ( c == btowc( '/' ) ) {
if ( seen_period || dividend > 0 ) {
return make_exception( c_string_to_lisp_string
( "Malformed number: dividend must be integer" ),
( "Malformed number: dividend of rational must be integer" ),
frame );
} else {
dividend = negative ? 0 - accumulator : accumulator;