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

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 );

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.
+                         ( pointer2cell( frame->arg[0] ).payload.
-                           stream ), NIL );
+                           stream.stream ), NIL );
     }
 
     return result;

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,

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.
+                          pointer2cell( cell.payload.ratio.dividend ).
-                          integer.value,
+                          payload.integer.value,
-                          pointer2cell( cell.payload.ratio.divisor ).payload.
+                          pointer2cell( cell.payload.ratio.divisor ).
-                          integer.value, cell.count );
+                          payload.integer.value, cell.count );
             break;
         case READTV:
             url_fputws( L"\t\tInput stream; metadata: ", output );

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.
+                                        map->payload.
-                                        buckets[bucket_no] ) );
+                                        hashmap.buckets[bucket_no] ) );
             }
         }
     }

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.
+                            ( *fn_cell.payload.special.
-                              special.executable ) ( get_stack_frame
+                              executable ) ( get_stack_frame( next_pointer ),
-                                                     ( next_pointer ),
+                                             next_pointer, env );
-                                                     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 ) ) {
+    if ( sequencep( arg ) ) {
-        struct cons_space_object o = pointer2cell( p );
+        for ( struct cons_pointer p = arg; sequencep( p ); p = c_cdr( p ) ) {
-        switch ( o.tag.value ) {
+            struct cons_space_object o = pointer2cell( p );
-            case CONSTV:
+            switch ( o.tag.value ) {
-                result = make_cons( o.payload.cons.car, result );
+                case CONSTV:
-                break;
+                    result = make_cons( o.payload.cons.car, result );
-            case STRINGTV:
+                    break;
-                result = make_string( o.payload.string.character, result );
+                case STRINGTV:
-                break;
+                    result = make_string( o.payload.string.character, result );
-            case SYMBOLTV:
+                    break;
-                result =
+                case SYMBOLTV:
-                    make_symbol_or_key( o.payload.string.character, result,
+                    result =
-                                        SYMBOLTV );
+                        make_symbol_or_key( o.payload.string.character, result,
-                break;
+                                            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

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

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 <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];
+
+}

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 <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */

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
+