Implement NTH.

Signed-off-by: Kaz Wesley <kaz@lambdaverse.org>

diff --git a/src/Makefile.am b/src/Makefile.am
index 50723bd9c55703f5a308cd3a07467ed2e32eeea6..34bbd8871099231ff8b0977906a8db71f099d5ed 100644 (file)
--- a/src/Makefile.am
+++ b/src/Makefile.am
@@ -2,4 +2,4 @@ bin_PROGRAMS = muddle
 muddle_SOURCES = main.c read.c eval.c print.c alloc.c object.c atom.c oblist.c
 muddle_CFLAGS = -Wall -Wno-unused-function -Werror=implicit-function-declaration -Werror=incompatible-pointer-types
 
-TESTS = test_oblists test_bindings
+TESTS = test_oblists test_bindings test_sequences

diff --git a/src/eval.c b/src/eval.c
index fb116d327e347ca2529ba8b4418987cd36844955..253c8ec45f1833f9d3e39edf909f09819d5f6349 100644 (file)
--- a/src/eval.c
+++ b/src/eval.c
@@ -93,6 +93,8 @@ generic calls must perform wrapping
 
 static object *gval (atom_object * var);
 
+static void subr_NTH ();
+
 // Upon initial entry, `cf->args.body[0]` is the FORM, and
 // `ret` is the result of evaluating the FORM's first position.
 // Typically, the first position will be an ATOM, which is
@@ -127,13 +129,28 @@ call ()
          }
        if (val->type == EVALTYPE_SUBR)
          CALL_THEN_RET (val->subr.val.fn, new_tuple (args, argct));
+       if (val->type == EVALTYPE_FIX32 || val->type == EVALTYPE_FIX64)
+         {
+           pool_ptr p = as_list (&cf->args.body[0])->val.head;
+           object * args = cst;
+           *cst++ = *val;
+           cst++->pool = *POOL_OBJECT (POOL_OBJECT (p)->rest);
+           assert (!POOL_OBJECT (POOL_OBJECT (p)->rest)->rest);
+           CALL_THEN_RET (subr_NTH, new_tuple (args, 2));
+         }
        assert (0 && "I don't know how to call that");
        break;
-       /*
-          case EVALTYPE_FIX32:
-          case EVALTYPE_FIX64:
-          break;
-        */
+      }
+    case EVALTYPE_FIX32:
+    case EVALTYPE_FIX64:
+      {
+       pool_ptr p = as_list (&cf->args.body[0])->val.head;
+       object * args = cst;
+       *cst++ = ret;
+       assert (POOL_OBJECT (p)->rest);
+       cst++->pool = *POOL_OBJECT (POOL_OBJECT (p)->rest);
+       assert (!POOL_OBJECT (POOL_OBJECT (p)->rest)->rest);
+       CALL_THEN_RET (subr_NTH, new_tuple (args, 2));
       }
     default:
       assert (0 && "I don't know how to call that");
@@ -361,6 +378,47 @@ subr_add ()
   eval_arg ()? : appl_add ();
 }
 
+static void appl_NTH ()
+{
+  assert (cf->args.len == 2);
+  int ix;
+  switch (cf->args.body[0].type)
+    {
+    case EVALTYPE_FIX32:
+    case EVALTYPE_FIX64:
+      ix = cf->args.body[0].fix64.val.n;
+      assert ((uint64_t)ix == cf->args.body[0].fix64.val.n);
+      break;
+    default:
+      assert (0 && "tried to NTH a strange index type?");
+    }
+  switch (cf->args.body[1].type)
+    {
+    case EVALTYPE_VECTOR:
+      assert (ix < cf->args.body[1].vector.val.len);
+      RETURN (HEAP_OBJECT (cf->args.body[1].vector.val.body)[ix]);
+    case EVALTYPE_UVECTOR:
+      assert (ix < cf->args.body[1].uvector.val.len);
+      RETURN (uv_get (&cf->args.body[1].uvector, ix));
+    case EVALTYPE_LIST:
+      {
+       pool_ptr p = cf->args.body[1].list.val.head;
+       for (int i=0; i<ix; i++) {
+         assert (p);
+         p = POOL_OBJECT (p)->rest;
+       }
+       assert (p);
+       RETURN (*(object*)POOL_OBJECT (p));
+      }
+    }
+  assert (0 && "tried to NTH a strange collection type?");
+}
+
+void subr_NTH ()
+{
+  eval_arg ()? : appl_NTH ();
+}
+
 void
 init_standard_env ()
 {
@@ -370,6 +428,7 @@ init_standard_env ()
   create_global_binding (root, "QUOTE")->subr = new_subr (subr_quote);
   create_global_binding (root, "LIST")->subr = new_subr (subr_list);
   create_global_binding (root, "+")->subr = new_subr (subr_add);
+  create_global_binding (root, "NTH")->subr = new_subr (subr_NTH);
 }
 
 object *

diff --git a/src/object.c b/src/object.c
index af50edaa191905c920704fc29af899f3117bbc08..5b115c0b89ffbcfc78c5b9e249f8488d573aa25d 100644 (file)
--- a/src/object.c
+++ b/src/object.c
@@ -99,3 +99,10 @@ stack_push (vector_object * v)
   v->val.len++;
   return HEAP_OBJECT (--(v->val.body));
 }
+
+object
+uv_get (const uvector_object * o, uint32_t i)
+{
+  return (object)
+  {.type = utype (o),.uv_val = UV_VAL (o->val.body)[i]};
+}

diff --git a/src/object.h b/src/object.h
index 56f17b6425d598aee2174f1edcdd40cb66f0f2c5..1435f5d353098a0105296df4b9fe01ac116a996d 100644 (file)
--- a/src/object.h
+++ b/src/object.h
@@ -272,7 +272,11 @@ union object
     // NB. never take the address of these type-punned fields!
     alignas (16) evaltype type;
     opaque32 _unknown0;
-    opaque64 _unknown1;
+    union
+    {
+      opaque64 _unknown1;
+      uv_val uv_val;
+    };
   };
   /// objects of statically known type
   /// use as_X() for checked downcast
@@ -324,7 +328,6 @@ new_list (pool_ptr head)
   ,};
 }
 
-// TODO: take a dope_object like uvector
 static inline vector_object
 new_vector (heap_ptr body, uint32_t length)
 {
@@ -401,6 +404,10 @@ utype (const uvector_object * o)
   return uv_dope (o)->type;
 }
 
+object
+uv_get (const uvector_object * o, uint32_t i);
+
+
 // Change the EVALTYPE of an object. New type must have same PRIMTYPE.
 static inline void
 chtype (object * o, evaltype type)

diff --git a/src/test_sequences b/src/test_sequences
new file mode 100755 (executable)
index 0000000..a0f96a6
--- /dev/null
+++ b/src/test_sequences
@@ -0,0 +1,27 @@
+#!/bin/sh
+
+# Copyright (C) 2018 Keziah Wesley
+
+# You can redistribute and/or modify this file under the terms of the
+# GNU Affero General Public License as published by the Free Software
+# Foundation, either version 3 of the License, or (at your option) any
+# later version.
+
+# This file is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# Affero General Public License for more details.
+
+# You should have received a copy of the GNU Affero General Public
+# License along with this file. If not, see
+# <http://www.gnu.org/licenses/>.
+
+assert_eq () {
+    [ "$1" = "$2" ] || ( echo Assertion failed: "\"$1\"" = "\"$2\""; exit 1 )
+}
+
+assert_eq '1' "$(echo '<NTH 0 <LIST 1 2 3>>' | ./muddle)"
+assert_eq '1' "$(echo '<NTH 0 (1 2 3)>' | ./muddle)"
+assert_eq '1' "$(echo '<0 (1 2 3)>' | ./muddle)"
+assert_eq '1' "$(echo '<1 (0 1)>' | ./muddle)"
+assert_eq '(1 7)' "$(echo '(<SETG BAZ 1> <BAZ (4 7)>)' | ./muddle)"