From 6771d6494c5b95d1adc7029aa8920e763d0a71b6 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 23 Aug 2021 12:35:05 +0100 Subject: [PATCH] Append works; mapcar doesn't; loop isn't even written. --- src/init.c | 2 + src/io/io.c | 4 +- src/memory/consspaceobject.h | 13 ++-- src/memory/dump.c | 8 +-- src/memory/hashmap.c | 4 +- src/ops/lispops.c | 121 +++++++++++++++++++++++++++++------ src/ops/lispops.h | 9 +++ src/ops/loop.c | 50 +++++++++++++++ src/ops/loop.h | 10 +++ unit-tests/append.sh | 24 +++++++ 10 files changed, 213 insertions(+), 32 deletions(-) create mode 100644 src/ops/loop.c create mode 100644 src/ops/loop.h create mode 100755 unit-tests/append.sh diff --git a/src/init.c b/src/init.c index dbd7acf..5e8a55d 100644 --- a/src/init.c +++ b/src/init.c @@ -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 ); diff --git a/src/io/io.c b/src/io/io.c index f621539..72830a4 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -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; diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 2817e69..7c3a390 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -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, diff --git a/src/memory/dump.c b/src/memory/dump.c index 086f8c8..81182a8 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -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 ); diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c index cee9267..d6909ba 100644 --- a/src/memory/hashmap.c +++ b/src/memory/hashmap.c @@ -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] ) ); } } } diff --git a/src/ops/lispops.c b/src/ops/lispops.c index b173090..2356abe 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -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 diff --git a/src/ops/lispops.h b/src/ops/lispops.h index c1cc337..582cd98 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -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 diff --git a/src/ops/loop.c b/src/ops/loop.c new file mode 100644 index 0000000..6ccada6 --- /dev/null +++ b/src/ops/loop.c @@ -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 + * 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]; + +} diff --git a/src/ops/loop.h b/src/ops/loop.h new file mode 100644 index 0000000..27714a8 --- /dev/null +++ b/src/ops/loop.h @@ -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 + * Licensed under GPL version 2.0, or, at your option, any later version. + */ diff --git a/unit-tests/append.sh b/unit-tests/append.sh new file mode 100755 index 0000000..0f6fb30 --- /dev/null +++ b/unit-tests/append.sh @@ -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 +