aboutsummaryrefslogtreecommitdiff
path: root/src/primitives.c
diff options
context:
space:
mode:
Diffstat (limited to 'src/primitives.c')
-rw-r--r--src/primitives.c142
1 files changed, 89 insertions, 53 deletions
diff --git a/src/primitives.c b/src/primitives.c
index 8958842..1cee577 100644
--- a/src/primitives.c
+++ b/src/primitives.c
@@ -3,10 +3,12 @@
#include "sexp.h"
SExpRef primitive_if(Interp *interp, SExpRef args) {
+ SExpRef cond, tb, fb;
+
if (lisp_length(interp, args) != 3) goto error;
- SExpRef cond = CAR(args);
- SExpRef tb = CADR(args);
- SExpRef fb = CADDR(args);
+ cond = CAR(args);
+ tb = CADR(args);
+ fb = CADDR(args);
cond = EVAL(cond);
if (ERRORP(cond)) return cond;
if (TRUEP(cond)) return EVAL(tb);
@@ -17,14 +19,16 @@ error:
}
SExpRef primitive_cond(Interp *interp, SExpRef args) {
+ SExpRef pair, condition, exp, iter;
+
if (lisp_length(interp, args) < 1) goto error;
- SExpRef iter = args;
+ iter = args;
while (!NILP(iter)) {
- SExpRef pair = CAR(iter);
+ pair = CAR(iter);
if (!lisp_check_list(interp, pair)) goto error;
if (lisp_length(interp, pair) != 2) goto error;
- SExpRef condition = CAR(pair);
- SExpRef exp = CADR(pair);
+ condition = CAR(pair);
+ exp = CADR(pair);
condition = EVAL(condition);
if (ERRORP(condition)) return condition;
if (TRUEP(condition)) return EVAL(exp);
@@ -38,6 +42,7 @@ error:
SExpRef primitive_progn(Interp *interp, SExpRef args) {
SExpRef iter = args;
SExpRef ret;
+
while (!NILP(iter)) {
ret = EVAL(CAR(iter));
if (ERRORP(ret)) return ret;
@@ -47,11 +52,13 @@ SExpRef primitive_progn(Interp *interp, SExpRef args) {
}
SExpRef primitive_setq(Interp *interp, SExpRef args) {
+ SExpRef name, exp, value;
+
if (lisp_length(interp, args) != 2) goto error;
- SExpRef name = CAR(args);
- SExpRef exp = CADR(args);
+ name = CAR(args);
+ exp = CADR(args);
if (REF(name)->type != kSymbolSExp) goto error;
- SExpRef value = EVAL(exp);
+ value = EVAL(exp);
if (ERRORP(value)) return value;
return lisp_setq(interp, REF(name)->str, value);
error:
@@ -65,6 +72,7 @@ static const char *binding_name(Interp *interp, SExpRef binding) {
static bool is_binding_repeat(Interp *interp, SExpRef sym, SExpRef env) {
SExpRef binding = REF(env)->env.bindings;
+
while (!NILP(binding)) {
if (strcmp(REF(sym)->str, binding_name(interp, binding)) == 0) return true;
binding = REF(binding)->binding.next;
@@ -73,40 +81,43 @@ static bool is_binding_repeat(Interp *interp, SExpRef sym, SExpRef env) {
}
SExpRef primitive_let(Interp *interp, SExpRef args) {
+ SExpRef binding, iter, bindings, env, x,
+ val, body, ret, exp;
+
if (lisp_length(interp, args) < 1) goto error;
- SExpRef bindings = CAR(args);
- SExpRef env = new_env(interp);
+ bindings = CAR(args);
+ env = new_env(interp);
REF(env)->env.parent = CAR(interp->stack);
- SExpRef iter = bindings;
+ iter = bindings;
while (!NILP(iter)) {
- SExpRef x = CAR(iter);
+ x = CAR(iter);
if (!lisp_check_list(interp, x)) goto error;
if (lisp_length(interp, x) != 2) goto error;
if (REF(CAR(x))->type != kSymbolSExp) goto error;
if (is_binding_repeat(interp, CAR(x), env)) goto error;
- SExpRef binding = new_binding(interp, CAR(x), NIL);
+ binding = new_binding(interp, CAR(x), NIL);
REF(binding)->binding.next = REF(env)->env.bindings;
REF(env)->env.bindings = binding;
iter = CDR(iter);
}
interp->stack = CONS(env, interp->stack);
- SExpRef ret = NIL;
+ ret = NIL;
iter = bindings;
while (!NILP(iter)) {
- SExpRef x = CAR(iter);
- SExpRef val = EVAL(CADR(x));
+ x = CAR(iter);
+ val = EVAL(CADR(x));
if (REF(val)->type == kErrSExp) goto end;
ret = lisp_setq(interp, REF(CAR(x))->str, val);
if (ERRORP(ret)) goto end;
iter = CDR(iter);
}
- SExpRef body = CDR(args);
+ body = CDR(args);
iter = body;
while (!NILP(iter)) {
- SExpRef exp = CAR(iter);
+ exp = CAR(iter);
ret = EVAL(exp);
if (REF(ret)->type == kErrSExp) goto end;
iter = CDR(iter);
@@ -120,17 +131,19 @@ error:
}
SExpRef primitive_while(Interp *interp, SExpRef args) {
+ SExpRef ret, pred, body, cond, iter, x;
+
if (lisp_length(interp, args) < 2) goto error;
- SExpRef ret = NIL;
- SExpRef pred = CAR(args);
- SExpRef body = CDR(args);
+ ret = NIL;
+ pred = CAR(args);
+ body = CDR(args);
while (1) {
- SExpRef cond = EVAL(pred);
+ cond = EVAL(pred);
if (ERRORP(cond)) return cond;
if (!TRUEP(cond)) return ret;
- SExpRef iter = body;
+ iter = body;
while (!NILP(iter)) {
- SExpRef x = CAR(iter);
+ x = CAR(iter);
ret = EVAL(x);
if (ERRORP(ret)) return ret;
iter = CDR(iter);
@@ -141,40 +154,46 @@ error:
}
SExpRef primitive_lambda(Interp *interp, SExpRef args) {
+ SExpRef env, param, body;
+
if (lisp_length(interp, args) < 2) goto error;
- SExpRef env = CAR(interp->stack);
- SExpRef param = CAR(args);
- SExpRef body = CDR(args);
+ env = CAR(interp->stack);
+ param = CAR(args);
+ body = CDR(args);
return new_lambda(interp, param, body, env);
error:
return new_error(interp, "lambda: syntax error.\n");
}
SExpRef primitive_defun(Interp *interp, SExpRef args) {
+ SExpRef name, param, body, function;
+
if (lisp_length(interp, args) < 3) goto error;
if (CAR(interp->stack).idx != interp->top_level.idx) {
return new_error(interp, "defun: functions can only be defined in top level.\n");
}
- SExpRef name = CAR(args);
+ name = CAR(args);
if (VALTYPE(name) != kSymbolSExp) goto error;
- SExpRef param = CADR(args);
- SExpRef body = CDDR(args);
- SExpRef function = new_lambda(interp, param, body, interp->top_level);
+ param = CADR(args);
+ body = CDDR(args);
+ function = new_lambda(interp, param, body, interp->top_level);
lisp_defun(interp, REF(name)->str, function);
return name;
error:
return new_error(interp, "defun: syntax error.\n");
}
SExpRef primitive_defmacro(Interp *interp, SExpRef args) {
+ SExpRef param, name, body, macro;
+
if (lisp_length(interp, args) < 3) goto error;
if (CAR(interp->stack).idx != interp->top_level.idx) {
return new_error(interp, "defmacro: macros can only be defined in top level.\n");
}
- SExpRef name = CAR(args);
+ name = CAR(args);
if (VALTYPE(name) != kSymbolSExp) goto error;
- SExpRef param = CADR(args);
- SExpRef body = CDDR(args);
- SExpRef macro = new_macro(interp, param, body);
+ param = CADR(args);
+ body = CDDR(args);
+ macro = new_macro(interp, param, body);
lisp_defun(interp, REF(name)->str, macro);
return name;
error:
@@ -182,14 +201,16 @@ error:
}
SExpRef primitive_defvar(Interp *interp, SExpRef args) {
+ SExpRef name, exp, val;
+
if (lisp_length(interp, args) != 2) goto error;
if (CAR(interp->stack).idx != interp->top_level.idx) {
return new_error(interp, "defvar: functions can only be defined in top level.\n");
}
- SExpRef name = CAR(args);
+ name = CAR(args);
if (VALTYPE(name) != kSymbolSExp) goto error;
- SExpRef exp = CADR(args);
- SExpRef val = EVAL(exp);
+ exp = CADR(args);
+ val = EVAL(exp);
if (ERRORP(val)) return val;
lisp_defvar(interp, REF(name)->str, val);
return name;
@@ -210,19 +231,21 @@ static SExpRef build_function_env(Interp *interp, SExpRef func, SExpRef args) {
SExpRef iparam = param;
SExpRef iargs = args;
SExpRef env = new_env(interp);
+ SExpRef binding, name;
+
while (!NILP(iparam)) {
if (VALTYPE(iparam) == kSymbolSExp) {
- SExpRef binding = new_binding(interp, iparam, iargs);
+ binding = new_binding(interp, iparam, iargs);
REF(binding)->binding.next = REF(env)->env.bindings;
REF(env)->env.bindings = binding;
return env;
}
- SExpRef name = CAR(iparam);
+ name = CAR(iparam);
if (VALTYPE(name) != kSymbolSExp) {
return new_error(interp, "function syntax error: parameter must be a symbol.\n");
}
if (NILP(iargs)) return new_error(interp, "funcall: wrong argument number.\n");
- SExpRef binding = new_binding(interp, name, CAR(iargs));
+ binding = new_binding(interp, name, CAR(iargs));
REF(binding)->binding.next = REF(env)->env.bindings;
REF(env)->env.bindings = binding;
iargs = CDR(iargs);
@@ -247,10 +270,12 @@ SExpRef primitive_quote(Interp *interp, SExpRef args) {
}
SExpRef primitive_macroexpand1(Interp *interp, SExpRef args) {
+ SExpRef macro;
+
if (lisp_length(interp, args) != 1) goto error;
args = CAR(args);
if (VALTYPE(CAR(args)) != kSymbolSExp) goto error;
- SExpRef macro = lisp_lookup_func(interp, REF(CAR(args))->str);
+ macro = lisp_lookup_func(interp, REF(CAR(args))->str);
if (VALTYPE(macro) != kMacroSExp) goto error;
return lisp_macroexpand1(interp, macro, CDR(args));
error:
@@ -258,11 +283,16 @@ error:
}
SExpRef primitive_apply(Interp *interp, SExpRef args) {
+ SExpRef ret;
+
if (lisp_length(interp, args) != 2) goto error;
args = lisp_eval_args(interp, args);
if (ERRORP(args)) return args;
if (!lisp_check_list(interp, CADR(args))) goto error;
- return lisp_apply(interp, CAR(args), CADR(args));
+ PUSH_REG(args);
+ ret = lisp_apply(interp, CAR(args), CADR(args));
+ POP_REG();
+ return ret;
error:
return new_error(interp, "apply: syntax error.\n");
}
@@ -271,6 +301,8 @@ static SExpRef quasi_on_list(Interp *interp, SExpRef lst);
static SExpRef quasi_impl(Interp *interp, SExpRef obj, bool *slicing);
static SExpRef quasi_impl(Interp *interp, SExpRef obj, bool *slicing) {
+ SExpRef lst;
+
*slicing = false;
if (VALTYPE(obj) != kPairSExp) return obj;
if (VALTYPE(CAR(obj)) == kSymbolSExp
@@ -282,7 +314,7 @@ static SExpRef quasi_impl(Interp *interp, SExpRef obj, bool *slicing) {
}
if (VALTYPE(CAR(obj)) == kSymbolSExp
&& strcmp("slicing-unquote", REF(CAR(obj))->str) == 0) {
- SExpRef lst = EVAL(CADR(obj));
+ lst = EVAL(CADR(obj));
if (ERRORP(lst)) return lst;
if (lisp_length(interp, obj) != 2) {
return new_error(interp, "slicing-unquote: syntax error.\n");
@@ -298,14 +330,16 @@ static SExpRef quasi_impl(Interp *interp, SExpRef obj, bool *slicing) {
static SExpRef quasi_on_list(Interp *interp, SExpRef lst) {
SExpRef newlst = NIL;
+ SExpRef iter, j, x, newx;
+
bool slicing;
- SExpRef iter = lst;
+ iter = lst;
while (!NILP(iter)) {
- SExpRef x = CAR(iter);
- SExpRef newx = quasi_impl(interp, x, &slicing);
+ x = CAR(iter);
+ newx = quasi_impl(interp, x, &slicing);
if (ERRORP(newx)) return newx;
if (slicing) {
- SExpRef j = newx;
+ j = newx;
while (!NILP(j)) {
newlst = CONS(CAR(j), newlst);
j = CDR(j);
@@ -320,17 +354,18 @@ static SExpRef quasi_on_list(Interp *interp, SExpRef lst) {
}
SExpRef primitive_quasi(Interp *interp, SExpRef args) {
+ SExpRef ret;
if (lisp_length(interp, args) != 1) return new_error(interp, "quasiquote: syntax error.\n");
bool slicing;
- SExpRef ret = quasi_impl(interp, CAR(args), &slicing);
+ ret = quasi_impl(interp, CAR(args), &slicing);
if (slicing) return new_error(interp, "quasiquote: syntax error.\n");
return ret;
}
SExpRef primitive_and(Interp *interp, SExpRef args) {
- if (lisp_length(interp, args) < 1) return new_error(interp, "and: syntax error.\n");
SExpRef ret;
SExpRef i = args;
+ if (lisp_length(interp, args) < 1) return new_error(interp, "and: syntax error.\n");
while (!NILP(i)) {
ret = EVAL(CAR(i));
if (!TRUEP(ret)) return ret;
@@ -340,9 +375,10 @@ SExpRef primitive_and(Interp *interp, SExpRef args) {
}
SExpRef primitive_or(Interp *interp, SExpRef args) {
- if (lisp_length(interp, args) < 1) return new_error(interp, "or: syntax error.\n");
SExpRef ret;
SExpRef i = args;
+
+ if (lisp_length(interp, args) < 1) return new_error(interp, "or: syntax error.\n");
while (!NILP(i)) {
ret = EVAL(CAR(i));
if (TRUEP(ret)) return ret;
generated by cgit v1.0 at 2025-12-29 21:05:15 +0000