Implement NTH.

[muddle-interpreter.git] / src / eval.c

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 *