From e3dcc1d3966fb95a5a232daa193c6b5d89a06b7e Mon Sep 17 00:00:00 2001 From: Kaz Wesley Date: Fri, 9 Feb 2018 18:57:14 -0800 Subject: [PATCH] Implement NTH. Signed-off-by: Kaz Wesley --- src/Makefile.am | 2 +- src/eval.c | 69 ++++++++++++++++++++++++++++++++++++++++++---- src/object.c | 7 +++++ src/object.h | 11 ++++++-- src/test_sequences | 27 ++++++++++++++++++ 5 files changed, 108 insertions(+), 8 deletions(-) create mode 100755 src/test_sequences diff --git a/src/Makefile.am b/src/Makefile.am index 50723bd..34bbd88 100644 --- 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 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; irest; + } + 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 af50eda..5b115c0 100644 --- 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 56f17b6..1435f5d 100644 --- 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 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 +# . + +assert_eq () { + [ "$1" = "$2" ] || ( echo Assertion failed: "\"$1\"" = "\"$2\""; exit 1 ) +} + +assert_eq '1' "$(echo '>' | ./muddle)" +assert_eq '1' "$(echo '' | ./muddle)" +assert_eq '1' "$(echo '<0 (1 2 3)>' | ./muddle)" +assert_eq '1' "$(echo '<1 (0 1)>' | ./muddle)" +assert_eq '(1 7)' "$(echo '( )' | ./muddle)" -- 2.31.1