X-Git-Url: https://jxself.org/git/?a=blobdiff_plain;f=src%2Feval.c;h=253c8ec45f1833f9d3e39edf909f09819d5f6349;hb=refs%2Fheads%2Fmaster;hp=fb116d327e347ca2529ba8b4418987cd36844955;hpb=4b917a1f5fe2af0245454fe6be14710b2c24a475;p=muddle-interpreter.git

diff --git a/src/eval.c b/src/eval.c
index fb116d3..253c8ec 100644
--- 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 *