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

Append works; mapcar doesn't; loop isn't even written.

Browse source
This commit is contained in:
Simon Brooke 2021-08-23 12:35:05 +01:00
parent c63c262b74
commit 6771d6494c
No known key found for this signature in database
GPG key ID: A7A4F18D1D4DF987
10 changed files with 213 additions and 32 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
src/init.c
View file

@ -220,6 +220,7 @@ int main( int argc, char *argv[] ) {
*/
bind_function( L"absolute", &lisp_absolute );
bind_function( L"add", &lisp_add );
bind_function( L"append", &lisp_append );
bind_function( L"apply", &lisp_apply );
bind_function( L"assoc", &lisp_assoc );
bind_function( L"car", &lisp_car );
@ -235,6 +236,7 @@ int main( int argc, char *argv[] ) {
bind_function( L"hashmap", lisp_make_hashmap );
bind_function( L"inspect", &lisp_inspect );
bind_function( L"keys", &lisp_keys );
bind_function( L"mapcar", &lisp_mapcar );
bind_function( L"meta", &lisp_metadata );
bind_function( L"metadata", &lisp_metadata );
bind_function( L"multiply", &lisp_multiply );

4
src/io/io.c
View file

@ -503,8 +503,8 @@ lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer,
if ( readp( frame->arg[0] ) ) {
result =
make_string( url_fgetwc
( pointer2cell( frame->arg[0] ).payload.stream.
stream ), NIL );
( pointer2cell( frame->arg[0] ).payload.
stream.stream ), NIL );
}
return result;

13
src/memory/consspaceobject.h
View file

@ -114,12 +114,12 @@
* A loop exit is a special kind of exception which has exactly the same
* payload as an exception.
*/
#define LOOPXTAG "LOOX"
#define LOOPTAG "LOOP"
/**
* The string `LOOX`, considered as an `unsigned int`.
*/
#define LOOPXTV 1481592652
#define LOOPTV 1347374924
/**
* The special cons cell at address {0,0} whose car and cdr both point to
@ -304,9 +304,9 @@
#define lambdap(conspoint) (check_tag(conspoint,LAMBDATV))
/**
* true if `conspoint` points to a loop exit exception, else false.
* true if `conspoint` points to a loop recursion, else false.
*/
#define loopexitp(conspoint) (check_tag(conspoint,LOOPXTV))
#define loopp(conspoint) (check_tag(conspoint,LOOPTV))
/**
* true if `conspoint` points to a special form cell, else false
@ -615,7 +615,7 @@ struct cons_space_object {
*/
struct cons_payload cons;
/**
* if tag == EXCEPTIONTAG || tag == LOOPXTAG
* if tag == EXCEPTIONTAG || tag == LOOPTAG
*/
struct exception_payload exception;
/**
@ -713,6 +713,9 @@ struct cons_pointer make_special( struct cons_pointer src,
struct cons_pointer,
struct cons_pointer ) );
struct cons_pointer make_string_like_thing( wint_t c, struct cons_pointer tail,
uint32_t tag );
struct cons_pointer make_string( wint_t c, struct cons_pointer tail );
struct cons_pointer make_symbol_or_key( wint_t c, struct cons_pointer tail,

8
src/memory/dump.c
View file

@ -114,10 +114,10 @@ void dump_object( URL_FILE * output, struct cons_pointer pointer ) {
case RATIOTV:
url_fwprintf( output,
L"\t\tRational cell: value %ld/%ld, count %u\n",
pointer2cell( cell.payload.ratio.dividend ).payload.
integer.value,
pointer2cell( cell.payload.ratio.divisor ).payload.
integer.value, cell.count );
pointer2cell( cell.payload.ratio.dividend ).
payload.integer.value,
pointer2cell( cell.payload.ratio.divisor ).
payload.integer.value, cell.count );
break;
case READTV:
url_fputws( L"\t\tInput stream; metadata: ", output );

4
src/memory/hashmap.c
View file

@ -180,8 +180,8 @@ struct cons_pointer lisp_make_hashmap( struct stack_frame *frame,
map->payload.hashmap.buckets[bucket_no] =
inc_ref( make_cons( make_cons( key, val ),
map->payload.hashmap.
buckets[bucket_no] ) );
map->payload.
hashmap.buckets[bucket_no] ) );
}
}
}

121
src/ops/lispops.c
View file

@ -413,10 +413,9 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
result = next_pointer;
} else {
result =
( *fn_cell.payload.
special.executable ) ( get_stack_frame
( next_pointer ),
next_pointer, env );
( *fn_cell.payload.special.
executable ) ( get_stack_frame( next_pointer ),
next_pointer, env );
debug_print( L"Special form returning: ", DEBUG_EVAL );
debug_print_object( result, DEBUG_EVAL );
debug_println( DEBUG_EVAL );
@ -904,26 +903,30 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer,
/**
* reverse a sequence.
* reverse a sequence (if it is a sequence); else return it unchanged.
*/
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_or_key( o.payload.string.character, result,
SYMBOLTV );
break;
if ( sequencep( arg ) ) {
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_or_key( o.payload.string.character, result,
SYMBOLTV );
break;
}
}
} else {
result = arg;
}
return result;
@ -1350,6 +1353,86 @@ struct cons_pointer lisp_source( struct stack_frame *frame,
return result;
}
/**
* A version of append which can conveniently be called from C.
*/
struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) {
switch ( pointer2cell( l1 ).tag.value ) {
case CONSTV:
if ( pointer2cell( l1 ).tag.value == pointer2cell( l2 ).tag.value ) {
if ( nilp( c_cdr( l1 ) ) ) {
return make_cons( c_car( l1 ), l2 );
} else {
return make_cons( c_car( l1 ),
c_append( c_cdr( l1 ), l2 ) );
}
} else {
throw_exception( c_string_to_lisp_string
( L"Can't append: not same type" ), NIL );
}
break;
case KEYTV:
case STRINGTV:
case SYMBOLTV:
if ( pointer2cell( l1 ).tag.value == pointer2cell( l2 ).tag.value ) {
if ( nilp( c_cdr( l1 ) ) ) {
return
make_string_like_thing( ( pointer2cell( l1 ).payload.
string.character ), l2,
pointer2cell( l1 ).tag.value );
} else {
return
make_string_like_thing( ( pointer2cell( l1 ).payload.
string.character ),
c_append( c_cdr( l1 ), l2 ),
pointer2cell( l1 ).tag.value );
}
} else {
throw_exception( c_string_to_lisp_string
( L"Can't append: not same type" ), NIL );
}
break;
default:
throw_exception( c_string_to_lisp_string
( L"Can't append: not a sequence" ), NIL );
break;
}
}
/**
* should really be overwritten with a version in Lisp, since this is much easier to write in Lisp
*/
struct cons_pointer lisp_append( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return c_append( frame->arg[0], frame->arg[1] );
}
struct cons_pointer lisp_mapcar( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer result = NIL;
for ( struct cons_pointer c = frame->arg[1]; truep( c ); c = c_cdr( c ) ) {
struct cons_pointer expr = make_cons(frame->arg[0], make_cons(c_car(c), NIL));
inc_ref(expr);
struct cons_pointer r = eval_form(frame, frame_pointer, expr, env);
if ( exceptionp( r ) ) {
result = r;
inc_ref( expr ); // to protect exception from the later dec_ref
break;
} else {
result = make_cons( c, result );
}
dec_ref( expr );
}
return c_reverse( result );
}
// /**
// * Function; print the internal representation of the object indicated by `frame->arg[0]` to the

9
src/ops/lispops.h
View file

@ -202,4 +202,13 @@ struct cons_pointer lisp_source( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 );
struct cons_pointer lisp_append( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_mapcar( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
#endif

50
src/ops/loop.c Normal file
View file

@ -0,0 +1,50 @@
/*
* loop.c
*
* Iteration functions. This has *a lot* of similarity to try/catch --
* essentially what `recur` does is throw a special purpose exception which is
* caught by `loop`.
*
* Essentially the syntax I want is
*
* (defun expt (n e)
* (loop ((n1 . n) (r . n) (e1 . e))
* (cond ((= e 0) r)
* (t (recur n1 (* n1 r) (- e 1)))))
*
* It might in future be good to allow the body of the loop to comprise many
* expressions, like a `progn`, but for now if you want that you can just
* shove a `progn` in. Note that, given that what `recur` is essentially
* doing is throwing a special purpose exception, the `recur` expression
* doesn't actually have to be in the same function as the `loop` expression.
*
* (c) 2021 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include "consspaceobject.h"
#include "lispops.h"
#include "loop.h"
/**
* Special form, not dissimilar to `let`. Essentially,
*
* 1. the first arg (`args`) is an assoc list;
* 2. the second arg (`body`) is an expression.
*
* Each of the vals in the assoc list is evaluated, and bound to its
* respective key in a new environment. The body is then evaled in that
* environment. If the result is an object of type LOOP, it should carry
* a list of values of the same arity as args. Each of the keys in args
* is then rebound in a new environment to the respective value from the
* LOOP object, and body is then re-evaled in that environment.
*
* If the result is not a LOOP object, it is simply returned.
*/
struct cons_pointer
lisp_loop( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer keys = c_keys( frame->arg[0] );
struct cons_pointer body = frame->arg[1];
}

10
src/ops/loop.h Normal file
View file

@ -0,0 +1,10 @@
/*
* loop.h
*
* Iteration functions. This has *a lot* of similarity to try/catch --
* essentially what `recur` does is throw a special purpose exception which is
* caught by `loop`.
*
* (c) 2021 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/

24
unit-tests/append.sh Executable file
View file

@ -0,0 +1,24 @@
#!/bin/bash
expected='(a b c d e f)'
actual=`echo "(append '(a b c) '(d e f))" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi
expected='"hellodere"'
actual=`echo '(append "hello" "dere")' | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi