diff options
| -rw-r--r-- | src/builtins.c | 38 | ||||
| -rw-r--r-- | src/interp.c | 6 | ||||
| -rw-r--r-- | src/primitives.c | 4 | ||||
| -rw-r--r-- | tests/eq.lisp | 27 | ||||
| -rw-r--r-- | tests/test.lisp | 1 |
5 files changed, 71 insertions, 5 deletions
diff --git a/src/builtins.c b/src/builtins.c index 9a35f52..198f80d 100644 --- a/src/builtins.c +++ b/src/builtins.c @@ -3,6 +3,44 @@ #include "sexp.h" #include <algds/str.h> +static bool equal_impl(Interp *interp, SExpRef x, SExpRef y) { + if (VALTYPE(x) != VALTYPE(y)) return false; + if (VALTYPE(x) == kIntegerSExp) { + return REF(x)->integer== REF(y)->integer; + } else if (VALTYPE(x) == kRealSExp) { + return REF(x)->real == REF(y)->real; + } else if (VALTYPE(x) == kStringSExp) { + return strcmp(REF(x)->str, REF(y)->str) == 0; + } else if (VALTYPE(x) == kPairSExp) { + return equal_impl(interp, REF(x)->pair.car, REF(y)->pair.car) + && equal_impl(interp, REF(x)->pair.cdr, REF(y)->pair.cdr); + } else if (VALTYPE(x) == kCharSExp) { + return REF(x)->character == REF(y)->character; + } else if (VALTYPE(x) == kUserDataSExp) { + return REF(x)->userdata == REF(y)->userdata; + } + return x.idx == y.idx; +} + +SExpRef builtin_eq(Interp *interp, SExpRef args) { + if (LENGTH(args) != 2) return new_error(interp, "eq: expect 2 args.\n"); + SExpRef x = CAR(args), y = CADR(args); + if (VALTYPE(x) != VALTYPE(y)) return new_boolean(interp, false); + if (VALTYPE(x) == kIntegerSExp + || VALTYPE(x) == kCharSExp + || VALTYPE(x) == kRealSExp) { + return new_boolean(interp, equal_impl(interp, x ,y)); + } + return new_boolean(interp, x.idx == y.idx); +} + + +SExpRef builtin_equal(Interp *interp, SExpRef args) { + if (LENGTH(args) != 2) return new_error(interp, "equal: expect 2 args.\n"); + SExpRef x = CAR(args), y = CADR(args); + return new_boolean(interp, equal_impl(interp, x, y)); +} + SExpRef builtin_format(Interp *interp, SExpRef args) { if (NILP(args)) { return new_error(interp, "format: too few arguments (missing format string).\n"); diff --git a/src/interp.c b/src/interp.c index f055bce..d7e06ed 100644 --- a/src/interp.c +++ b/src/interp.c @@ -86,6 +86,8 @@ void Interp_init(Interp *self) { Interp_add_primitive(self, "assert-error", primitive_assert_error); Interp_add_primitive(self, "load", primitive_load); + Interp_add_userfunc(self, "eq", builtin_eq); + Interp_add_userfunc(self, "equal", builtin_equal); Interp_add_userfunc(self, "format", builtin_format); Interp_add_userfunc(self, "concat", builtin_concat); Interp_add_userfunc(self, "error", builtin_error); @@ -627,8 +629,10 @@ SExpRef lisp_apply(Interp *interp, SExpRef fn, SExpRef args, bool istail) { iter = CDR(iter); } } else if (VALTYPE(fn) == kUserFuncSExp) { - LispUserFunc fnptr = REF(fn)->userfunc; + LispUserFunc fnptr = REF(fn)->userfunc; + PUSH_REG(args); ret = (*fnptr)(interp, args); + POP_REG(); return ret; } end: diff --git a/src/primitives.c b/src/primitives.c index 92e8110..a0a90a0 100644 --- a/src/primitives.c +++ b/src/primitives.c @@ -357,9 +357,7 @@ SExpRef primitive_funcall(Interp *interp, SExpRef args, bool istail) { if (LENGTH(args) < 1) goto error; args = lisp_eval_args(interp, args); if (CTL_FL(args)) return args; - PUSH_REG(args); SExpRef ret = lisp_apply(interp, CAR(args), CDR(args), istail); - POP_REG(); return ret; error: return new_error(interp, "funcall: syntax error.\n"); @@ -390,9 +388,7 @@ SExpRef primitive_apply(Interp *interp, SExpRef args, bool istail) { args = lisp_eval_args(interp, args); if (CTL_FL(args)) return args; if (!lisp_check_list(interp, CADR(args))) goto error; - PUSH_REG(args); ret = lisp_apply(interp, CAR(args), CADR(args), istail); - POP_REG(); return ret; error: return new_error(interp, "apply: syntax error.\n"); diff --git a/tests/eq.lisp b/tests/eq.lisp new file mode 100644 index 0000000..4db31ce --- /dev/null +++ b/tests/eq.lisp @@ -0,0 +1,27 @@ +(assert-error (eq 1 2 3)) +(assert-error (equal 1 2 3)) + +(assert (eq 1 1)) +(assert (eq 'a 'a)) +(assert (eq 1.0 1.0)) +(assert (eq #\a #\a)) +(assert (eq #f #f)) +(assert (eq nil nil)) +(assert (eq #t #t)) +(assert (not (eq 1 2))) +(assert (not (eq "a" "a"))) +(assert (not (eq 'a 'b))) +(assert (not (eq '(1 2) '(1 2)))) + +(assert (equal 1 1)) +(assert (equal 'a 'a)) +(assert (equal "a" "a")) +(assert (equal 1.0 1.0)) +(assert (equal #\a #\a)) +(assert (equal #f #f)) +(assert (equal '(1 2) '(1 2))) + +(assert (not (equal 1 2))) +(assert (not (equal 'a 'b))) +(assert (not (equal "a" "b"))) +(assert (not (equal '(1 2 3) '(1 2)))) diff --git a/tests/test.lisp b/tests/test.lisp index 4ca2964..797fc0d 100644 --- a/tests/test.lisp +++ b/tests/test.lisp @@ -4,6 +4,7 @@ (load (format "%s.lisp" ,name)) (princ (format "[PASS] %s\n" ,name)))) +(test-module "eq") (test-module "arithmetic") (test-module "error") (test-module "logic") |