Mercurial > libjeffpc
view sexpr_eval.c @ 810:cb643e3ad672
sexpr: use size_t in sexpr lexer input function
Signed-off-by: Josef 'Jeff' Sipek <jeffpc@josefsipek.net>
author | Josef 'Jeff' Sipek <jeffpc@josefsipek.net> |
---|---|
date | Sat, 18 Jul 2020 10:07:34 -0400 |
parents | b1e4c7607050 |
children |
line wrap: on
line source
/* * Copyright (c) 2016-2018 Josef 'Jeff' Sipek <jeffpc@josefsipek.net> * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to deal * in the Software without restriction, including without limitation the rights * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell * copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE * SOFTWARE. */ #include <jeffpc/sexpr.h> struct builtin_fxn { const char *name; struct val *(*f)(struct val *args, struct sexpr_eval_env *env); /* expected number of arguments; -1 indicates any length is ok */ ssize_t arglen; }; #define __REDUCE(fname, alloc, t, valmember, ctype, ident, op) \ static struct val *fname(struct val *args, struct sexpr_eval_env *env) \ { \ ctype ret = (ident); \ \ while (args) { \ struct val *el = sexpr_car(val_getref(args)); \ struct val *next = sexpr_cdr(args); \ \ while (el && (el->type == VT_CONS || el->type == VT_SYM)) \ el = sexpr_eval(el, env); \ \ ASSERT(el); \ ASSERT3U(el->type, ==, t); \ \ ret = ret op el->valmember; \ \ val_putref(el); \ args = next; \ } \ \ return alloc(ret); \ } #define BOOL_REDUCE(fname, ident, op) \ __REDUCE(fname, VAL_ALLOC_BOOL, VT_BOOL, b, bool, ident, op) BOOL_REDUCE(fxn_or, false, ||) BOOL_REDUCE(fxn_and, true, &&) #define INT_REDUCE(fname, ident, op) \ __REDUCE(fname, VAL_ALLOC_INT, VT_INT, i, uint64_t, ident, op) INT_REDUCE(fxn_add, 0, +) INT_REDUCE(fxn_mult, 1, *) static struct val *fxn_quote(struct val *args, struct sexpr_eval_env *env) { return sexpr_car(args); } static struct val *fxn_cxr(struct val *args, struct sexpr_eval_env *env, struct val *(*cxr)(struct val *)) { /* * The args argument contains the cdr of the whole expression. For * example, if we tried to evaluate: * * (car '(a b)) * * aka. * * (car (quote (a b))) * * args will contain: * * ((quote (a b))) * * That is why we do a car on it first before calling eval. * * Note: This makes sense because in general functions can take any * number of arguments - it's just that car and cdr take only one. * So, we need to take the first element of the list of arguments - * and we get that by calling car. */ return cxr(sexpr_eval(sexpr_car(args), env)); } static struct val *fxn_car(struct val *args, struct sexpr_eval_env *env) { return fxn_cxr(args, env, sexpr_car); } static struct val *fxn_cdr(struct val *args, struct sexpr_eval_env *env) { return fxn_cxr(args, env, sexpr_cdr); } static struct val *fxn_equal(struct val *args, struct sexpr_eval_env *env) { struct val *a, *b; a = sexpr_eval(sexpr_nth(val_getref(args), 1), env); b = sexpr_eval(sexpr_nth(args, 2), env); return VAL_ALLOC_BOOL(sexpr_equal(a, b)); } static struct val *fxn_if(struct val *args, struct sexpr_eval_env *env) { struct val *c; struct val *t, *f; struct val *ret; c = sexpr_nth(val_getref(args), 1); t = sexpr_nth(val_getref(args), 2); f = sexpr_nth(args, 3); c = sexpr_eval(c, env); VERIFY3U(c->type, ==, VT_BOOL); ret = c->b ? val_getref(t) : val_getref(f); val_putref(c); val_putref(t); val_putref(f); return sexpr_eval(ret, env); } static struct builtin_fxn builtins[] = { { "and", fxn_and, -1, }, { "or", fxn_or, -1, }, { "+", fxn_add, -1, }, { "*", fxn_mult, -1, }, { "quote", fxn_quote, 1, }, { "car", fxn_car, 1, }, { "cdr", fxn_cdr, 1, }, { "=", fxn_equal, 2, }, { "==", fxn_equal, 2, }, { "if", fxn_if, 3, }, { NULL, }, }; static struct builtin_fxn *fxnlookup_builtin(struct sym *name) { size_t i; for (i = 0; builtins[i].name; i++) if (!strcmp(builtins[i].name, sym_cstr(name))) return &builtins[i]; return NULL; } static struct val *eval_cons(struct val *expr, struct sexpr_eval_env *env) { struct builtin_fxn *fxn; struct sym *name; struct val *args; struct val *op; op = sexpr_car(val_getref(expr)); args = sexpr_cdr(expr); ASSERT(op); switch (op->type) { case VT_NULL: panic("function name cannot be a VT_NULL"); case VT_INT: panic("function name cannot be a VT_INT (%"PRIu64")", op->i); case VT_CHAR: panic("function name cannot be a VT_CHAR (%"PRIu64")", op->i); case VT_STR: panic("function name cannot be a VT_STR (\"%s\")", val_cstr(op)); case VT_BOOL: panic("function name cannot be a VT_BOOL (%s)", op->b ? "true" : "false"); case VT_CONS: panic("function name cannot be a VT_CONS"); case VT_BLOB: panic("function name cannot be a VT_BLOB"); case VT_ARRAY: panic("function name cannot be a VT_ARRAY"); case VT_NVL: panic("function name cannot be a VT_NVL"); case VT_SYM: break; /* ok */ } name = val_cast_to_sym(op); if (env->fxnlookup) { fxn = env->fxnlookup(name, env); if (fxn) goto found; } fxn = fxnlookup_builtin(name); if (fxn) goto found; panic("unknown function '%s'", sym_cstr(name)); found: sym_putref(name); if (fxn->arglen != -1) { size_t got; got = sexpr_length(val_getref(args)); if (got != fxn->arglen) panic("'%s' not given the right number of arguments " "(expected %zd, got %zu)", fxn->name, fxn->arglen, got); } return fxn->f(args, env); } struct val *sexpr_eval(struct val *expr, struct sexpr_eval_env *env) { static struct sexpr_eval_env emptyenv; if (!expr) return NULL; if (!env) env = &emptyenv; switch (expr->type) { case VT_NULL: case VT_INT: case VT_STR: case VT_BOOL: case VT_CHAR: case VT_BLOB: case VT_ARRAY: case VT_NVL: return expr; case VT_SYM: if (!env->symlookup) panic("VT_SYM requires non-NULL symlookup " "function in the environment"); /* * Symbol lookup returns a value (not an expression) * therefore we don't want to evaluate it. */ return env->symlookup(val_cast_to_sym(expr), env); case VT_CONS: return eval_cons(expr, env); } panic("impossible!"); }