diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/builtins.c | 1462 | ||||
| -rw-r--r-- | src/builtins.h | 122 | ||||
| -rw-r--r-- | src/interp.c | 1175 | ||||
| -rw-r--r-- | src/interp.h | 135 | ||||
| -rw-r--r-- | src/main.c | 74 | ||||
| -rw-r--r-- | src/parser.c | 483 | ||||
| -rw-r--r-- | src/parser.h | 66 | ||||
| -rw-r--r-- | src/prelude.c | 6 | ||||
| -rw-r--r-- | src/prelude.h | 7 | ||||
| -rw-r--r-- | src/prelude.lisp | 132 | ||||
| -rw-r--r-- | src/primitives.c | 576 | ||||
| -rw-r--r-- | src/primitives.h | 35 | ||||
| -rw-r--r-- | src/sexp.c | 12 | ||||
| -rw-r--r-- | src/sexp.h | 125 | ||||
| -rw-r--r-- | src/vector.c | 128 | ||||
| -rw-r--r-- | src/vector.h | 8 |
16 files changed, 0 insertions, 4546 deletions
diff --git a/src/builtins.c b/src/builtins.c deleted file mode 100644 index efad674..0000000 --- a/src/builtins.c +++ /dev/null @@ -1,1462 +0,0 @@ -#include "builtins.h" -#include "interp.h" -#include "sexp.h" -#include <algds/str.h> -#include <ctype.h> -#include <stdint.h> -#include <float.h> -#include <math.h> - -SExpRef builtin_throw(Interp *interp, SExpRef args) { - if (LENGTH(args) != 1) return new_error(interp, "throw: syntax error.\n"); - return new_exception(interp, CAR(args)); -} - -SExpRef builtin_functionp(Interp *interp, SExpRef args) { - if (LENGTH(args) != 1) { - return new_error(interp, "function?: args num error.\n"); - } - return new_boolean(interp, VALTYPE(CAR(args)) == kFuncSExp - || VALTYPE(CAR(args)) == kUserFuncSExp); -} - -SExpRef builtin_setnth(Interp *interp, SExpRef args) { - if (LENGTH(args) != 3) { - return new_error(interp, "set-nth: args num error.\n"); - } - SExpRef n = CAR(args), lst = CADR(args), elem = CADDR(args); - if (VALTYPE(n) != kIntegerSExp) return new_error(interp, "set-nth: type error.\n"); - if (VALTYPE(lst) == kPairSExp) { - if (REF(n)->integer >= LENGTH(lst)) { - return new_error(interp, "nth: out of bound.\n"); - } - for (int i = 0; i < REF(n)->integer; i++) { - lst = CDR(lst); - } - return REF(lst)->pair.car = elem; - return NIL; - } else if (VALTYPE(lst) == kStringSExp) { - if (REF(n)->integer >= strlen(REF(lst)->str)) { - return new_error(interp, "nth: out of bound\n"); - } - if (VALTYPE(elem) != kCharSExp) { - return new_error(interp, "set-nth: type error.\n"); - } - ((char*)REF(lst)->str)[REF(n)->integer] = REF(elem)->character; - return NIL; - } else { - return new_error(interp, "nth: type error.\n"); - } -} - -SExpRef builtin_setnthcdr(Interp *interp, SExpRef args) { - if (LENGTH(args) != 3) { - return new_error(interp, "set-nthcdr: args num error.\n"); - } - SExpRef n = CAR(args), lst = CADR(args), elem = CADDR(args); - if (VALTYPE(n) != kIntegerSExp) return new_error(interp, "set-nthcdr: type error.\n"); - if (VALTYPE(lst) == kPairSExp) { - if (REF(n)->integer >= LENGTH(lst)) { - return new_error(interp, "set-nthcdr: out of bound.\n"); - } - for (int i = 0; i < REF(n)->integer; i++) { - lst = CDR(lst); - } - return REF(lst)->pair.cdr = elem; - return NIL; - } - return new_error(interp, "set-nthcdr: type error.\n"); - -} - -SExpRef builtin_foldl(Interp *interp, SExpRef args) { - if (LENGTH(args) != 3) { - return new_error(interp, "foldl: args num error.\n"); - } - SExpRef fn = CAR(args), init = CADR(args), lst = CADDR(args); - SExpRef ret = init; - if (!CALLABLE(fn)) { - return new_error(interp, "foldl: type error.\n"); - } - if (!lisp_check_list(interp, lst)) { - return new_error(interp, "foldl: type error.\n"); - } - for (SExpRef i = lst ; !NILP(i); i = CDR(i)) { - SExpRef x = CAR(i); - ret = lisp_call(interp, fn, new_list2(interp, ret, x)); - if (CTL_FL(ret)) { - return ret; - } - } - return ret; -} - -SExpRef builtin_append(Interp *interp, SExpRef args) { - for (SExpRef l = args; !NILP(l); l = CDR(l)) { - if (!lisp_check_list(interp, l)) { - return new_error(interp, "append: type error.\n"); - } - } - SExpRef newlst = NIL; - for (SExpRef i = args; !NILP(i); i = CDR(i)) { - for (SExpRef j = CAR(i); !NILP(j); j = CDR(j)) { - newlst = CONS(CAR(j), newlst); - } - } - return lisp_nreverse(interp, newlst); -} - -SExpRef builtin_nconc(Interp *interp, SExpRef args) { - if (LENGTH(args) != 2) { - return new_error(interp, "nconc: args num error.\n"); - } - SExpRef l1 = CAR(args), l2= CADR(args); - if (!lisp_check_list(interp, l1) || !lisp_check_list(interp, l2)) { - return new_error(interp, "nconc: type error.\n"); - } - SExpRef last = NIL; - for (SExpRef i = l1; !NILP(i); i = CDR(i)) { - if (NILP(CDR(i))) { - last = i; - } - } - if (NILP(last)) return l2; - REF(last)->pair.cdr = l2; - return l1; -} - -SExpRef builtin_logand(Interp *interp, SExpRef args) { - if (LENGTH(args) < 1) { - return new_error(interp, "logand: args num error.\n"); - } - for (SExpRef l = args; !NILP(l); l = CDR(l)) { - if (VALTYPE(CAR(l)) != kIntegerSExp) { - return new_error(interp, "logand: type error.\n"); - } - } - uint64_t res = 0xffffffffffffffffULL; - for (SExpRef l = args; !NILP(l); l = CDR(l)) { - res = res & (REF(CAR(l))->integer); - } - return new_integer(interp, res); -} - -SExpRef builtin_logior(Interp *interp, SExpRef args) { - if (LENGTH(args) < 1) { - return new_error(interp, "logior: args num error.\n"); - } - for (SExpRef l = args; !NILP(l); l = CDR(l)) { - if (VALTYPE(CAR(l)) != kIntegerSExp) { - return new_error(interp, "logior: type error.\n"); - } - } - uint64_t res = 0; - for (SExpRef l = args; !NILP(l); l = CDR(l)) { - res = res | (REF(CAR(l))->integer); - } - return new_integer(interp, res); -} - -SExpRef builtin_logxor(Interp *interp, SExpRef args) { - if (LENGTH(args) < 1) { - return new_error(interp, "logxor: args num error.\n"); - } - for (SExpRef l = args; !NILP(l); l = CDR(l)) { - if (VALTYPE(CAR(l)) != kIntegerSExp) { - return new_error(interp, "logxor: type error.\n"); - } - } - uint64_t res = 0; - for (SExpRef l = args; !NILP(l); l = CDR(l)) { - res = res ^ (REF(CAR(l))->integer); - } - return new_integer(interp, res); -} - -SExpRef builtin_lognot(Interp *interp, SExpRef args) { - if (LENGTH(args) != 1) { - return new_error(interp, "lognot: args num error.\n"); - } - SExpRef x = CAR(args); - if (VALTYPE(x) != kIntegerSExp) { - return new_error(interp, "lognot: type error.\n"); - } - uint64_t res = 0; - res = ~(REF(x)->integer); - return new_integer(interp, res); -} - -SExpRef builtin_lsh(Interp *interp, SExpRef args) { - if (LENGTH(args) != 2) { - return new_error(interp, "lsh: args num error.\n"); - } - SExpRef x = CAR(args), n = CADR(args); - if (VALTYPE(x) != kIntegerSExp) { - return new_error(interp, "lsh: type error.\n"); - } - if (VALTYPE(n) != kIntegerSExp) { - return new_error(interp, "lsh: type error.\n"); - } - uint64_t res = 0; - res = (REF(x)->integer) << (REF(n)->integer); - return new_integer(interp, res); -} - -SExpRef builtin_ash(Interp *interp, SExpRef args) { - if (LENGTH(args) != 2) { - return new_error(interp, "ash: args num error.\n"); - } - SExpRef x = CAR(args), n = CADR(args); - if (VALTYPE(x) != kIntegerSExp) { - return new_error(interp, "ash: type error.\n"); - } - if (VALTYPE(n) != kIntegerSExp) { - return new_error(interp, "ash: type error.\n"); - } - int64_t res = 0; - res = (REF(x)->integer) >> (REF(n)->integer); - return new_integer(interp, res); -} - -SExpRef builtin_charp(Interp *interp, SExpRef args) { - if (LENGTH(args) != 1) return new_error(interp, "char?: arg num error.\n"); - return new_boolean(interp, VALTYPE(CAR(args)) == kCharSExp); -} - -SExpRef builtin_char_eq(Interp *interp, SExpRef args) { - if (LENGTH(args) != 2) return new_error(interp, "char=: arg num error.\n"); - if (VALTYPE(CAR(args)) != kCharSExp || VALTYPE(CADR(args)) != kCharSExp) { - return new_error(interp, "char=: type error.\n"); - } - char a = REF(CAR(args))->character; - char b = REF(CADR(args))->character; - return new_boolean(interp, a == b); -} - -SExpRef builtin_char_gt(Interp *interp, SExpRef args) { - if (LENGTH(args) != 2) return new_error(interp, "char>: arg num error.\n"); - if (VALTYPE(CAR(args)) != kCharSExp || VALTYPE(CADR(args)) != kCharSExp) { - return new_error(interp, "char>: type error.\n"); - } - char a = REF(CAR(args))->character; - char b = REF(CADR(args))->character; - return new_boolean(interp, a > b); -} - -SExpRef builtin_char_lt(Interp *interp, SExpRef args) { - if (LENGTH(args) != 2) return new_error(interp, "char<: arg num error.\n"); - if (VALTYPE(CAR(args)) != kCharSExp || VALTYPE(CADR(args)) != kCharSExp) { - return new_error(interp, "char<: type error.\n"); - } - char a = REF(CAR(args))->character; - char b = REF(CADR(args))->character; - return new_boolean(interp, a < b); -} -#undef FUNC - -SExpRef builtin_char_ge(Interp *interp, SExpRef args) { - if (LENGTH(args) != 2) return new_error(interp, "char>=: arg num error."); - if (VALTYPE(CAR(args)) != kCharSExp || VALTYPE(CADR(args)) != kCharSExp) { - return new_error(interp, "char>=: type error.\n"); - } - char a = REF(CAR(args))->character; - char b = REF(CADR(args))->character; - return new_boolean(interp, a >= b); -} - -SExpRef builtin_char_le(Interp *interp, SExpRef args) { - if (LENGTH(args) != 2) return new_error(interp, "char<=: arg num error.\n"); - if (VALTYPE(CAR(args)) != kCharSExp || VALTYPE(CADR(args)) != kCharSExp) { - return new_error(interp, "char<=: type error.\n"); - } - char a = REF(CAR(args))->character; - char b = REF(CADR(args))->character; - return new_boolean(interp, a <= b); -} -#undef FUNC - -SExpRef builtin_char_neq(Interp *interp, SExpRef args) { - if (LENGTH(args) != 2) return new_error(interp, "char/=: arg num error.\n"); - if (VALTYPE(CAR(args)) != kCharSExp || VALTYPE(CADR(args)) != kCharSExp) { - return new_error(interp, "char/=: type error.\n"); - } - char a = REF(CAR(args))->character; - char b = REF(CADR(args))->character; - return new_boolean(interp, a != b); -} - -SExpRef builtin_char2int(Interp *interp, SExpRef args) { - if (LENGTH(args) != 1) return new_error(interp, "char->int: arg num error.\n"); - if (VALTYPE(CAR(args)) != kCharSExp) return new_error(interp, "char->int: type error.\n"); - return new_integer(interp, REF(CAR(args))->character); -} - -SExpRef builtin_int2char(Interp *interp, SExpRef args) { - if (LENGTH(args) != 1) return new_error(interp, "int->char: arg num error.\n"); - if (VALTYPE(CAR(args)) != kIntegerSExp) return new_error(interp, "int->char: type error.\n"); - return new_char(interp, REF(CAR(args))->integer); -} - -SExpRef builtin_alphabeticp(Interp *interp, SExpRef args) { - if (LENGTH(args) != 1) return new_error(interp, "alphabetic?: arg num error.\n"); - if (VALTYPE(CAR(args)) != kCharSExp) return new_error(interp, "alphabetic?: type error.\n"); - return new_boolean(interp, isalpha(REF(CAR(args))->character)); -} - -SExpRef builtin_numericp(Interp *interp, SExpRef args) { - if (LENGTH(args) != 1) return new_error(interp, "numeric?: arg num error.\n"); - if (VALTYPE(CAR(args)) != kCharSExp) return new_error(interp, "numeric?: type error.\n"); - return new_boolean(interp, isdigit(REF(CAR(args))->character)); -} - -SExpRef builtin_alphanump(Interp *interp, SExpRef args) { - if (LENGTH(args) != 1) return new_error(interp, "alphanum?: arg num error.\n"); - if (VALTYPE(CAR(args)) != kCharSExp) return new_error(interp, "alphanum?: type error.\n"); - return new_boolean(interp, isalnum(REF(CAR(args))->character)); -} - -SExpRef builtin_listp(Interp *interp, SExpRef args) { - if (LENGTH(args) != 1) return new_error(interp, "list?: arg num error.\n"); - return new_boolean(interp, lisp_check_list(interp, CAR(args))); -} - -SExpRef builtin_consp(Interp *interp, SExpRef args) { - if (LENGTH(args) != 1) return new_error(interp, "cons?: arg num error.\n"); - return new_boolean(interp, REF(CAR(args))->type == kPairSExp); -} - -SExpRef builtin_atomp(Interp *interp, SExpRef args) { - if (LENGTH(args) != 1) return new_error(interp, "atom?: arg num error.\n"); - bool ret = false; - SExpType type = REF(CAR(args))->type; - if (type == kRealSExp) ret = true; - if (type == kIntegerSExp) ret = true; - if (type == kStringSExp) ret = true; - if (type == kSymbolSExp) ret = true; - if (type == kCharSExp) ret = true; - if (type == kBooleanSExp) ret = true; - if (type == kNilSExp) ret = true; - if (type == kFuncSExp) ret = true; - if (type == kUserFuncSExp) ret = true; - return new_boolean(interp, ret); -} -SExpRef builtin_nullp(Interp *interp, SExpRef args) { - if (LENGTH(args) != 1) return new_error(interp, "null?: arg num error.\n"); - return new_boolean(interp, REF(CAR(args))->type == kNilSExp); -} - -SExpRef builtin_numberp(Interp *interp, SExpRef args) { - if (LENGTH(args) != 1) return new_error(interp, "number?: arg num error.\n"); - return new_boolean(interp, REF(CAR(args))->type == kIntegerSExp - || REF(CAR(args))->type == kRealSExp); -} - -SExpRef builtin_integerp(Interp *interp, SExpRef args) { - if (LENGTH(args) != 1) return new_error(interp, "integer?: arg num error.\n"); - return new_boolean(interp, REF(CAR(args))->type == kIntegerSExp); -} - -SExpRef builtin_floatp(Interp *interp, SExpRef args) { - if (LENGTH(args) != 1) return new_error(interp, "float?: arg num error.\n"); - return new_boolean(interp, REF(CAR(args))->type == kRealSExp); -} - -SExpRef builtin_nreverse(Interp *interp, SExpRef args) { - if (LENGTH(args) != 1) return new_error(interp, "nreverse: arg num error.\n"); - SExpRef lst = CAR(args); - if (lisp_check_list(interp, lst)) { - return lisp_nreverse(interp, lst); - } - return new_error(interp, "nreverse: type error.\n"); -} - -SExpRef builtin_reverse(Interp *interp, SExpRef args) { - if (LENGTH(args) != 1) return new_error(interp, "reverse: arg num error.\n"); - SExpRef lst = CAR(args); - if (lisp_check_list(interp, lst)) { - return lisp_reverse(interp, lst); - } - return new_error(interp, "reverse: type error.\n"); -} - -SExpRef builtin_last(Interp *interp, SExpRef args) { - if (LENGTH(args) != 1) { - return new_error(interp, "last: arg num error.\n"); - } - SExpRef lst = CAR(args); - if (NILP(lst)) { - return new_error(interp, "last: empty list.\n"); - } - if (!lisp_check_list(interp, lst)) { - return new_error(interp, "last: type error.\n"); - } - for (SExpRef i = lst; !NILP(i); i = CDR(i)) { - if (NILP(CDR(i))) { - return CAR(i); - } - } - return NIL; -} - -static bool equal_impl(Interp *interp, SExpRef x, SExpRef y); - -SExpRef builtin_memberp(Interp *interp, SExpRef args) { - if (LENGTH(args) != 2) { - return new_error(interp, "member?: arg num error.\n"); - } - SExpRef elem = CAR(args), lst = CADR(args); - if (!lisp_check_list(interp, lst)) { - return new_error(interp, "member?: type error.\n"); - } - for (SExpRef i = lst; !NILP(i); i = CDR(i)) { - SExpRef x = CAR(i); - if (equal_impl(interp, x, elem)) { - return interp->t; - } - } - return interp->f; -} - -SExpRef builtin_map(Interp *interp, SExpRef args) { - if (LENGTH(args) != 2) return new_error(interp, "map: wrong arg num.\n"); - SExpRef fn = CAR(args), lst = CADR(args); - if (VALTYPE(fn) != kFuncSExp && VALTYPE(fn) != kUserFuncSExp) { - return new_error(interp, "map: type error.\n"); - } - if (!lisp_check_list(interp, lst)) { - return new_error(interp, "map: type error."); - } - SExpRef newlst = NIL; - for (SExpRef i = lst; !NILP(i); i = CDR(i)) { - SExpRef x = CAR(i); - PUSH_REG(newlst); - SExpRef newx = lisp_call(interp, fn, CONS(x, NIL)); - POP_REG(); - if (CTL_FL(newx)) return newx; - newlst = CONS(newx, newlst); - } - return lisp_nreverse(interp, newlst); -} - -SExpRef builtin_filter(Interp *interp, SExpRef args) { - if (LENGTH(args) != 2) return new_error(interp, "map: wrong arg num.\n"); - SExpRef fn = CAR(args), lst = CADR(args); - if (VALTYPE(fn) != kFuncSExp && VALTYPE(fn) != kUserFuncSExp) { - return new_error(interp, "map: type error.\n"); - } - if (!lisp_check_list(interp, lst)) { - return new_error(interp, "map: type error."); - } - SExpRef newlst = NIL; - for (SExpRef i = lst; !NILP(i); i = CDR(i)) { - SExpRef x = CAR(i); - PUSH_REG(newlst); - SExpRef pred = lisp_call(interp, fn, CONS(x, NIL)); - POP_REG(); - if (CTL_FL(pred)) return pred; - if (TRUEP(pred)) { - newlst = CONS(pred, newlst); - } - } - return lisp_nreverse(interp, newlst); -} - -SExpRef builtin_remove(Interp *interp, SExpRef args) { - if (LENGTH(args) != 2) return new_error(interp, "remove: wrong arg num.\n"); - SExpRef fn = CAR(args), lst = CADR(args); - if (VALTYPE(fn) != kFuncSExp && VALTYPE(fn) != kUserFuncSExp) { - return new_error(interp, "remove: type error.\n"); - } - if (!lisp_check_list(interp, lst)) { - return new_error(interp, "remove: type error."); - } - SExpRef newlst = NIL; - for (SExpRef i = lst; !NILP(i); i = CDR(i)) { - SExpRef x = CAR(i); - PUSH_REG(newlst); - SExpRef pred = lisp_call(interp, fn, CONS(x, NIL)); - POP_REG(); - if (CTL_FL(pred)) return pred; - if (!TRUEP(pred)) { - newlst = CONS(pred, newlst); - } - } - return lisp_nreverse(interp, newlst); -} - -SExpRef builtin_count(Interp *interp, SExpRef args) { - if (LENGTH(args) != 2) return new_error(interp, "count: wrong arg num.\n"); - SExpRef fn = CAR(args), lst = CADR(args); - if (VALTYPE(fn) != kFuncSExp && VALTYPE(fn) != kUserFuncSExp) { - return new_error(interp, "count: type error.\n"); - } - if (!lisp_check_list(interp, lst)) { - return new_error(interp, "count: type error."); - } - int count = 0; - for (SExpRef i = lst; !NILP(i); i = CDR(i)) { - SExpRef x = CAR(i); - SExpRef pred = lisp_call(interp, fn, CONS(x, NIL)); - if (CTL_FL(pred)) return pred; - if (TRUEP(pred)) { - count++; - } - } - return new_integer(interp, count); -} - -SExpRef builtin_foreach(Interp *interp, SExpRef args) { - if (LENGTH(args) != 2) return new_error(interp, "foreach: wrong arg num.\n"); - SExpRef fn = CAR(args), lst = CADR(args); - if (VALTYPE(fn) != kFuncSExp && VALTYPE(fn) != kUserFuncSExp) { - return new_error(interp, "foreach: type error.\n"); - } - if (!lisp_check_list(interp, lst)) { - return new_error(interp, "foreach: type error."); - } - for (SExpRef i = lst; !NILP(i); i = CDR(i)) { - SExpRef x = CAR(i); - SExpRef newx = lisp_call(interp, fn, CONS(x, NIL)); - if (CTL_FL(newx)) return newx; - } - return NIL; -} - -SExpRef builtin_set_car(Interp *interp, SExpRef args) { - if (LENGTH(args) != 2) { - return new_error(interp, "set-car: args num error.\n"); - } - SExpRef lst = CAR(args), elem = CADR(args); - if (VALTYPE(lst) != kPairSExp) { - return new_error(interp, "set-car: type error."); - } - REF(lst)->pair.car = elem; - return NIL; -} - -SExpRef builtin_set_cdr(Interp *interp, SExpRef args) { - if (LENGTH(args) != 2) { - return new_error(interp, "set-cdr: args num error.\n"); - } - SExpRef lst = CAR(args), elem = CADR(args); - if (VALTYPE(lst) != kPairSExp) { - return new_error(interp, "set-cdr: type error."); - } - REF(lst)->pair.cdr = elem; - return NIL; -} - -SExpRef builtin_length(Interp *interp, SExpRef args) { - if (LENGTH(args) != 1) { - return new_error(interp, "length: args num error.\n"); - } - int len = LENGTH(CAR(args)); - if (len < 0) { - return new_error(interp, "length: type error.\n"); - } - return new_integer(interp, len); -} - -SExpRef builtin_nth(Interp *interp, SExpRef args) { - if (LENGTH(args) != 2) { - return new_error(interp, "nth: args num error.\n"); - } - SExpRef n = CAR(args), lst = CADR(args); - if (VALTYPE(n) != kIntegerSExp) return new_error(interp, "nth: type error.\n"); - if (VALTYPE(lst) == kPairSExp) { - if (REF(n)->integer >= LENGTH(lst)) { - return new_error(interp, "nth: out of bound.\n"); - } - for (int i = 0; i < REF(n)->integer; i++) { - lst = CDR(lst); - } - return CAR(lst); - } else if (VALTYPE(lst) == kStringSExp) { - if (REF(n)->integer >= strlen(REF(lst)->str)) { - return new_error(interp, "nth: out of bound\n"); - } - return new_char(interp, REF(lst)->str[REF(n)->integer]); - } else { - return new_error(interp, "nth: type error.\n"); - } -} - -SExpRef builtin_nthcdr(Interp *interp, SExpRef args) { - if (LENGTH(args) != 2) { - return new_error(interp, "nth: args num error.\n"); - } - SExpRef n = CAR(args), lst = CADR(args); - if (VALTYPE(n) != kIntegerSExp) return new_error(interp, "nth: type error.\n"); - if (VALTYPE(lst) == kPairSExp) { - if (REF(n)->integer >= LENGTH(lst)) { - return new_error(interp, "nth: out of bound.\n"); - } - for (int i = 0; i < REF(n)->integer; i++) { - lst = CDR(lst); - } - return CDR(lst); - } else { - return new_error(interp, "nth: type error.\n"); - } -} - -SExpRef builtin_string(Interp *interp, SExpRef args) { - for (SExpRef i = args; !NILP(i); i = CDR(i)) { - SExpRef x = CAR(i); - if (VALTYPE(x) != kIntegerSExp && VALTYPE(x) != kCharSExp) { - return new_error(interp, "string: type error.\n"); - } - } - str_builder_t sb; - init_str_builder(&sb); - for (SExpRef i = args; !NILP(i); i = CDR(i)) { - SExpRef x = CAR(i); - if (VALTYPE(x) == kIntegerSExp) { - str_builder_append_char(&sb, REF(x)->integer); - } else { - str_builder_append_char(&sb, REF(x)->character); - } - } - str_builder_append_char(&sb, '\0'); - SExpRef ret = new_string(interp, sb.buf); - free(sb.buf); - return ret; -} - -SExpRef builtin_string_eq(Interp *interp, SExpRef args) { - if (LENGTH(args) != 2) return new_error(interp, "string=: arg num error.\n"); - SExpRef s1 = CAR(args), s2 = CADR(args); - if (VALTYPE(s1) != kStringSExp || VALTYPE(s2) != kStringSExp) { - return new_error(interp, "string=: type error.\n"); - } - return new_boolean(interp, strcmp(REF(s1)->str, REF(s2)->str) == 0); -} - -SExpRef builtin_string_gt(Interp *interp, SExpRef args) { - if (LENGTH(args) != 2) return new_error(interp, "string>: arg num error.\n"); - SExpRef s1 = CAR(args), s2 = CADR(args); - if (VALTYPE(s1) != kStringSExp || VALTYPE(s2) != kStringSExp) { - return new_error(interp, "string>: type error.\n"); - } - return new_boolean(interp, strcmp(REF(s1)->str, REF(s2)->str) > 0); - -} - -SExpRef builtin_string_lt(Interp *interp, SExpRef args) { - if (LENGTH(args) != 2) return new_error(interp, "string<: arg num error.\n"); - SExpRef s1 = CAR(args), s2 = CADR(args); - if (VALTYPE(s1) != kStringSExp || VALTYPE(s2) != kStringSExp) { - return new_error(interp, "string<: type error.\n"); - } - return new_boolean(interp, strcmp(REF(s1)->str, REF(s2)->str) < 0); -} - -SExpRef builtin_string_ge(Interp *interp, SExpRef args) { - if (LENGTH(args) != 2) return new_error(interp, "string>=: arg num error.\n"); - SExpRef s1 = CAR(args), s2 = CADR(args); - if (VALTYPE(s1) != kStringSExp || VALTYPE(s2) != kStringSExp) { - return new_error(interp, "string>=: type error.\n"); - } - return new_boolean(interp, strcmp(REF(s1)->str, REF(s2)->str) >= 0); -} - -SExpRef builtin_string_le(Interp *interp, SExpRef args) { - if (LENGTH(args) != 2) return new_error(interp, "string<=: arg num error.\n"); - SExpRef s1 = CAR(args), s2 = CADR(args); - if (VALTYPE(s1) != kStringSExp || VALTYPE(s2) != kStringSExp) { - return new_error(interp, "string<=: type error.\n"); - } - return new_boolean(interp, strcmp(REF(s1)->str, REF(s2)->str) <= 0); -} - -SExpRef builtin_string_neq(Interp *interp, SExpRef args) { - if (LENGTH(args) != 2) return new_error(interp, "string/=: arg num error.\n"); - SExpRef s1 = CAR(args), s2 = CADR(args); - if (VALTYPE(s1) != kStringSExp || VALTYPE(s2) != kStringSExp) { - return new_error(interp, "string/=: type error.\n"); - } - return new_boolean(interp, strcmp(REF(s1)->str, REF(s2)->str) != 0); -} - -SExpRef builtin_split_string(Interp *interp, SExpRef args) { - if (LENGTH(args) != 2) return new_error(interp, "split-string: arg num error.\n"); - SExpRef s1 = CAR(args), s2 = CADR(args); - if (VALTYPE(s1) != kStringSExp || VALTYPE(s2) != kCharSExp) { - return new_error(interp, "split-string: type error.\n"); - } - char **ss; - ss = str_split((char*)REF(s1)->str, REF(s2)->character); - SExpRef lst = NIL; - for (char **i = ss; *i != NULL; i++) { - lst = CONS(new_string(interp, *i), lst); - } - destroy_str_list(ss); - return lisp_nreverse(interp, lst); -} - -SExpRef builtin_strip_string(Interp *interp, SExpRef args) { - if (LENGTH(args) != 1) return new_error(interp, "strip-string: arg num error.\n"); - SExpRef s = CAR(args); - if (VALTYPE(s) != kStringSExp) return new_error(interp, "strip-string: type error.\n"); - char *news = str_strip((char*)REF(s)->str); - SExpRef ret = new_string(interp, news); - free(news); - return ret; -} - -SExpRef builtin_alwaysgc(Interp *interp, SExpRef args) { - if (LENGTH(args) != 1) return new_error(interp, "_alwaysgc: arg num error.\n"); - SExpRef arg = CAR(args); - if (VALTYPE(arg) != kBooleanSExp) return new_error(interp, "alwaysgc: type error.\n"); - interp->alwaysgc = REF(arg)->boolean; - return NIL; -} - -SExpRef builtin_symbol2string(Interp *interp, SExpRef args) { - if (LENGTH(args) != 1) return new_error(interp, "symbol->string: arg num error.\n"); - SExpRef arg = CAR(args); - if (VALTYPE(arg) != kSymbolSExp) return new_error(interp, "symbol->string: type error.\n"); - return new_string(interp, REF(arg)->str); -} - -SExpRef builtin_intern(Interp *interp, SExpRef args) { - if (LENGTH(args) != 1) return new_error(interp, "intern: arg num error.\n"); - SExpRef arg = CAR(args); - if (VALTYPE(arg) != kStringSExp) return new_error(interp, "intern: type error.\n"); - return new_symbol(interp, REF(arg)->str); -} - -SExpRef builtin_gensym(Interp *interp, SExpRef args) { - if (LENGTH(args) != 0) return new_error(interp, "gensym: no arg.\n"); - char buf[16]; - snprintf(buf, 16, "sYyYm%d", interp->gensym_cnt); - interp->gensym_cnt++; - return new_symbol(interp, buf); -} - -SExpRef builtin_float(Interp *interp, SExpRef args) { - if (LENGTH(args) != 1) return new_error(interp, "float: expect 1 arg.\n"); - SExpRef x = CAR(args); - if (VALTYPE(x) != kIntegerSExp) return new_error(interp, "float: wrong type.\n"); - return new_real(interp, REF(x)->integer); -} - -SExpRef builtin_abs(Interp *interp, SExpRef args) { - if (LENGTH(args) != 1) return new_error(interp, "abs: expect 1 arg.\n"); - SExpRef x = CAR(args); - if (VALTYPE(x) != kIntegerSExp && VALTYPE(x) != kRealSExp) { - return new_error(interp, "abs: wrong type.\n"); - } - if (VALTYPE(x) == kIntegerSExp) { - int64_t val = REF(x)->integer; - if (val < 0) val = -val; - return new_integer(interp, val); - } else { - double val = REF(x)->real; - if (val < 0) val = -val; - return new_real(interp, val); - } -} - -static double real_value(Interp *interp, SExpRef x) { - if (VALTYPE(x) == kIntegerSExp) { - return REF(x)->integer; - } else { - return REF(x)->real; - } -} - -SExpRef builtin_pow(Interp *interp, SExpRef args) { - if (LENGTH(args) != 2) return new_error(interp, "pow: expect 2 args.\n"); - SExpRef x = CAR(args), y = CADR(args); - if (VALTYPE(x) != kIntegerSExp && VALTYPE(x) != kRealSExp) { - return new_error(interp, "pow: wrong type.\n"); - } - if (VALTYPE(y) != kIntegerSExp && VALTYPE(y) != kRealSExp) { - return new_error(interp, "pow: wrong type.\n"); - } - return new_real(interp, pow(real_value(interp, x), real_value(interp, y))); -} - -#define GEN_MATH_FUNC(name, cfunc) \ -SExpRef builtin_##name(Interp *interp, SExpRef args) { \ - if (LENGTH(args) != 1) return new_error(interp, #name": expect 1 args.\n"); \ - SExpRef x = CAR(args); \ - if (VALTYPE(x) != kIntegerSExp && VALTYPE(x) != kRealSExp) { \ - return new_error(interp, #name": wrong type.\n"); \ - } \ - return new_real(interp, cfunc(real_value(interp, x))); \ -} - -GEN_MATH_FUNC(sqrt, sqrt); -GEN_MATH_FUNC(cbrt, cbrt); -GEN_MATH_FUNC(floor, floor); -GEN_MATH_FUNC(truncate, trunc); -GEN_MATH_FUNC(ceiling, ceil); -GEN_MATH_FUNC(round, round); -GEN_MATH_FUNC(sin, sin); -GEN_MATH_FUNC(cos, cos); -GEN_MATH_FUNC(tan, tan); -GEN_MATH_FUNC(asin, asin); -GEN_MATH_FUNC(acos, acos); -GEN_MATH_FUNC(atan, atan); -GEN_MATH_FUNC(ln, log); -GEN_MATH_FUNC(log10, log10); -GEN_MATH_FUNC(log2, log2); -GEN_MATH_FUNC(exp, exp); - -SExpRef builtin_min(Interp *interp, SExpRef args) { - if (LENGTH(args) < 1) return new_error(interp, "min: wrong arg number.\n"); - bool hasReal = false; - FOREACH(iter, args) { - SExpRef x = CAR(iter); - if (VALTYPE(x) == kRealSExp) hasReal = true; - if (VALTYPE(x) != kRealSExp && VALTYPE(x) != kIntegerSExp) { - return new_error(interp, "min: wrong type.\n"); - } - } - if (hasReal) { - double min = DBL_MAX; - FOREACH(iter, args) { - SExpRef x = CAR(iter); - if (VALTYPE(x) == kIntegerSExp) { - if (REF(x)->integer < min) { - min = REF(x)->integer; - } - } - if (VALTYPE(x) == kRealSExp) { - if (REF(x)->real < min) { - min = REF(x)->real; - } - } - } - return new_integer(interp, min); - } else { - int64_t min = INT64_MAX; - FOREACH(iter, args) { - SExpRef x = CAR(iter); - if (VALTYPE(x) == kIntegerSExp) { - if (REF(x)->integer < min) { - min = REF(x)->integer; - } - } - } - return new_integer(interp, min); - } -} - -SExpRef builtin_max(Interp *interp, SExpRef args) { - if (LENGTH(args) < 1) return new_error(interp, "min: wrong arg number.\n"); - bool hasReal = false; - FOREACH(iter, args) { - SExpRef x = CAR(iter); - if (VALTYPE(x) == kRealSExp) hasReal = true; - if (VALTYPE(x) != kRealSExp && VALTYPE(x) != kIntegerSExp) { - return new_error(interp, "min: wrong type.\n"); - } - } - if (hasReal) { - double max = -DBL_MAX; - FOREACH(iter, args) { - SExpRef x = CAR(iter); - if (VALTYPE(x) == kIntegerSExp) { - if (REF(x)->integer > max) { - max = REF(x)->integer; - } - } - if (VALTYPE(x) == kRealSExp) { - if (REF(x)->real > max) { - max = REF(x)->real; - } - } - } - return new_real(interp, max); - } else { - int64_t max = INT64_MIN; - FOREACH(iter, args) { - SExpRef x = CAR(iter); - if (VALTYPE(x) == kIntegerSExp) { - if (REF(x)->integer > max) { - max = REF(x)->integer; - } - } - } - return new_integer(interp, max); - } -} - -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"); - } - - SExpRef format_string_sexp = CAR(args); - SExpRef format_args = CDR(args); - - if (REF(format_string_sexp)->type != kStringSExp) { - return new_error(interp, "format: first argument must be a string.\n"); - } - - const char *format_str = REF(format_string_sexp)->str; - str_builder_t sb; - SExpRef ret; - init_str_builder(&sb); - - SExpRef current_format_arg = format_args; - for (int i = 0; format_str[i] != '\0'; ++i) { - if (format_str[i] == '%' && format_str[i+1] == 's') { - if (NILP(current_format_arg)) { - ret = new_error(interp, "format: wrong argument number.\n"); - goto end; - } else { - SExpRef s_arg = CAR(current_format_arg); - if (REF(s_arg)->type != kStringSExp) { - const char *s = lisp_to_string(interp, s_arg); - str_builder_append(&sb, "%s", s); - free((void*)s); - } else { - str_builder_append(&sb, "%s", REF(s_arg)->str); - } - current_format_arg = CDR(current_format_arg); - i++; - } - } else if (format_str[i] == '%' && format_str[i+1] == '%') { - str_builder_append_char(&sb, '%'); - i++; - } else if (format_str[i] == '%') { - ret = new_error(interp, "format: only %%s is supported.\n"); - goto end; - } else { - str_builder_append_char(&sb, format_str[i]); - } - } - if (!NILP(current_format_arg)) { - ret = new_error(interp, "format: wrong argument number.\n"); - goto end; - } - - str_builder_append_char(&sb, '\0'); - ret = new_string(interp, sb.buf); -end: - free(sb.buf); - return ret; -} - -SExpRef builtin_concat(Interp *interp, SExpRef args) { - SExpRef cur = args; - while (!NILP(cur)) { - if (REF(CAR(cur))->type != kStringSExp) { - return new_error(interp, "concat: wrong type.\n"); - } - cur = CDR(cur); - } - str_builder_t sb; - init_str_builder(&sb); - cur = args; - while (!NILP(cur)) { - SExpRef s = CAR(cur); - str_builder_append(&sb, "%s", REF(s)->str); - cur = CDR(cur); - } - str_builder_append_char(&sb, '\0'); - SExpRef ret = new_string(interp, sb.buf); - free(sb.buf); - return ret; -} - -SExpRef builtin_exit(Interp *interp, SExpRef args) { - if (LENGTH(args) == 0) { - Interp_free(interp); - exit(0); - } - if (LENGTH(args) == 1) { - SExpRef x = CAR(args); - if (VALTYPE(x) != kIntegerSExp) goto error; - int retcode = REF(x)->integer; - Interp_free(interp); - exit(retcode); - } -error: - return new_error(interp, "exit: argument error.\n"); -} - -SExpRef builtin_error(Interp *interp, SExpRef args) { - if (LENGTH(args) != 1) return new_error(interp, "err.\n"); - if (VALTYPE(CAR(args)) == kStringSExp || VALTYPE(CAR(args)) == kSymbolSExp) { - return new_error(interp, "%s\n", REF(CAR(args))->str); - } - const char *str = lisp_to_string(interp, CAR(args)); - SExpRef ret = new_error(interp, "%s\n", REF(CAR(args))->str); - free((void*)str); - return ret; -} - -SExpRef builtin_list(Interp *interp, SExpRef args) { - return args; -} - -SExpRef builtin_car(Interp *interp, SExpRef args) { - if (LENGTH(args) != 1) { - return new_error(interp, "car: wrong argument number.\n"); - } - if (CTL_FL(args)) return args; - return CAR(CAR(args)); -} - -SExpRef builtin_princ(Interp *interp, SExpRef args) { - if (LENGTH(args) != 1) { - return new_error(interp, "show wrong argument number.\n"); - } - if (VALTYPE(CAR(args)) == kStringSExp) { - printf("%s", REF(CAR(args))->str); - return NIL; - } - const char *s = lisp_to_string(interp, CAR(args)); - printf("%s", s); - free((void*)s); - return NIL; -} - -SExpRef builtin_print(Interp *interp, SExpRef args) { - if (LENGTH(args) != 1) { - return new_error(interp, "show wrong argument number.\n"); - } - lisp_print(interp, CAR(args), stdout); - return NIL; -} - -SExpRef builtin_cdr(Interp *interp, SExpRef args) { - if (LENGTH(args) != 1) { - return new_error(interp, "cdr: wrong argument number.\n"); - } - return CDR(CAR(args)); -} - -SExpRef builtin_cons(Interp *interp, SExpRef args) { - if (LENGTH(args) != 2) { - return new_error(interp, "cons: wrong argument number.\n"); - } - return CONS(CAR(args), CADR(args)); -} - -static SExp raw_add(SExp a, SExp b) { - if (a.type == kRealSExp || b.type == kRealSExp) { - double result = 0; - if (a.type == kRealSExp) result += a.real; - else result += a.integer; - if (b.type == kRealSExp) result += b.real; - else result += b.integer; - return (SExp){ .type = kRealSExp, .real = result }; - } else { - int64_t result; - return (SExp){ .type = kIntegerSExp, .integer= a.integer + b.integer}; - } -} - -static SExp raw_mul(SExp a, SExp b) { - if (a.type == kRealSExp || b.type == kRealSExp) { - double result = 1.0; - if (a.type == kRealSExp) result *= a.real; - else result *= a.integer; - if (b.type == kRealSExp) result *= b.real; - else result *= b.integer; - return (SExp){ .type = kRealSExp, .real = result }; - } else { - int64_t result; - return (SExp){ .type = kIntegerSExp, .integer= a.integer * b.integer}; - } -} - -static SExp raw_sub(SExp a, SExp b) { - if (a.type == kRealSExp || b.type == kRealSExp) { - double result = 0; - if (a.type == kRealSExp) result += a.real; - else result += a.integer; - if (b.type == kRealSExp) result -= b.real; - else result -= b.integer; - return (SExp){ .type = kRealSExp, .real = result }; - } else { - return (SExp){ .type = kIntegerSExp, .integer= a.integer - b.integer}; - } -} - -static SExp raw_div(SExp a, SExp b) { - double lhs, rhs; - if (a.type == kRealSExp) lhs = a.real; - else lhs = a.integer; - if (b.type == kRealSExp) rhs = b.real; - else rhs = b.integer; - return (SExp){ .type = kRealSExp, .real = lhs / rhs}; -} - -static SExp raw_idiv(SExp a, SExp b) { - int64_t lhs, rhs; - lhs = a.integer; - rhs = b.integer; - return (SExp){ .type = kIntegerSExp, .integer = lhs / rhs}; -} - -static SExp raw_mod(SExp a, SExp b) { - int64_t lhs, rhs; - lhs = a.integer; - rhs = b.integer; - return (SExp){ .type = kIntegerSExp, .integer = lhs % rhs}; -} - -SExpRef builtin_add(Interp *interp, SExpRef args) { - SExpRef ret; - SExp acc = {.type = kIntegerSExp, .integer = 0}; - SExpRef cur = args; - while (!NILP(cur)) { - if (REF(CAR(cur))->type != kIntegerSExp && REF(CAR(cur))->type != kRealSExp) { - return new_error(interp, "+: wrong argument type.\n"); - } - cur = CDR(cur); - } - cur = args; - while (!NILP(cur)) { - acc = raw_add(acc, *REF(CAR(cur))); - cur = CDR(cur); - } - ret = new_sexp(interp); - *REF(ret) = acc; - return ret; -} - -SExpRef builtin_mul(Interp *interp, SExpRef args) { - SExpRef ret; - SExp acc = {.type = kIntegerSExp, .integer = 1}; - SExpRef cur = args; - while (!NILP(cur)) { - if (REF(CAR(cur))->type != kIntegerSExp && REF(CAR(cur))->type != kRealSExp) { - return new_error(interp, "*: wrong argument type.\n"); - } - cur = CDR(cur); - } - cur = args; - while (!NILP(cur)) { - acc = raw_mul(acc, *REF(CAR(cur))); - cur = CDR(cur); - } - ret = new_sexp(interp); - *REF(ret) = acc; - return ret; -} - -SExpRef builtin_sub(Interp *interp, SExpRef args) { - SExpRef ret; - SExpRef cur = args; - while (!NILP(cur)) { - if (REF(CAR(cur))->type != kIntegerSExp && REF(CAR(cur))->type != kRealSExp) { - return new_error(interp, "-: wrong argument type.\n"); - } - cur = CDR(cur); - } - int args_len = LENGTH(args); - if (args_len == 1) { - SExp num = *REF(CAR(args)); - if (num.type == kIntegerSExp) { - return new_integer(interp, -num.integer); - } - return new_real(interp, -num.real); - } - if (args_len == 2) { - SExp num = raw_sub(*REF(CAR(args)), *REF(CADR(args))); - ret = new_sexp(interp); - *REF(ret) = num; - return ret; - } - return new_error(interp, "-: wrong argument number.\n"); -} - -SExpRef builtin_div(Interp *interp, SExpRef args) { - SExpRef ret; - SExpRef cur = args; - while (!NILP(cur)) { - if (REF(CAR(cur))->type != kIntegerSExp && REF(CAR(cur))->type != kRealSExp) { - return new_error(interp, "/: wrong argument type.\n"); - } - cur = CDR(cur); - } - int args_len = LENGTH(args); - if (args_len == 1) { - SExp num = *REF(CAR(args)); - if (num.type == kIntegerSExp) { - return new_real(interp, 1.0/num.integer); - } - return new_real(interp, 1.0/num.real); - } - if (args_len == 2) { - SExp num = raw_div(*REF(CAR(args)), *REF(CADR(args))); - ret = new_sexp(interp); - *REF(ret) = num; - return ret; - } - return new_error(interp, "/: wrong argument number.\n"); -} - -SExpRef builtin_idiv(Interp *interp, SExpRef args) { - SExpRef ret; - SExpRef cur = args; - while (!NILP(cur)) { - if (REF(CAR(cur))->type != kIntegerSExp) { - return new_error(interp, "i/: wrong argument type.\n"); - } - cur = CDR(cur); - } - int args_len = LENGTH(args); - if (args_len == 2) { - SExp num = raw_idiv(*REF(CAR(args)), *REF(CADR(args))); - ret = new_sexp(interp); - *REF(ret) = num; - return ret; - } - return new_error(interp, "i/: wrong argument number.\n"); -} - -SExpRef builtin_mod(Interp *interp, SExpRef args) { - SExpRef ret; - SExpRef cur = args; - while (!NILP(cur)) { - if (REF(CAR(cur))->type != kIntegerSExp) { - return new_error(interp, "mod: wrong argument type.\n"); - } - cur = CDR(cur); - } - int args_len = LENGTH(args); - if (args_len == 2) { - SExp num = raw_mod(*REF(CAR(args)), *REF(CADR(args))); - ret = new_sexp(interp); - *REF(ret) = num; - return ret; - } - return new_error(interp, "mod: wrong argument number.\n"); -} - -SExpRef builtin_not(Interp *interp, SExpRef args) { - int args_len = LENGTH(args); - if (args_len != 1) return new_error(interp, "not: wrong argument number.\n"); - if (TRUEP(CAR(args))) return interp->f; - return interp->t; -} - -SExpRef builtin_num_equal(Interp *interp, SExpRef args) { - int args_len = LENGTH(args); - if (args_len != 2) return new_error(interp, "=: wrong argument number.\n"); - SExpRef lhs = CAR(args); - SExpRef rhs = CADR(args); - if (VALTYPE(lhs) != kRealSExp && VALTYPE(lhs) != kIntegerSExp) { - return new_error(interp, "=: type error.\n"); - } - if (VALTYPE(rhs) != kRealSExp && VALTYPE(rhs) != kIntegerSExp) { - return new_error(interp, "=: type error.\n"); - } - if (VALTYPE(lhs) == kRealSExp || VALTYPE(rhs) == kRealSExp) { - double flhs, frhs; - if (VALTYPE(lhs) == kIntegerSExp) { - flhs = REF(lhs)->integer; - } else { - flhs = REF(lhs)->real; - } - if (VALTYPE(rhs) == kIntegerSExp) { - frhs = REF(rhs)->integer; - } else { - frhs = REF(rhs)->real; - } - return new_boolean(interp, flhs == frhs); - } else { - return new_boolean(interp, REF(lhs)->integer == REF(rhs)->integer); - } -} - - -SExpRef builtin_num_neq(Interp *interp, SExpRef args) { - int args_len = LENGTH(args); - if (args_len != 2) return new_error(interp, "/=: wrong argument number.\n"); - SExpRef lhs = CAR(args); - SExpRef rhs = CADR(args); - if (VALTYPE(lhs) != kRealSExp && VALTYPE(lhs) != kIntegerSExp) { - return new_error(interp, "/=: type error.\n"); - } - if (VALTYPE(rhs) != kRealSExp && VALTYPE(rhs) != kIntegerSExp) { - return new_error(interp, "/=: type error.\n"); - } - if (VALTYPE(lhs) == kRealSExp || VALTYPE(rhs) == kRealSExp) { - double flhs, frhs; - if (VALTYPE(lhs) == kIntegerSExp) { - flhs = REF(lhs)->integer; - } else { - flhs = REF(lhs)->real; - } - if (VALTYPE(rhs) == kIntegerSExp) { - frhs = REF(rhs)->integer; - } else { - frhs = REF(rhs)->real; - } - return new_boolean(interp, flhs != frhs); - } else { - return new_boolean(interp, REF(lhs)->integer != REF(rhs)->integer); - } -} - -SExpRef builtin_gt(Interp *interp, SExpRef args) { - int args_len = LENGTH(args); - if (args_len != 2) return new_error(interp, ">: wrong argument number.\n"); - SExpRef lhs = CAR(args); - SExpRef rhs = CADR(args); - if (VALTYPE(lhs) != kRealSExp && VALTYPE(lhs) != kIntegerSExp) { - return new_error(interp, ">: type error.\n"); - } - if (VALTYPE(rhs) != kRealSExp && VALTYPE(rhs) != kIntegerSExp) { - return new_error(interp, ">: type error.\n"); - } - if (VALTYPE(lhs) == kRealSExp || VALTYPE(rhs) == kRealSExp) { - double flhs, frhs; - if (VALTYPE(lhs) == kIntegerSExp) { - flhs = REF(lhs)->integer; - } else { - flhs = REF(lhs)->real; - } - if (VALTYPE(rhs) == kIntegerSExp) { - frhs = REF(rhs)->integer; - } else { - frhs = REF(rhs)->real; - } - return new_boolean(interp, flhs > frhs); - } else { - return new_boolean(interp, REF(lhs)->integer > REF(rhs)->integer); - } -} - -SExpRef builtin_lt(Interp *interp, SExpRef args) { - int args_len = LENGTH(args); - if (args_len != 2) return new_error(interp, "<: wrong argument number.\n"); - SExpRef lhs = CAR(args); - SExpRef rhs = CADR(args); - if (VALTYPE(lhs) != kRealSExp && VALTYPE(lhs) != kIntegerSExp) { - return new_error(interp, "<: type error.\n"); - } - if (VALTYPE(rhs) != kRealSExp && VALTYPE(rhs) != kIntegerSExp) { - return new_error(interp, "<: type error.\n"); - } - if (VALTYPE(lhs) == kRealSExp || VALTYPE(rhs) == kRealSExp) { - double flhs, frhs; - if (VALTYPE(lhs) == kIntegerSExp) { - flhs = REF(lhs)->integer; - } else { - flhs = REF(lhs)->real; - } - if (VALTYPE(rhs) == kIntegerSExp) { - frhs = REF(rhs)->integer; - } else { - frhs = REF(rhs)->real; - } - return new_boolean(interp, flhs < frhs); - } else { - return new_boolean(interp, REF(lhs)->integer < REF(rhs)->integer); - } -} - -SExpRef builtin_ge(Interp *interp, SExpRef args) { - int args_len = LENGTH(args); - if (args_len != 2) return new_error(interp, ">=: wrong argument number.\n"); - SExpRef lhs = CAR(args); - SExpRef rhs = CADR(args); - if (VALTYPE(lhs) != kRealSExp && VALTYPE(lhs) != kIntegerSExp) { - return new_error(interp, ">=: type error.\n"); - } - if (VALTYPE(rhs) != kRealSExp && VALTYPE(rhs) != kIntegerSExp) { - return new_error(interp, ">=: type error.\n"); - } - if (VALTYPE(lhs) == kRealSExp || VALTYPE(rhs) == kRealSExp) { - double flhs, frhs; - if (VALTYPE(lhs) == kIntegerSExp) { - flhs = REF(lhs)->integer; - } else { - flhs = REF(lhs)->real; - } - if (VALTYPE(rhs) == kIntegerSExp) { - frhs = REF(rhs)->integer; - } else { - frhs = REF(rhs)->real; - } - return new_boolean(interp, flhs >= frhs); - } else { - return new_boolean(interp, REF(lhs)->integer >= REF(rhs)->integer); - } -} - -SExpRef builtin_gcstat(Interp *interp, SExpRef args) { - int heapsize = SExpVector_len(&interp->objs); - int freesize = IntVector_len(&interp->empty_space); - fprintf(stderr, "heapsize: %d, free: %d\n", heapsize, freesize); - return NIL; -} - -SExpRef builtin_le(Interp *interp, SExpRef args) { - int args_len = LENGTH(args); - if (args_len != 2) return new_error(interp, "<=: wrong argument number.\n"); - SExpRef lhs = CAR(args); - SExpRef rhs = CADR(args); - if (VALTYPE(lhs) != kRealSExp && VALTYPE(lhs) != kIntegerSExp) { - return new_error(interp, "<=: type error.\n"); - } - if (VALTYPE(rhs) != kRealSExp && VALTYPE(rhs) != kIntegerSExp) { - return new_error(interp, "<=: type error.\n"); - } - if (VALTYPE(lhs) == kRealSExp || VALTYPE(rhs) == kRealSExp) { - double flhs, frhs; - if (VALTYPE(lhs) == kIntegerSExp) { - flhs = REF(lhs)->integer; - } else { - flhs = REF(lhs)->real; - } - if (VALTYPE(rhs) == kIntegerSExp) { - frhs = REF(rhs)->integer; - } else { - frhs = REF(rhs)->real; - } - return new_boolean(interp, flhs <= frhs); - } else { - return new_boolean(interp, REF(lhs)->integer <= REF(rhs)->integer); - } -} - diff --git a/src/builtins.h b/src/builtins.h deleted file mode 100644 index 66d6d1a..0000000 --- a/src/builtins.h +++ /dev/null @@ -1,122 +0,0 @@ -#ifndef BAMBOO_LISP_BUILTINS_H_ -#define BAMBOO_LISP_BUILTINS_H_ - -#include "interp.h" - -SExpRef builtin_logand(Interp *interp, SExpRef args); -SExpRef builtin_logior(Interp *interp, SExpRef args); -SExpRef builtin_logxor(Interp *interp, SExpRef args); -SExpRef builtin_lognot(Interp *interp, SExpRef args); -SExpRef builtin_lsh(Interp *interp, SExpRef args); -SExpRef builtin_ash(Interp *interp, SExpRef args); - -SExpRef builtin_numberp(Interp *interp, SExpRef args); -SExpRef builtin_integerp(Interp *interp, SExpRef args); -SExpRef builtin_functionp(Interp *interp, SExpRef args); -SExpRef builtin_charp(Interp *interp, SExpRef args); -SExpRef builtin_listp(Interp *interp, SExpRef args); -SExpRef builtin_consp(Interp *interp, SExpRef args); -SExpRef builtin_atomp(Interp *interp, SExpRef args); -SExpRef builtin_nullp(Interp *interp, SExpRef args); -SExpRef builtin_floatp(Interp *interp, SExpRef args); - -SExpRef builtin_char_eq(Interp *interp, SExpRef args); -SExpRef builtin_char_gt(Interp *interp, SExpRef args); -SExpRef builtin_char_lt(Interp *interp, SExpRef args); -SExpRef builtin_char_ge(Interp *interp, SExpRef args); -SExpRef builtin_char_le(Interp *interp, SExpRef args); -SExpRef builtin_char_neq(Interp *interp, SExpRef args); -SExpRef builtin_int2char(Interp *interp, SExpRef args); -SExpRef builtin_char2int(Interp *interp, SExpRef args); -SExpRef builtin_numericp(Interp *interp, SExpRef args); -SExpRef builtin_alphabeticp(Interp *interp, SExpRef args); -SExpRef builtin_alphanump(Interp *interp, SExpRef args); - -SExpRef builtin_string(Interp *interp, SExpRef args); -SExpRef builtin_string_eq(Interp *interp, SExpRef args); -SExpRef builtin_string_gt(Interp *interp, SExpRef args); -SExpRef builtin_string_lt(Interp *interp, SExpRef args); -SExpRef builtin_string_ge(Interp *interp, SExpRef args); -SExpRef builtin_string_le(Interp *interp, SExpRef args); -SExpRef builtin_string_neq(Interp *interp, SExpRef args); -SExpRef builtin_split_string(Interp *interp, SExpRef args); -SExpRef builtin_strip_string(Interp *interp, SExpRef args); -SExpRef builtin_format(Interp *interp, SExpRef args); -SExpRef builtin_concat(Interp *interp, SExpRef args); -SExpRef builtin_print(Interp *interp, SExpRef args); -SExpRef builtin_princ(Interp *interp, SExpRef args); - -SExpRef builtin_add(Interp *interp, SExpRef args); -SExpRef builtin_sub(Interp *interp, SExpRef args); -SExpRef builtin_mul(Interp *interp, SExpRef args); -SExpRef builtin_div(Interp *interp, SExpRef args); -SExpRef builtin_idiv(Interp *interp, SExpRef args); -SExpRef builtin_mod(Interp *interp, SExpRef args); -SExpRef builtin_num_equal(Interp *interp, SExpRef args); -SExpRef builtin_num_neq(Interp *interp, SExpRef args); -SExpRef builtin_gt(Interp *interp, SExpRef args); -SExpRef builtin_lt(Interp *interp, SExpRef args); -SExpRef builtin_ge(Interp *interp, SExpRef args); -SExpRef builtin_le(Interp *interp, SExpRef args); -SExpRef builtin_sqrt(Interp *interp, SExpRef args); -SExpRef builtin_cbrt(Interp *interp, SExpRef args); -SExpRef builtin_float(Interp *interp, SExpRef args); -SExpRef builtin_abs(Interp *interp, SExpRef args); -SExpRef builtin_pow(Interp *interp, SExpRef args); -SExpRef builtin_floor(Interp *interp, SExpRef args); -SExpRef builtin_truncate(Interp *interp, SExpRef args); -SExpRef builtin_ceiling(Interp *interp, SExpRef args); -SExpRef builtin_round(Interp *interp, SExpRef args); -SExpRef builtin_sin(Interp *interp, SExpRef args); -SExpRef builtin_cos(Interp *interp, SExpRef args); -SExpRef builtin_tan(Interp *interp, SExpRef args); -SExpRef builtin_asin(Interp *interp, SExpRef args); -SExpRef builtin_acos(Interp *interp, SExpRef args); -SExpRef builtin_atan(Interp *interp, SExpRef args); -SExpRef builtin_ln(Interp *interp, SExpRef args); -SExpRef builtin_log10(Interp *interp, SExpRef args); -SExpRef builtin_log2(Interp *interp, SExpRef args); -SExpRef builtin_exp(Interp *interp, SExpRef args); -SExpRef builtin_min(Interp *interp, SExpRef args); -SExpRef builtin_max(Interp *interp, SExpRef args); - -SExpRef builtin_list(Interp *interp, SExpRef args); -SExpRef builtin_setnth(Interp *interp, SExpRef args); -SExpRef builtin_setnthcdr(Interp *interp, SExpRef args); -SExpRef builtin_foldl(Interp *interp, SExpRef args); -SExpRef builtin_append(Interp *interp, SExpRef args); -SExpRef builtin_nconc(Interp *interp, SExpRef args); -SExpRef builtin_memberp(Interp *interp, SExpRef args); -SExpRef builtin_nreverse(Interp *interp, SExpRef args); -SExpRef builtin_reverse(Interp *interp, SExpRef args); -SExpRef builtin_last(Interp *interp, SExpRef args); -SExpRef builtin_map(Interp *interp, SExpRef args); -SExpRef builtin_filter(Interp *interp, SExpRef args); -SExpRef builtin_remove(Interp *interp, SExpRef args); -SExpRef builtin_count(Interp *interp, SExpRef args); -SExpRef builtin_foreach(Interp *interp, SExpRef args); -SExpRef builtin_set_car(Interp *interp, SExpRef args); -SExpRef builtin_set_cdr(Interp *interp, SExpRef args); -SExpRef builtin_length(Interp *interp, SExpRef args); -SExpRef builtin_nth(Interp *interp, SExpRef args); -SExpRef builtin_nthcdr(Interp *interp, SExpRef args); -SExpRef builtin_car(Interp *interp, SExpRef args); -SExpRef builtin_cdr(Interp *interp, SExpRef args); -SExpRef builtin_cons(Interp *interp, SExpRef args); - -SExpRef builtin_symbol2string(Interp *interp, SExpRef args); -SExpRef builtin_intern(Interp *interp, SExpRef args); -SExpRef builtin_gensym(Interp *interp, SExpRef args); - -SExpRef builtin_not(Interp *interp, SExpRef args); -SExpRef builtin_equal(Interp *interp, SExpRef args); -SExpRef builtin_eq(Interp *interp, SExpRef args); - -SExpRef builtin_exit(Interp *interp, SExpRef args); -SExpRef builtin_error(Interp *interp, SExpRef args); -SExpRef builtin_throw(Interp *interp, SExpRef args); - -SExpRef builtin_gcstat(Interp *interp, SExpRef args); -SExpRef builtin_alwaysgc(Interp *interp, SExpRef args); - -#endif diff --git a/src/interp.c b/src/interp.c deleted file mode 100644 index 0af16de..0000000 --- a/src/interp.c +++ /dev/null @@ -1,1175 +0,0 @@ -#include "interp.h" - -#include <stdarg.h> -#include <inttypes.h> - -#include <algds/hash_table.h> -#include <algds/str.h> - -#include "sexp.h" -#include "builtins.h" -#include "primitives.h" -#include "parser.h" -#include "prelude.h" - -#include "vector.h" - -#define BUFSIZE 1024 - -bool SExpRef_eq(SExpRef a, SExpRef b) { - return a.idx == b.idx; -} - -uint64_t SExpRef_hash(SExpRef s) { - // FNV-1a 64-bit hash - uint32_t idx = s.idx; - uint8_t byte0 = idx & 0xff; - uint8_t byte1 = (idx >> 8) & 0xff; - uint8_t byte2 = (idx >> 16) & 0xff; - uint8_t byte3 = (idx >> 24) & 0xff; - uint64_t hash = 14695981039346656037ULL; - hash = hash ^ byte0; - hash = hash * 1099511628211ULL; - hash = hash ^ byte1; - hash = hash * 1099511628211ULL; - hash = hash ^ byte2; - hash = hash * 1099511628211ULL; - hash = hash ^ byte3; - hash = hash * 1099511628211ULL; - return hash; -} - -HASH_TABLE_IMPL(SExpRef, SExpRef); - -#define UNBOUND ((SExpRef){-1}) - -// for wasm -Interp *new_interp() { - Interp *ret = malloc(sizeof(Interp)); - Interp_init(ret); - return ret; -} - -// for wasm -void print_lisp_error(Interp *interp, SExpRef err) { - if (VALTYPE(err) == kErrSignal) { - fprintf(stderr, "Error: %s", REF(err)->str); - } else if (VALTYPE(err) == kExceptionSignal) { - const char *exception_str = lisp_to_string(interp, REF(err)->ret); - fprintf(stderr, "Exception: %s\n", exception_str); - free((void*)exception_str); - } -} - -const char *lisp_stacktrace_to_string(Interp *interp, SExpRef stacktrace) { - str_builder_t sb; - init_str_builder(&sb); - str_builder_append(&sb, "Stacktrace:\n"); - for (SExpRef iter = stacktrace; !NILP(iter); iter = CDR(iter)) { - SExpRef i = CAR(iter); - SExpRef filename = CAR(i); - SExpRef linenum = CADR(i); - SExpRef sym = CADDR(i); - str_builder_append(&sb, " %s:%d %s\n", REF(filename)->str, REF(linenum)->integer, REF(sym)->str); - } - return sb.buf; -} - -void Interp_init(Interp *self) { - self->recursion_depth = 0; - self->gensym_cnt = 42; - self->parser = malloc(sizeof(Parser)); - Parser_init(self->parser); - self->parser->ctx = self; - self->errmsg_buf = malloc(BUFSIZE); - SExpVector_init(&self->objs); - IntVector_init(&self->empty_space); - SExpRef2SExpRefHashTable_init(&self->topbindings); - String2IntHashTable_init(&self->symbols); - int i = 0; - SExp sexp; - sexp.marked = false; - sexp.type = kNilSExp; - SExpVector_push_back(&self->objs, sexp); - self->nil = (SExpRef){i}; i++; - - sexp.type = kEnvSExp; - sexp.env.parent= self->nil; - sexp.env.bindings = self->nil; - SExpVector_push_back(&self->objs, sexp); - self->top_level = (SExpRef){i}; i++; - - sexp.type = kBooleanSExp; - sexp.boolean = true; - SExpVector_push_back(&self->objs, sexp); - self->t= (SExpRef){i}; i++; - - sexp.type = kBooleanSExp; - sexp.boolean = false; - SExpVector_push_back(&self->objs, sexp); - self->f = (SExpRef){i}; i++; - - sexp.type = kEmptySExp; - for (; i < 1024; i++) { - SExpVector_push_back(&self->objs, sexp); - IntVector_push_back(&self->empty_space, i); - } - - self->stack = lisp_cons(self, self->top_level, self->nil); - self->reg = self->nil; - self->stacktrace = self->nil; - - Interp_add_primitive(self, "eval", primitive_eval); - Interp_add_primitive(self, "apply", primitive_apply); - Interp_add_primitive(self, "if", primitive_if); - Interp_add_primitive(self, "cond", primitive_cond); - Interp_add_primitive(self, "while", primitive_while); - Interp_add_primitive(self, "progn", primitive_progn); - Interp_add_primitive(self, "and", primitive_and); - Interp_add_primitive(self, "or", primitive_or); - Interp_add_primitive(self, "let", primitive_let); - Interp_add_primitive(self, "setq", primitive_setq); - Interp_add_primitive(self, "lambda", primitive_lambda); - Interp_add_primitive(self, "function", primitive_function); - Interp_add_primitive(self, "defun", primitive_defun); - Interp_add_primitive(self, "defvar", primitive_defvar); - Interp_add_primitive(self, "defmacro", primitive_defmacro); - Interp_add_primitive(self, "funcall", primitive_funcall); - Interp_add_primitive(self, "quote", primitive_quote); - Interp_add_primitive(self, "quasiquote", primitive_quasi); - Interp_add_primitive(self, "macroexpand-1", primitive_macroexpand1); - Interp_add_primitive(self, "return", primitive_return); - Interp_add_primitive(self, "break", primitive_break); - Interp_add_primitive(self, "continue", primitive_continue); - Interp_add_primitive(self, "assert", primitive_assert); - Interp_add_primitive(self, "assert-error", primitive_assert_error); - Interp_add_primitive(self, "assert-exception", primitive_assert_exception); - Interp_add_primitive(self, "load", primitive_load); - Interp_add_primitive(self, "try", primitive_try); - Interp_add_primitive(self, "unwind-protect", primitive_unwind_protect); - - Interp_add_userfunc(self, "throw", builtin_throw); - Interp_add_userfunc(self, "function?", builtin_functionp); - Interp_add_userfunc(self, "map", builtin_map); - Interp_add_userfunc(self, "filter", builtin_filter); - Interp_add_userfunc(self, "remove", builtin_remove); - Interp_add_userfunc(self, "count", builtin_count); - Interp_add_userfunc(self, "foreach", builtin_foreach); - Interp_add_userfunc(self, "symbol->string", builtin_symbol2string); - Interp_add_userfunc(self, "intern", builtin_intern); - Interp_add_userfunc(self, "gensym", builtin_gensym); - Interp_add_userfunc(self, "float", builtin_float); - Interp_add_userfunc(self, "tan", builtin_tan); - Interp_add_userfunc(self, "asin", builtin_asin); - Interp_add_userfunc(self, "acos", builtin_acos); - Interp_add_userfunc(self, "log2", builtin_log2); - Interp_add_userfunc(self, "pow", builtin_pow); - Interp_add_userfunc(self, "expt", builtin_pow); - Interp_add_userfunc(self, "exp", builtin_exp); - Interp_add_userfunc(self, "sqrt", builtin_sqrt); - Interp_add_userfunc(self, "cbrt", builtin_cbrt); - Interp_add_userfunc(self, "log10", builtin_log10); - Interp_add_userfunc(self, "eq?", builtin_eq); - Interp_add_userfunc(self, "ln", builtin_ln); - Interp_add_userfunc(self, "=", builtin_num_equal); - Interp_add_userfunc(self, "/=", builtin_num_neq); - Interp_add_userfunc(self, "concat", builtin_concat); - Interp_add_userfunc(self, "string", builtin_string); - Interp_add_userfunc(self, "string=", builtin_string_eq); - Interp_add_userfunc(self, "string>=", builtin_string_ge); - Interp_add_userfunc(self, "string<=", builtin_string_le); - Interp_add_userfunc(self, "string>", builtin_string_gt); - Interp_add_userfunc(self, "string<", builtin_string_lt); - Interp_add_userfunc(self, "string/=", builtin_string_neq); - Interp_add_userfunc(self, "split-string", builtin_split_string); - Interp_add_userfunc(self, "strip-string", builtin_strip_string); - Interp_add_userfunc(self, "print", builtin_print); - Interp_add_userfunc(self, "format", builtin_format); - Interp_add_userfunc(self, "truncate", builtin_truncate); - Interp_add_userfunc(self, "mod", builtin_mod); - Interp_add_userfunc(self, "+", builtin_add); - Interp_add_userfunc(self, "-", builtin_sub); - Interp_add_userfunc(self, "*", builtin_mul); - Interp_add_userfunc(self, "/", builtin_div); - Interp_add_userfunc(self, "i/", builtin_idiv); - Interp_add_userfunc(self, ">", builtin_gt); - Interp_add_userfunc(self, "<", builtin_lt); - Interp_add_userfunc(self, ">=", builtin_ge); - Interp_add_userfunc(self, "<=", builtin_le); - Interp_add_userfunc(self, "abs", builtin_abs); - Interp_add_userfunc(self, "list", builtin_list); - Interp_add_userfunc(self, "car", builtin_car); - Interp_add_userfunc(self, "sin", builtin_sin); - Interp_add_userfunc(self, "max", builtin_max); - Interp_add_userfunc(self, "exit", builtin_exit); - Interp_add_userfunc(self, "not", builtin_not); - Interp_add_userfunc(self, "cos", builtin_cos); - Interp_add_userfunc(self, "princ", builtin_princ); - Interp_add_userfunc(self, "equal?", builtin_equal); - Interp_add_userfunc(self, "atan", builtin_atan); - Interp_add_userfunc(self, "cons", builtin_cons); - Interp_add_userfunc(self, "cdr", builtin_cdr); - Interp_add_userfunc(self, "ceiling", builtin_ceiling); - Interp_add_userfunc(self, "round", builtin_round); - Interp_add_userfunc(self, "floor", builtin_floor); - Interp_add_userfunc(self, "min", builtin_min); - Interp_add_userfunc(self, "error", builtin_error); - Interp_add_userfunc(self, "set-car", builtin_set_car); - Interp_add_userfunc(self, "set-cdr", builtin_set_cdr); - Interp_add_userfunc(self, "length", builtin_length); - Interp_add_userfunc(self, "nth", builtin_nth); - Interp_add_userfunc(self, "nthcdr", builtin_nthcdr); - Interp_add_userfunc(self, "list?", builtin_listp); - Interp_add_userfunc(self, "cons?", builtin_consp); - Interp_add_userfunc(self, "atom?", builtin_atomp); - Interp_add_userfunc(self, "null?", builtin_nullp); - Interp_add_userfunc(self, "member?", builtin_memberp); - Interp_add_userfunc(self, "number?", builtin_numberp); - Interp_add_userfunc(self, "integer?", builtin_integerp); - Interp_add_userfunc(self, "float?", builtin_floatp); - Interp_add_userfunc(self, "nreverse", builtin_nreverse); - Interp_add_userfunc(self, "reverse", builtin_reverse); - Interp_add_userfunc(self, "last", builtin_last); - Interp_add_userfunc(self, "char?", builtin_charp); - Interp_add_userfunc(self, "char=", builtin_char_eq); - Interp_add_userfunc(self, "char>", builtin_char_gt); - Interp_add_userfunc(self, "char<", builtin_char_lt); - Interp_add_userfunc(self, "char>=", builtin_char_ge); - Interp_add_userfunc(self, "char<=", builtin_char_le); - Interp_add_userfunc(self, "char/=", builtin_char_neq); - Interp_add_userfunc(self, "int->char", builtin_int2char); - Interp_add_userfunc(self, "char->int", builtin_char2int); - Interp_add_userfunc(self, "alphabetic?", builtin_alphabeticp); - Interp_add_userfunc(self, "numeric?", builtin_numericp); - Interp_add_userfunc(self, "alphanum?", builtin_alphanump); - Interp_add_userfunc(self, "set-nth", builtin_setnth); - Interp_add_userfunc(self, "set-nthcdr", builtin_setnthcdr); - Interp_add_userfunc(self, "foldl", builtin_foldl); - Interp_add_userfunc(self, "append", builtin_append); - Interp_add_userfunc(self, "nconc", builtin_nconc); - Interp_add_userfunc(self, "logand", builtin_logand); - Interp_add_userfunc(self, "logior", builtin_logior); - Interp_add_userfunc(self, "logxor", builtin_logxor); - Interp_add_userfunc(self, "lognot", builtin_lognot); - Interp_add_userfunc(self, "lsh", builtin_lsh); - Interp_add_userfunc(self, "ash", builtin_ash); - - Interp_add_userfunc(self, "_gcstat", builtin_gcstat); - Interp_add_userfunc(self, "_alwaysgc", builtin_alwaysgc); - - // extentions - bamboo_lisp_init_vector(self); - - SExpRef ret = Interp_eval_string(self, bamboo_lisp_prelude); - Interp *interp = self; - if (VALTYPE(ret) == kErrSignal) { - fprintf(stderr, "Failed to load prelude: %s", REF(ret)->str); - } - if (VALTYPE(ret) == kExceptionSignal) { - const char *exception_str = lisp_to_string(interp, Interp_ref(self, ret)->ret); - fprintf(stderr, "Failed to load prelude, uncatched exception: %s\n", exception_str); - free((void*)exception_str); - } -} - - -SExpRef Interp_eval_string(Interp *interp, const char * str) { - Parser_set_string(interp->parser, str); - SExpRef sexp, ret; - ParseResult parse_result; - while (1) { - parse_result = parse_sexp(interp->parser); - if (parse_result.errmsg != NULL) { - ret = new_error(interp, "Parsing error: %s", parse_result.errmsg); - goto end; - } - ret = lisp_eval(interp, parse_result.val, false); - if (Interp_ref(interp, ret)->type == kErrSignal - || Interp_ref(interp, ret)->type == kExceptionSignal) { - goto end; - } - if (Interp_ref(interp, ret)->type == kBreakSignal - || Interp_ref(interp, ret)->type == kContinueSignal - || Interp_ref(interp, ret)->type == kReturnSignal) { - ret = new_error(interp, "Eval error: unexpected control flow signal.\n"); - goto end; - } - if (Parser_is_end(interp->parser)) goto end; - } -end: - return ret; -} - -SExpRef Interp_load_file(Interp *interp, const char *filename) { - FILE *fp = NULL; - fp = fopen(filename, "r"); - if (fp == NULL) { - return new_error(interp, "Failed to open file: %s\n", filename); - goto end; - } - Parser_set_file(interp->parser, fp); - SExpRef sexp, ret; - ParseResult parse_result; - SExpRef old_filename = interp->filename; - int old_linenum = interp->linenum; - interp->filename = new_string(interp, filename); - interp->linenum = 1; - while (1) { - parse_result = parse_sexp(interp->parser); - if (parse_result.errmsg != NULL) { - ret = new_error(interp, "Parsing error: %s", parse_result.errmsg); - goto end; - } - ret = lisp_eval(interp, parse_result.val, false); - if (Interp_ref(interp, ret)->type == kErrSignal - || Interp_ref(interp, ret)->type == kExceptionSignal) { - goto end; - } - if (Interp_ref(interp, ret)->type == kBreakSignal - || Interp_ref(interp, ret)->type == kContinueSignal - || Interp_ref(interp, ret)->type == kReturnSignal) { - ret = new_error(interp, "Eval error: unexpected control flow signal.\n"); - goto end; - } - if (Parser_is_end(interp->parser)) goto end; - } -end: - interp->filename = old_filename; - interp->linenum = old_linenum; - fclose(fp); - return ret; -} - -void Interp_add_userfunc(Interp *interp, const char *name, LispUserFunc fn) { - SExpRef userfunc = new_userfunc(interp, fn); - SExpRef sym = new_symbol(interp, name); - lisp_defun(interp, sym, userfunc); -} - -void Interp_free(Interp *self) { - for (size_t i = 0; i < SExpVector_len(&self->objs); i++) { - SExp *obj = SExpVector_ref(&self->objs, i); - if (obj->type == kStringSExp) { - free((void*)obj->str); - } - if (obj->type == kUserDataSExp) { - if (obj->userdata_meta && obj->userdata_meta->free) { - (*obj->userdata_meta->free)(obj->userdata); - } - } - } - for (String2IntHashTableIter iter = String2IntHashTable_begin(&self->symbols); - iter != NULL; - iter = String2IntHashTable_next(&self->symbols, iter)) { - free((void*)iter->key); - } - String2IntHashTable_free(&self->symbols); - SExpVector_free(&self->objs); - IntVector_free(&self->empty_space); - SExpRef2SExpRefHashTable_free(&self->topbindings); - free(self->errmsg_buf); - Parser_free(self->parser); - free(self->parser); -} - -SExp* Interp_ref(Interp *self, SExpRef ref) { - if (ref.idx > SExpVector_len(&self->objs)) return NULL; - SExp *res = SExpVector_ref(&self->objs, ref.idx); - return res; -} - -void Interp_add_primitive(Interp *self, const char *name, LispPrimitive fn) { - SExpRef sym = new_symbol(self, name); - SExpRef prim = new_primitive(self, fn); - lisp_defun(self, sym, prim); -} - -void Interp_gc(Interp *interp, SExpRef tmproot) { - int freesize = IntVector_len(&interp->empty_space); - int heapsize = SExpVector_len(&interp->objs); - if (freesize > (heapsize >> 4) && !interp->alwaysgc) { - return; - } - SExpPtrVector gcstack; - SExpPtrVector_init(&gcstack); - // add root - SExpPtrVector_push_back(&gcstack, REF(tmproot)); - SExpPtrVector_push_back(&gcstack, REF(interp->nil)); - SExpPtrVector_push_back(&gcstack, REF(interp->t)); - SExpPtrVector_push_back(&gcstack, REF(interp->f)); - SExpPtrVector_push_back(&gcstack, REF(interp->stack)); - SExpPtrVector_push_back(&gcstack, REF(interp->top_level)); - SExpPtrVector_push_back(&gcstack, REF(interp->reg)); - SExpPtrVector_push_back(&gcstack, REF(interp->stacktrace)); - // mark - while (!SExpPtrVector_empty(&gcstack)) { - SExpPtr obj = *SExpPtrVector_last(&gcstack); - SExpPtr child; - SExpPtrVector_pop(&gcstack); - if (!obj) continue; - if (obj->marked) continue; - obj->marked = true; - if (obj->type == kPairSExp) { - child = REF(obj->pair.car); - if (child && !child->marked) SExpPtrVector_push_back(&gcstack, child); - child = REF(obj->pair.cdr); - if (child && !child->marked) SExpPtrVector_push_back(&gcstack, child); - child = REF(obj->pair.filename); - if (child && !child->marked) SExpPtrVector_push_back(&gcstack, child); - } else if (obj->type == kFuncSExp) { - child = REF(obj->func.args); - if (child && !child->marked) SExpPtrVector_push_back(&gcstack, child); - child = REF(obj->func.body); - if (child && !child->marked) SExpPtrVector_push_back(&gcstack, child); - child = REF(obj->func.env); - if (child && !child->marked) SExpPtrVector_push_back(&gcstack, child); - } else if (obj->type == kEnvSExp) { - child = REF(obj->env.bindings); - if (child && !child->marked) SExpPtrVector_push_back(&gcstack, child); - child = REF(obj->env.parent); - if (child && !child->marked) SExpPtrVector_push_back(&gcstack, child); - } else if (obj->type == kBindingSExp) { - child = REF(obj->binding.name); - if (child && !child->marked) SExpPtrVector_push_back(&gcstack, child); - child = REF(obj->binding.value); - if (child && !child->marked) SExpPtrVector_push_back(&gcstack, child); - child = REF(obj->binding.func); - if (child && !child->marked) SExpPtrVector_push_back(&gcstack, child); - child = REF(obj->binding.next); - if (child && !child->marked) SExpPtrVector_push_back(&gcstack, child); - } else if (obj->type == kMacroSExp) { - child = REF(obj->macro.args); - if (child && !child->marked) SExpPtrVector_push_back(&gcstack, child); - child = REF(obj->macro.body); - if (child && !child->marked) SExpPtrVector_push_back(&gcstack, child); - } else if (obj->type == kReturnSignal) { - child = REF(obj->ret); - if (child && !child->marked) SExpPtrVector_push_back(&gcstack, child); - } else if (obj->type == kTailcallSExp) { - child = REF(obj->tailcall.args); - if (child && !child->marked) SExpPtrVector_push_back(&gcstack, child); - child = REF(obj->tailcall.fn); - if (child && !child->marked) SExpPtrVector_push_back(&gcstack, child); - } else if (obj->type == kUserDataSExp) { - if (obj->userdata_meta && obj->userdata_meta->gcmark) { - (*obj->userdata_meta->gcmark)(interp, &gcstack, obj->userdata); - } - } - } - SExpPtrVector_free(&gcstack); - // sweep - for (int i = 0; i < SExpVector_len(&interp->objs); i++) { - SExp *obj = SExpVector_ref(&interp->objs, i); - if (obj->marked) { - obj->marked = false; - continue; - } - if (obj->type == kSymbolSExp) continue; - if (obj->type == kEmptySExp) continue; - if (obj->type == kStringSExp) free((void*)obj->str); - if (obj->type == kUserDataSExp) { - if (obj->userdata_meta && obj->userdata_meta->free) { - (*obj->userdata_meta->free)(obj->userdata); - } - } - obj->type = kEmptySExp; - IntVector_push_back(&interp->empty_space, i); - } - // enlarge heap - heapsize = SExpVector_len(&interp->objs); - int usedsize = heapsize - IntVector_len(&interp->empty_space); - if (heapsize < usedsize * 4) { - SExp sexp; - sexp.marked = false; - sexp.type = kEmptySExp; - while (SExpVector_len(&interp->objs) < usedsize * 4) { - SExpVector_push_back(&interp->objs, sexp); - IntVector_push_back(&interp->empty_space, SExpVector_len(&interp->objs) - 1); - } - } -} - -bool lisp_truep(Interp *interp, SExpRef a) { - if (REF(a)->type == kNilSExp) return false; - if (REF(a)->type == kBooleanSExp && !REF(a)->boolean) return false; - return true; -} - -SExpRef lisp_cons(Interp *interp, SExpRef a, SExpRef b) { - SExpRef obj = new_sexp(interp); - REF(obj)->type = kPairSExp; - REF(obj)->pair.car = a; - REF(obj)->pair.cdr = b; - REF(obj)->pair.filename = NIL; - REF(obj)->pair.line = -1; - return obj; -} - -SExpRef lisp_dup(Interp *interp, SExpRef arg) { - SExpRef obj = new_sexp(interp); - *REF(obj) = *REF(arg); - return obj; -} - -SExpRef lisp_car(Interp *interp, SExpRef arg) { - if (REF(arg)->type != kPairSExp) { - return new_error(interp, "car: wrong argument type."); - } - return REF(arg)->pair.car; -} - -SExpRef lisp_cdr(Interp *interp, SExpRef arg) { - if (REF(arg)->type != kPairSExp) { - return new_error(interp, "cdr: wrong argument type."); - } - return REF(arg)->pair.cdr; -} - -bool lisp_check_list(Interp *interp, SExpRef lst) { - while (REF(lst)->type == kPairSExp) { - lst = CDR(lst); - } - return REF(lst)->type == kNilSExp; -} - -void lisp_to_string_impl(str_builder_t *sb, Int2IntHashTable *visited, Interp *interp, SExpRef val) { - SExp *pe = REF(val); - if (pe->type == kIntegerSExp) { - str_builder_append(sb, "%"PRId64, pe->integer); - } else if (pe->type == kRealSExp) { - str_builder_append(sb, "%lg", pe->real); - } else if (pe->type == kCharSExp) { - str_builder_append(sb, "#\\%c", pe->character); - } else if (pe->type == kBooleanSExp) { - if (pe->boolean) str_builder_append(sb, "#t"); - else str_builder_append(sb, "#f"); - } else if (pe->type == kCharSExp) { - str_builder_append(sb, "#\%c", pe->character); - } else if (pe->type == kSymbolSExp) { - str_builder_append(sb, "%s", pe->str); - } else if (pe->type == kStringSExp) { - str_builder_append(sb, "\"%s\"", pe->str); - } else if (pe->type == kFuncSExp) { - str_builder_append(sb, "<FUNCTION>"); - } else if (pe->type == kUserFuncSExp) { - str_builder_append(sb, "<FUNCTION>"); - } else if (pe->type == kMacroSExp) { - str_builder_append(sb, "<MACRO>"); - } else if (pe->type == kEnvSExp) { - str_builder_append(sb, "<ENV>"); - } else if (pe->type == kBindingSExp) { - str_builder_append(sb, "<BINDING>"); - } else if (pe->type == kNilSExp) { - str_builder_append(sb, "()"); - } else if (pe->type == kErrSignal) { - str_builder_append(sb, "<ERROR>"); - } else if (pe->type == kExceptionSignal) { - str_builder_append(sb, "<EXCEPTION>"); - } else if (pe->type == kReturnSignal) { - str_builder_append(sb, "<RETURN>"); - } else if (pe->type == kBreakSignal) { - str_builder_append(sb, "<BREAK>"); - } else if (pe->type == kContinueSignal) { - str_builder_append(sb, "<CONTINUE>"); - } else if (pe->type == kTailcallSExp) { - str_builder_append(sb, "<TAILCALL>"); - } else if (pe->type == kUserDataSExp) { - str_builder_append(sb, "<USERDATA>"); - } else if (pe->type == kPairSExp) { - if (Int2IntHashTable_find(visited, val.idx) != NULL) { - str_builder_append(sb, "<%d>", val.idx); - } else { - str_builder_append_char(sb, '('); - SExpRef cur = val; - while (REF(cur)->type == kPairSExp - && Int2IntHashTable_find(visited, cur.idx) == NULL) { - Int2IntHashTable_insert(visited, cur.idx, 1); - lisp_to_string_impl(sb, visited, interp, CAR(cur)); - str_builder_append_char(sb, ' '); - cur = CDR(cur); - } - if (REF(cur)->type == kNilSExp) { - sb->buf[sb->size - 1] = ')'; - } else if (REF(cur)->type != kPairSExp) { - str_builder_append(sb, ". "); - lisp_to_string_impl(sb, visited, interp, cur); - str_builder_append(sb, ")"); - } else { - str_builder_append(sb, "<%d>)", cur.idx); - } - } - } -} - - -const char* lisp_to_string(Interp *interp, SExpRef val) { - str_builder_t sb; - Int2IntHashTable visited; - Int2IntHashTable_init(&visited); - init_str_builder(&sb); - lisp_to_string_impl(&sb, &visited, interp, val); - str_builder_append_char(&sb, '\0'); - Int2IntHashTable_free(&visited); - return sb.buf; -} - -SExpRef lisp_macroexpand1(Interp *interp, SExpRef macro, SExpRef args) { - SExpRef fn = new_lambda(interp, REF(macro)->macro.args, REF(macro)->macro.body, interp->top_level); - PUSH_REG(fn); - SExpRef ret = lisp_call(interp, fn, args); - POP_REG(); - return ret; -error: - return new_error(interp, "macroexpand: syntax error.\n"); -} - -void lisp_defun(Interp *interp, SExpRef name, SExpRef val) { - SExpRef binding = REF(interp->top_level)->env.bindings; - while (REF(binding)->type != kNilSExp) { - if (name.idx == REF(binding)->binding.name.idx) { - REF(binding)->binding.func = val; - return; - } - binding = REF(binding)->binding.next; - } - binding = REF(interp->top_level)->env.bindings; - SExpRef newbinding = new_binding(interp, name, NIL); - REF(newbinding)->binding.func = val; - REF(newbinding)->binding.value = UNBOUND; - REF(newbinding)->binding.next = binding; - REF(interp->top_level)->env.bindings = newbinding; - SExpRef2SExpRefHashTable_insert(&interp->topbindings, name, newbinding); -} - -void lisp_defvar(Interp *interp, SExpRef name, SExpRef val) { - SExpRef binding = REF(interp->top_level)->env.bindings; - while (REF(binding)->type != kNilSExp) { - if (name.idx == REF(binding)->binding.name.idx) { - REF(binding)->binding.value = val; - return; - } - binding = REF(binding)->binding.next; - } - binding = REF(interp->top_level)->env.bindings; - SExpRef newbinding = new_binding(interp, name, NIL); - REF(newbinding)->binding.func = UNBOUND; - REF(newbinding)->binding.value = val; - REF(newbinding)->binding.next = binding; - REF(interp->top_level)->env.bindings = newbinding; - SExpRef2SExpRefHashTable_insert(&interp->topbindings, name, newbinding); -} - -SExpRef lisp_setq(Interp *interp, SExpRef name, SExpRef val) { - SExpRef env = CAR(interp->stack); - while (REF(env)->type != kNilSExp) { - SExpRef binding = REF(env)->env.bindings; - while (REF(binding)->type != kNilSExp) { - if (name.idx == REF(binding)->binding.name.idx) { - REF(binding)->binding.value = val; - return val; - } - binding = REF(binding)->binding.next; - } - env = REF(env)->env.parent; - } - return new_error(interp, "Unbound variable: %s.\n", REF(name)->str); -} - -SExpRef lisp_lookup_topvar(Interp *interp, SExpRef name); - -SExpRef lisp_lookup(Interp *interp, SExpRef name) { - SExpRef env = CAR(interp->stack); - while (REF(env)->type != kNilSExp) { - if (env.idx == interp->top_level.idx) { - return lisp_lookup_topvar(interp, name); - } - SExpRef binding = REF(env)->env.bindings; - while (REF(binding)->type != kNilSExp) { - if (name.idx == REF(binding)->binding.name.idx) { - SExpRef ret = REF(binding)->binding.value; - if (ret.idx < 0) goto notfound; - return ret; - } - binding = REF(binding)->binding.next; - } - env = REF(env)->env.parent; - } -notfound: - return new_error(interp, "Unbound variable: %s.\n", REF(name)->str); -} - -void lisp_print(Interp *interp, SExpRef obj, FILE *fp) { - const char *str = lisp_to_string(interp, obj); - fprintf(fp, "%s\n", str); - free((void*)str); -} - -SExpRef lisp_lookup_topvar(Interp *interp, SExpRef name) { - SExpRef *pbinding = SExpRef2SExpRefHashTable_get(&interp->topbindings, name); - if (pbinding == NULL) goto notfound; - SExpRef ret = REF(*pbinding)->binding.value; - if (ret.idx < 0) goto notfound; - return ret; -notfound: - return new_error(interp, "Unbound variable: %s.\n", REF(name)->str); -} - -SExpRef lisp_lookup_func(Interp *interp, SExpRef name) { - SExpRef *pbinding = SExpRef2SExpRefHashTable_get(&interp->topbindings, name); - if (pbinding == NULL) goto notfound; - SExpRef ret = REF(*pbinding)->binding.func; - if (ret.idx < 0) goto notfound; - return ret; -notfound: - return new_error(interp, "Unbound function: %s.\n", REF(name)->str); -} - -bool lisp_nilp(Interp *interp, SExpRef obj) { - return REF(obj)->type == kNilSExp; -} - -SExpRef lisp_reverse(Interp *interp, SExpRef lst) { - SExpRef cur = lst; - SExpRef ret = NIL; - while (!NILP(cur)) { - ret = CONS(CAR(cur), ret); - cur = CDR(cur); - } - return ret; -} - -SExpRef lisp_nreverse(Interp *interp, SExpRef lst) { - SExpRef prev = NIL; - SExpRef cur = lst; - SExpRef next_node; - - while (!NILP(cur)) { - next_node = CDR(cur); - REF(cur)->pair.cdr = prev; - prev = cur; - cur = next_node; - } - return prev; -} - -SExpRef lisp_eval_args(Interp *interp, SExpRef args) { - SExpRef ret = interp->nil; - SExpRef cur = args; - SExpRef evalres; - - while (!NILP(cur)) { - // save ret in register - PUSH_REG(ret); - evalres = EVAL(CAR(cur)); - POP_REG(); - if (CTL_FL(evalres)) { - ret = evalres; - goto end; - } - ret = CONS(evalres, ret); - cur = CDR(cur); - } - ret = lisp_nreverse(interp, ret); -end: - Interp_gc(interp, ret); - return ret; -} - -int lisp_length(Interp *interp, SExpRef lst) { - int cnt = 0; - if (VALTYPE(lst) == kNilSExp) { - return 0; - } else if (VALTYPE(lst) == kPairSExp) { - while (REF(lst)->type == kPairSExp) { - cnt++; - lst = CDR(lst); - } - return cnt; - } else if (VALTYPE(lst) == kStringSExp) { - return strlen(REF(lst)->str); - } else return -1; -} - -static SExpRef build_function_env(Interp *interp, SExpRef func, SExpRef args) { - SExpRef param = REF(func)->func.args; - SExpRef iparam = param; - SExpRef iargs = args; - SExpRef env = new_env(interp); - REF(env)->env.parent = REF(func)->func.env; - while (!NILP(iparam)) { - if (VALTYPE(iparam) == kSymbolSExp) { - SExpRef 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); - 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)); - REF(binding)->binding.next = REF(env)->env.bindings; - REF(env)->env.bindings = binding; - iargs = CDR(iargs); - iparam = CDR(iparam); - } - if (!NILP(iargs)) return new_error(interp, "funcall: wrong argument number.\n"); - return env; -} - -SExpRef lisp_call(Interp *interp, SExpRef fn, SExpRef args) { - SExpRef ret = lisp_apply(interp, fn, args, false); - while (VALTYPE(ret) == kTailcallSExp) { - fn = REF(ret)->tailcall.fn; - args = REF(ret)->tailcall.args; - PUSH_REG(ret); - ret = lisp_apply(interp, fn, args, false); - POP_REG(); - if (CTL_FL(ret)) break; - } - if (VALTYPE(ret) == kBreakSignal - || VALTYPE(ret) == kContinueSignal - || VALTYPE(ret) == kReturnSignal) { - return new_error(interp, "call: unexpected control flow signal.\n"); - } - return ret; -} - -SExpRef lisp_apply(Interp *interp, SExpRef fn, SExpRef args, bool istail) { - if (interp->recursion_depth > 2048) - return new_error(interp, "apply: stack overflow.\n"); - interp->recursion_depth++; - SExpRef exp, env, ret, iter; - if (istail) { - interp->recursion_depth--; - return new_tailcall(interp, fn, args); - } - if (VALTYPE(fn) == kFuncSExp) { - env = build_function_env(interp, fn, args); - if (CTL_FL(env)) { - interp->recursion_depth--; - return env; - } - interp->stack = CONS(env, interp->stack); - iter = REF(fn)->func.body; - while (!NILP(iter)) { - exp = CAR(iter); - if (NILP(CDR(iter))) { - ret = lisp_eval(interp, exp, true); - goto end; - } else { - ret = EVAL(exp); - } - if (CTL_FL(ret)) goto end; - iter = CDR(iter); - } - } else if (VALTYPE(fn) == kUserFuncSExp) { - LispUserFunc fnptr = REF(fn)->userfunc; - PUSH_REG(args); - ret = (*fnptr)(interp, args); - POP_REG(); - interp->recursion_depth--; - return ret; - } -end: - if (VALTYPE(ret) == kBreakSignal || VALTYPE(ret) == kContinueSignal) { - ret = new_error(interp, "function call: unexpected control flow signal.\n"); - } - if (VALTYPE(ret) == kReturnSignal) { - ret = REF(ret)->ret; - } - interp->stack = CDR(interp->stack); - interp->recursion_depth--; - return ret; -} - - -SExpRef lisp_eval(Interp *interp, SExpRef sexp, bool istail) { - if (interp->recursion_depth > 2048) { - return new_error(interp, "eval: stack overflow.\n"); - } - interp->recursion_depth++; - SExpRef ret; - SExpType type; - PUSH_REG(sexp); - type = REF(sexp)->type; - if (type == kEnvSExp || type == kEnvSExp || type == kBindingSExp) { - ret = new_error(interp, "type error: cannot eval.\n"); - goto end; - } - if (type == kIntegerSExp - || type == kStringSExp - || type == kBooleanSExp - || type == kCharSExp - || type == kErrSignal - || type == kExceptionSignal - || type == kBreakSignal - || type == kContinueSignal - || type == kReturnSignal - || type == kTailcallSExp - || type == kFuncSExp - || type == kUserFuncSExp - || type == kRealSExp) { - ret = sexp; - goto end; - } - if (type == kSymbolSExp) { - ret = lisp_lookup(interp, sexp); - goto end; - } - SExpRef fn, funcallargs, args; - SExpRef filename = NIL; - SExpRef sym = NIL; - int line = -1; - if (type == kPairSExp) { - if (!lisp_check_list(interp, sexp)) { - ret = new_error(interp, "eval: list not proper.\n"); - goto end; - } - if (REF(CAR(sexp))->type != kSymbolSExp) { - ret = new_error(interp, "eval: first elem must be a symbol.\n"); - goto end; - } - if (!NILP(REF(sexp)->pair.filename)) { - line = REF(sexp)->pair.line; - filename = REF(sexp)->pair.filename; - sym = REF(sexp)->pair.car; - } - SExpRef symbol = CAR(sexp); - fn = lisp_lookup_func(interp, symbol); - if (CTL_FL(fn)) { - ret = new_error(interp, "eval: \"%s\" is not a primitive, function, " - "or macro.\n", REF(symbol)->str); - goto end; - } - if (VALTYPE(fn) == kPrimitiveSExp) { - LispPrimitive primitive_fn = REF(fn)->primitive; - ret = (*primitive_fn)(interp, CDR(sexp), istail); - if (VALTYPE(ret) == kTailcallSExp && !istail) { - fn = REF(ret)->tailcall.fn; - args = REF(ret)->tailcall.args; - goto tailcall; - } - goto end; - } else if (VALTYPE(fn) == kFuncSExp || VALTYPE(fn) == kUserFuncSExp) { - args = CDR(sexp); - funcallargs = CONS(fn, args); - PUSH_REG(funcallargs); - ret = primitive_funcall(interp, funcallargs, istail); - POP_REG(); - if (VALTYPE(ret) == kTailcallSExp && !istail) { - fn = REF(ret)->tailcall.fn; - args = REF(ret)->tailcall.args; - goto tailcall; - } - goto end; - } else if (VALTYPE(fn) == kMacroSExp) { - SExpRef args = CDR(sexp); - SExpRef newast = lisp_macroexpand1(interp, fn, args); - PUSH_REG(newast); - ret = lisp_eval(interp, newast, istail); - POP_REG(); - goto end; - } else { - ret = new_error(interp, - "eval: fatal binding eval, %s is not a func, prim " - "or macro.\n", REF(symbol)->str); - goto end; - } - } - ret = new_error(interp, "eval: unknown syntax.\n"); -end: - if (VALTYPE(ret) == kErrSignal || VALTYPE(ret) == kExceptionSignal) { - if (!NILP(filename)) { - interp->stacktrace = - CONS(CONS(filename, CONS(new_integer(interp, line), CONS(sym, NIL))), - interp->stacktrace); - } - } - POP_REG(); - Interp_gc(interp, ret); - interp->recursion_depth--; - return ret; -tailcall: - while (1) { - PUSH_REG(CONS(fn, args)); - ret = lisp_apply(interp, fn, args, false); - POP_REG(); - if (VALTYPE(ret) != kTailcallSExp) break; - fn = REF(ret)->tailcall.fn; - args = REF(ret)->tailcall.args; - } - goto end; -} - -SExpRef new_sexp(Interp *interp) { - if (IntVector_len(&interp->empty_space) == 0) { - SExp sexp; - sexp.type = kEmptySExp; - sexp.marked = false; - SExpVector_push_back(&interp->objs, sexp); - return (SExpRef){ SExpVector_len(&interp->objs) - 1 }; - } - int idx = *IntVector_ref(&interp->empty_space, IntVector_len(&interp->empty_space) - 1); - IntVector_pop(&interp->empty_space); - return (SExpRef){idx}; -} - -SExpRef new_env(Interp *interp) { - SExpRef ret = new_sexp(interp); - REF(ret)->type = kEnvSExp; - REF(ret)->env.parent = NIL; - REF(ret)->env.bindings = NIL; - return ret; -} - -SExpRef new_tailcall(Interp *interp, SExpRef fn, SExpRef args) { - SExpRef ret = new_sexp(interp); - REF(ret)->type = kTailcallSExp; - REF(ret)->tailcall.fn = fn; - REF(ret)->tailcall.args= args; - return ret; -} - -SExpRef new_lambda(Interp *interp, SExpRef param, SExpRef body, SExpRef env) { - SExpRef ret = new_sexp(interp); - REF(ret)->type = kFuncSExp; - REF(ret)->func.args = param; - REF(ret)->func.body = body; - REF(ret)->func.env = env; - return ret; -} - -SExpRef new_macro(Interp *interp, SExpRef param, SExpRef body) { - SExpRef ret = new_sexp(interp); - REF(ret)->type = kMacroSExp; - REF(ret)->macro.args = param; - REF(ret)->macro.body = body; - return ret; -} - -SExpRef new_binding(Interp *interp, SExpRef sym, SExpRef val) { - SExpRef ret = new_sexp(interp); - REF(ret)->type = kBindingSExp; - REF(ret)->binding.name = sym; - REF(ret)->binding.value = val; - REF(ret)->binding.func = UNBOUND; - REF(ret)->binding.next = NIL; - return ret; -} - -SExpRef new_boolean(Interp *interp, bool val) { - if (val) return interp->t; - return interp->f; -} - -SExpRef new_error(Interp *interp, const char *format, ...) { - va_list args; - va_start(args, format); - vsnprintf(interp->errmsg_buf, BUFSIZE, format, args); - va_end(args); - SExpRef ret = new_sexp(interp); - REF(ret)->type = kErrSignal; - REF(ret)->str = interp->errmsg_buf; - return ret; -} - -SExpRef new_userfunc(Interp *interp, LispUserFunc val) { - SExpRef ret = new_sexp(interp); - REF(ret)->type = kUserFuncSExp; - REF(ret)->userfunc = val; - return ret; -} - -SExpRef new_char(Interp *interp, char val) { - SExpRef ret = new_sexp(interp); - SExp *psexp = Interp_ref(interp, ret); - psexp->type = kCharSExp; - psexp->character = val; - return ret; -} - -SExpRef new_integer(Interp *interp, int64_t val) { - SExpRef ret = new_sexp(interp); - SExp *psexp = Interp_ref(interp, ret); - psexp->type = kIntegerSExp; - psexp->integer = val; - return ret; -} - -SExpRef new_real(Interp *interp, double val) { - SExpRef ret = new_sexp(interp); - SExp *psexp = Interp_ref(interp, ret); - psexp->type = kRealSExp; - psexp->real = val; - return ret; -} - -SExpRef new_string(Interp *interp, const char *val) { - char *dup = strdup(val); - SExpRef ret = new_sexp(interp); - SExp *psexp = Interp_ref(interp, ret); - psexp->type = kStringSExp; - psexp->str = dup; - return ret; -} - -SExpRef new_symbol(Interp *interp, const char *val) { - String2IntHashTableIter iter = String2IntHashTable_find(&interp->symbols, val); - if (iter == NULL) { - char *dup = strdup(val); - SExpRef ret = new_sexp(interp); - SExp *psexp = Interp_ref(interp, ret); - psexp->type = kSymbolSExp; - psexp->str = dup; - String2IntHashTable_insert(&interp->symbols, dup, ret.idx); - return ret; - } else { - return (SExpRef){ iter->val }; - } -} - -SExpRef new_return(Interp *interp, SExpRef obj) { - SExpRef ret = new_sexp(interp); - SExp *psexp = Interp_ref(interp, ret); - psexp->type = kReturnSignal; - psexp->ret = obj; - return ret; -} - -SExpRef new_break(Interp *interp) { - SExpRef ret = new_sexp(interp); - SExp *psexp = Interp_ref(interp, ret); - psexp->type = kBreakSignal; - return ret; -} - -SExpRef new_continue(Interp *interp) { - SExpRef ret = new_sexp(interp); - SExp *psexp = Interp_ref(interp, ret); - psexp->type = kContinueSignal; - return ret; -} - -SExpRef new_primitive(Interp *interp, LispPrimitive val) { - SExpRef ret = new_sexp(interp); - REF(ret)->type = kPrimitiveSExp; - REF(ret)->primitive = val; - return ret; -} - -SExpRef new_exception(Interp *interp, SExpRef e) { - SExpRef ret = new_sexp(interp); - REF(ret)->type = kExceptionSignal; - REF(ret)->ret = e; - return ret; -} - -SExpRef new_list2(Interp *interp, SExpRef e1, SExpRef e2) { - return CONS(e1, CONS(e2, NIL)); -} -SExpRef new_list3(Interp *interp, SExpRef e1, SExpRef e2, SExpRef e3); -SExpRef new_list4(Interp *interp, SExpRef e1, SExpRef e2, SExpRef e3, SExpRef e4); -SExpRef new_list5(Interp *interp, SExpRef e1, SExpRef e2, SExpRef e3, SExpRef e4, SExpRef e5); - diff --git a/src/interp.h b/src/interp.h deleted file mode 100644 index 1acd983..0000000 --- a/src/interp.h +++ /dev/null @@ -1,135 +0,0 @@ -#ifndef BAMBOO_LISP_INTERP_H_ -#define BAMBOO_LISP_INTERP_H_ - -#include <stdbool.h> - -#include <algds/hash_table.h> - -#include "algds/vec.h" -#include "sexp.h" - -struct parser; -typedef struct parser Parser; - -struct interp; -typedef struct interp Interp; - -HASH_TABLE_DEF(SExpRef, SExpRef); - -struct interp { - SExpVector objs; - SExpRef2SExpRefHashTable topbindings; - IntVector empty_space; - String2IntHashTable symbols; - SExpRef stack; - SExpRef t; - SExpRef f; - SExpRef reg; - SExpRef top_level; - SExpRef nil; - SExpRef stacktrace; - SExpRef filename; - int32_t linenum; - char *errmsg_buf; - Parser *parser; - int gensym_cnt; - bool alwaysgc; - int recursion_depth; -}; - -void Interp_init(Interp *self); -void Interp_free(Interp *self); -SExp* Interp_ref(Interp *self, SExpRef ref); -void Interp_gc(Interp *self, SExpRef tmp_root); -void Interp_add_primitive(Interp *self, const char *name, LispPrimitive fn); -void Interp_add_userfunc(Interp *self, const char *name, LispUserFunc fn); - -SExpRef Interp_eval_string(Interp *interp, const char * str); -SExpRef Interp_load_file(Interp *interp, const char *filename); - -#define REF(_x) (((_x).idx) >= 0 ? (&(interp->objs.buffer)[(_x).idx]) : NULL) -#define CONS(_x, _y) (lisp_cons(interp, (_x), (_y))) -#define NILP(_x) (lisp_nilp(interp, (_x))) -#define LENGTH(_x) (lisp_length(interp, (_x))) -#define EVAL(_x) (lisp_eval(interp, (_x), false)) -#define EVALTAIL(_x) (lisp_eval(interp, (_x), true)) -#define TRUEP(_x) (lisp_truep(interp, (_x))) -#define FOREACH(_x, _lst) for (SExpRef _x = _lst; !NILP(_x); _x = CDR(_x)) -// control flow -#define CTL_FL(_x) \ - (REF((_x))->type == kErrSignal \ - || REF((_x))->type == kReturnSignal \ - || REF((_x))->type == kExceptionSignal \ - || REF((_x))->type == kBreakSignal \ - || REF((_x))->type == kContinueSignal) -#define VALTYPE(_x) (REF((_x))->type) -#define CALLABLE(_x) (VALTYPE(_x) == kFuncSExp || VALTYPE(_x) == kUserFuncSExp) -#define NIL (interp->nil) -#define CAR(_x) (lisp_car(interp, (_x))) -#define CDR(_x) (lisp_cdr(interp, (_x))) -#define CADR(_x) CAR(CDR(_x)) -#define CDDR(_x) CDR(CDR(_x)) -#define CADDR(_x) CAR(CDDR(_x)) -#define CDDDR(_x) CDR(CDDR(_x)) -#define CADDDR(_x) CAR(CDDDR(_x)) -#define CDDDDR(_x) CDR(CDDDR(_x)) -#define CADDDDR(_x) CAR(CDDDDR(_x)) -#define CDDDDDR(_x) CDR(CDDDDR(_x)) -#define PUSH_REG(_x) { interp->reg = CONS((_x), interp->reg); } -#define POP_REG() { interp->reg = CDR(interp->reg); } - -const char *lisp_stacktrace_to_string(Interp *interp, SExpRef stacktrace); -const char* lisp_to_string(Interp *interp, SExpRef val); -SExpRef lisp_macroexpand1(Interp *interp, SExpRef macro, SExpRef args); -SExpRef lisp_nreverse(Interp *interp, SExpRef lst); -SExpRef lisp_reverse(Interp *interp, SExpRef lst); -void lisp_defun(Interp *interp, SExpRef name, SExpRef val); -void lisp_defvar(Interp *interp, SExpRef name, SExpRef val); -void lisp_print(Interp *interp, SExpRef obj, FILE *fp); -SExpRef lisp_lookup(Interp *interp, SExpRef name); -SExpRef lisp_lookup_func(Interp *interp, SExpRef name); -SExpRef lisp_apply(Interp *interp, SExpRef fn, SExpRef args, bool istail); -SExpRef lisp_call(Interp *interp, SExpRef fn, SExpRef args); -SExpRef lisp_cons(Interp *interp, SExpRef a, SExpRef b); -SExpRef lisp_dup(Interp *interp, SExpRef arg); -bool lisp_nilp(Interp *interp, SExpRef arg); -bool lisp_truep(Interp *interp, SExpRef a); -bool lisp_check_list(Interp *interp, SExpRef lst); -SExpRef lisp_setq(Interp *interp, SExpRef name, SExpRef val); -int lisp_length(Interp *interp, SExpRef lst); -SExpRef lisp_car(Interp *interp, SExpRef arg); -SExpRef lisp_cdr(Interp *interp, SExpRef arg); -SExpRef lisp_eval(Interp *interp, SExpRef arg, bool istail); -SExpRef lisp_eval_args(Interp *interp, SExpRef args); -SExpRef lisp_add(Interp *interp, SExpRef args); -SExpRef lisp_sub(Interp *interp, SExpRef args); -SExpRef lisp_mul(Interp *interp, SExpRef args); -SExpRef lisp_div(Interp *interp, SExpRef args); - -SExpRef new_error(Interp *interp, const char *format, ...); -SExpRef new_sexp(Interp *ctx); -SExpRef new_return(Interp *ctx, SExpRef ret); -SExpRef new_break(Interp *ctx); -SExpRef new_continue(Interp *ctx); -SExpRef new_boolean(Interp *ctx, bool val); -SExpRef new_char(Interp *ctx, char val); -SExpRef new_integer(Interp *ctx, int64_t val); -SExpRef new_real(Interp *ctx, double val); -SExpRef new_string(Interp *ctx, const char *val); -SExpRef new_symbol(Interp *ctx, const char *val); -SExpRef new_env(Interp *ctx); -SExpRef new_binding(Interp *ctx, SExpRef name, SExpRef val); -SExpRef new_userfunc(Interp *interp, LispUserFunc val); -SExpRef new_primitive(Interp *interp, LispPrimitive val); -SExpRef new_lambda(Interp *interp, SExpRef param, SExpRef body, SExpRef env); -SExpRef new_macro(Interp *interp, SExpRef param, SExpRef body); -SExpRef new_tailcall(Interp *interp, SExpRef fn, SExpRef args); -SExpRef new_exception(Interp *interp, SExpRef e); -SExpRef new_list1(Interp *ctx, SExpRef e1); -SExpRef new_list2(Interp *ctx, SExpRef e1, SExpRef e2); -SExpRef new_list3(Interp *ctx, SExpRef e1, SExpRef e2, SExpRef e3); -SExpRef new_list4(Interp *ctx, SExpRef e1, SExpRef e2, SExpRef e3, SExpRef e4); -SExpRef new_list5(Interp *ctx, SExpRef e1, SExpRef e2, SExpRef e3, SExpRef e4, SExpRef e5); - -#endif - diff --git a/src/main.c b/src/main.c deleted file mode 100644 index 1911873..0000000 --- a/src/main.c +++ /dev/null @@ -1,74 +0,0 @@ -#include "interp.h" -#include "parser.h" -#include "sexp.h" - -int main(int argc, char **argv) { - int mainret = 0; - Interp interp; - Interp_init(&interp); - if (argc > 2) { - fprintf(stderr, "Usage: bamboo-lisp [file.lisp]\n"); - return -1; - } - if (argc == 2) { - const char *filename = argv[1]; - SExpRef ret = Interp_load_file(&interp, filename); - if (Interp_ref(&interp, ret)->type == kErrSignal) { - fprintf(stderr, "Error: %s", Interp_ref(&interp, ret)->str); - const char *stacktrace = lisp_stacktrace_to_string(&interp, interp.stacktrace); - fprintf(stderr, "%s", stacktrace); - free((void*)stacktrace); - interp.stacktrace = interp.nil; - mainret = -1; goto end; - } - if (Interp_ref(&interp, ret)->type == kExceptionSignal) { - const char *exception_str = lisp_to_string(&interp, Interp_ref(&interp, ret)->ret); - fprintf(stderr, "Uncatched exception: %s\n", exception_str); - free((void*)exception_str); - const char *stacktrace = lisp_stacktrace_to_string(&interp, interp.stacktrace); - fprintf(stderr, "%s", stacktrace); - free((void*)stacktrace); - interp.stacktrace = interp.nil; - mainret = -1; goto end; - } - } -#ifdef WITHREADLINE - Parser_set_readline(interp.parser); -#else - Parser_set_file(interp.parser, stdin); -#endif - SExpRef sexp, res; - ParseResult parse_result; - while (1) { -#ifndef WITHREADLINE - printf(">>> "); - fflush(stdout); -#endif - parse_result = parse_sexp(interp.parser); - if (parse_result.errmsg != NULL) { - if (Parser_peek(interp.parser) == EOF) goto end; - fprintf(stderr, "Parsing error: %s", parse_result.errmsg); -#ifdef WITHREADLINE - free((void*)interp.parser->string); - Parser_set_readline(interp.parser); -#endif - continue; - } - - res = lisp_eval(&interp, parse_result.val, false); - if (Interp_ref(&interp, res)->type == kErrSignal) { - fprintf(stderr, "Eval error: %s", Interp_ref(&interp, res)->str); - continue; - } - if (Interp_ref(&interp, res)->type == kBreakSignal - || Interp_ref(&interp, res)->type == kContinueSignal - || Interp_ref(&interp, res)->type == kReturnSignal) { - fprintf(stderr, "Eval error: unexpected control flow signal.\n"); - continue; - } - lisp_print(&interp, res, stdout); - } -end: - Interp_free(&interp); - return mainret; -} diff --git a/src/parser.c b/src/parser.c deleted file mode 100644 index f21c90b..0000000 --- a/src/parser.c +++ /dev/null @@ -1,483 +0,0 @@ -#include "parser.h" - -#include <ctype.h> -#include <stdlib.h> -#include <stdarg.h> - -#ifdef WITHREADLINE -#include <readline/readline.h> -#include <readline/history.h> -#endif - -#include "sexp.h" - -#define BUFSIZE 1024 - -static void skip_comment(Parser *parser) { - if (Parser_peek(parser) == ';') { - while (1) { - int peek = Parser_peek(parser); - if (peek == '\n' || peek == EOF) break; - Parser_getchar(parser); - } - } -} - -static void skip_spaces(Parser *parser) { - while (isspace(Parser_peek(parser))) { - Parser_getchar(parser); - } -} - -static void skip_blank(Parser *parser) { - while (1) { - int peek = Parser_peek(parser); - if (!isspace(peek) && peek != ';') { - break; - } - skip_comment(parser); - skip_spaces(parser); - } -} - -bool Parser_is_end(Parser *parser) { - skip_blank(parser); - if (Parser_peek(parser) == EOF) return true; - return false; -} - -ParseResult ParseOk(SExpRef ref) { - return (ParseResult){ .val = ref, .errmsg = NULL }; -} - -ParseResult ParseErr(Parser *parser, const char *format, ...) { - va_list args; - va_start(args, format); - vsnprintf(parser->errmsg_buf, BUFSIZE, format, args); - va_end(args); - return (ParseResult){ .val = {-1}, .errmsg = parser->errmsg_buf }; -} - -bool ParseResult_is_err(ParseResult res) { - if (res.errmsg != NULL) return true; - return false; -} - -void Parser_init(Parser *parser) { - parser->token_buf = malloc(BUFSIZE); - parser->errmsg_buf = malloc(BUFSIZE); -} - -void Parser_free(Parser *parser) { - if (parser->parse_type == kParseReadline) free((void*)parser->string); - free(parser->token_buf); - free(parser->errmsg_buf); -} - -void Parser_set_string(Parser *parser, const char *str) { - parser->parse_type = kParseString; - parser->string = str; - parser->str_cursor = str; -} - -void Parser_set_file(Parser *parser, FILE *fp) { - parser->parse_type = kParseFile; - parser->fp = fp; -} - -#ifdef WITHREADLINE -void Parser_set_readline(Parser *parser) { - stifle_history(100); - parser->parse_type = kParseReadline; - parser->string = NULL; - parser->str_cursor = NULL; - parser->readline_eof = false; -} -#endif - - -int Parser_getchar(Parser *ctx) { - if (ctx->parse_type == kParseString) { - if (*ctx->str_cursor == '\0') return EOF; - int ret = *ctx->str_cursor; - ctx->str_cursor++; - return ret; - } else if (ctx->parse_type == kParseFile) { - int ret = fgetc(ctx->fp); - if (ret == '\n') ctx->ctx->linenum++; - return ret; -#ifdef WITHREADLINE - } else if (ctx->parse_type == kParseReadline) { - if (ctx->readline_eof) return EOF; - if (ctx->string == NULL) { - char *s = readline(">>> "); - if (s == NULL) { - ctx->readline_eof = true; - return EOF; - } - if (s[0] != '\0') { add_history(s); } - ctx->string = s; - ctx->str_cursor = s; - } - if (*ctx->str_cursor == '\0') { - char *s = readline(">>> "); - if (s == NULL) { - ctx->readline_eof = true; - return EOF; - } - if (s[0] != '\0') { add_history(s); } - free((void*)ctx->string); - ctx->string = s; - ctx->str_cursor = s; - return '\n'; - } - int c = *ctx->str_cursor; - ctx->str_cursor++; - return c; -#endif - } - return EOF; -} - -int Parser_peek(Parser *ctx) { - if (ctx->parse_type == kParseString) { - if (*ctx->str_cursor == '\0') return EOF; - int ret = *ctx->str_cursor; - return ret; - } else if (ctx->parse_type == kParseFile) { - int ret = fgetc(ctx->fp); - if (ret == EOF) return EOF; - ungetc(ret, ctx->fp); - return ret; -#ifdef WITHREADLINE - } else if (ctx->parse_type == kParseReadline) { - if (ctx->readline_eof) return EOF; - if (ctx->string == NULL) { - char *s = readline(">>> "); - if (s == NULL) { - ctx->readline_eof = true; - return EOF; - } - if (s[0] != '\0') { add_history(s); } - ctx->string = s; - ctx->str_cursor = s; - } - if (*ctx->str_cursor == '\0') { - return '\n'; - } - int c = *ctx->str_cursor; - return c; -#endif - } - return EOF; -} - -ParseResult parse_sexp(Parser *parser) { - skip_blank(parser); - if (Parser_peek(parser) == EOF) { - return ParseErr(parser, "Unexpected EOF.\n"); - } - int next = Parser_peek(parser); - if (next == ')') { - Parser_getchar(parser); - return ParseErr(parser, "Invalid S-Expression.\n"); - } - if (next == '(') { - return parse_list(parser); - } else if (next == ',') { - Parser_getchar(parser); - if (Parser_peek(parser) == '@') { - Parser_getchar(parser); - return parse_slicing_unquote(parser); - } - return parse_unquote(parser); - } else if (next == '`') { - Parser_getchar(parser); - return parse_quasi(parser); - } else if (next == '\'') { - Parser_getchar(parser); - return parse_quote(parser); - } - return parse_atom(parser); -} - -static ParseResult expect_char(Parser *parser, int chr) { - if (Parser_peek(parser) == EOF) { - return ParseErr(parser, "Unexpected EOF.\n"); - } - if (Parser_peek(parser) == chr) { - Parser_getchar(parser); - return ParseOk(parser->ctx->nil); - } - return ParseErr(parser, "Unexpected character %c.\n", (char)chr); -} - -static ParseResult expect_space(Parser *parser) { - if (Parser_peek(parser) == EOF) { - return ParseErr(parser, "Unexpected EOF.\n"); - } - if (isspace(Parser_peek(parser)) || Parser_peek(parser) == ';') { - return ParseOk(parser->ctx->nil); - } - return ParseErr(parser, "Expect space.\n"); -} - -static ParseResult expect_space_or_end(Parser *parser) { - if (Parser_peek(parser) == EOF) { - return ParseErr(parser, "Unexpected EOF.\n"); - } - if (isspace(Parser_peek(parser)) - || Parser_peek(parser) == ')' - || Parser_peek(parser) == ';') { - return ParseOk(parser->ctx->nil); - } - return ParseErr(parser, "Expect space.\n"); -} - -static SExpRef build_list_from_vector(Interp *ctx, SExpRefVector elems) { - int i = SExpRefVector_len(&elems) - 1; - SExpRef ret = *SExpRefVector_ref(&elems, i); - i--; - for (; i >= 0; i--) { - SExpRef cur = *SExpRefVector_ref(&elems, i); - ret = lisp_cons(ctx, cur, ret); - } - Interp_ref(ctx, ret)->pair.filename = ctx->filename; - Interp_ref(ctx, ret)->pair.line = ctx->linenum; - return ret; -} - -ParseResult parse_list(Parser *parser) { - SExpRefVector elems; - SExpRefVector_init(&elems); - ParseResult ret; - ret = expect_char(parser, '('); - if (ParseResult_is_err(ret)) goto end; - int line = parser->ctx->linenum; - skip_blank(parser); - while (1) { - if (Parser_peek(parser) == EOF) { - ret = ParseErr(parser, "Unexpected EOF.\n"); - goto end; - } - if (Parser_peek(parser) == ')') { - Parser_getchar(parser); - SExpRefVector_push_back(&elems, parser->ctx->nil); - ret = ParseOk(build_list_from_vector(parser->ctx, elems)); - goto end; - } else if (Parser_peek(parser) == '.') { - Parser_getchar(parser); - break; - } - ret = parse_sexp(parser); - if (ParseResult_is_err(ret)) goto end; - SExpRefVector_push_back(&elems, ret.val); - // ret = expect_space_or_end(parser); - // if (ParseResult_is_err(ret)) goto end; - skip_blank(parser); - } - // dot - ret = expect_space(parser); - if (ParseResult_is_err(ret)) goto end; - skip_blank(parser); - ret = parse_sexp(parser); - if (ParseResult_is_err(ret)) goto end; - SExpRefVector_push_back(&elems, ret.val); - skip_blank(parser); - ret = expect_char(parser, ')'); - if (ParseResult_is_err(ret)) goto end; - ret = ParseOk(build_list_from_vector(parser->ctx, elems)); -end: - SExpRefVector_free(&elems); - return ret; -} - -static char *read_token(Parser *parser) { - int i = 0; - while (!isspace(Parser_peek(parser)) - && Parser_peek(parser) != EOF - && Parser_peek(parser) != ')' - && Parser_peek(parser) != '(' - && Parser_peek(parser) != '"' - && Parser_peek(parser) != ';' - && (i == 0 || Parser_peek(parser) != '#') - && i < BUFSIZE - 1) { - parser->token_buf[i] = Parser_getchar(parser); - i++; - } - if (i > 1022) return NULL; - parser->token_buf[i] = '\0'; - return parser->token_buf; -} - -static bool is_symbol_init(char c) { - if (isalpha(c)) return true; - if (c == '!') return true; - if (c == '$') return true; - if (c == '%') return true; - if (c == '&') return true; - if (c == '*') return true; - if (c == '/') return true; - if (c == ':') return true; - if (c == '<') return true; - if (c == '=') return true; - if (c == '>') return true; - if (c == '?') return true; - if (c == '^') return true; - if (c == '_') return true; - if (c == '~') return true; - if (c < 0) return true; - return false; -} - -static bool is_symbol_subsequent(char c) { - if (is_symbol_init(c)) return true; - if (isdigit(c)) return true; - if (c == '+') return true; - if (c == '-') return true; - if (c == '.') return true; - if (c == '@') return true; - return false; -} - -static ParseResult parse_token(Parser *parser, const char *token) { - int len = strlen(token); - if (len == 0) { - return ParseErr(parser, "Empty token.\n"); - } - if (len == 1) { - if (token[0] == '-' || token[0] == '+') { - return ParseOk(new_symbol(parser->ctx, token)); - } - } - if (token[0] == '#') { - if (len < 2) return ParseErr(parser, "Expect boolean or character.\n"); - if (token[1] == '\'') { - if (len < 3) return ParseErr(parser, "Expect a symbol.\n"); - if (len == 3) { - if (token[2] == '+' || token[2] == '-') { - goto funcmacro; - } - } - if (!is_symbol_init(token[2])) return ParseErr(parser, "Expect a symbol.\n"); - for (int i = 3; i < len; i++) { - if (!is_symbol_subsequent(token[i])) return ParseErr(parser, "Expect a symbol.\n"); - } - SExpRef funcsym; - SExpRef sym; - funcmacro: - funcsym = new_symbol(parser->ctx, "function"); - sym = new_symbol(parser->ctx, token+2); - return ParseOk(lisp_cons(parser->ctx, funcsym, lisp_cons(parser->ctx, sym, parser->ctx->nil))); - } - if (token[1] == 't') return ParseOk(new_boolean(parser->ctx, true)); - if (token[1] == 'f') return ParseOk(new_boolean(parser->ctx, false)); - if (token[1] == '\\') { - if (len < 3) return ParseErr(parser, "Expect character.\n"); - if (len == 3) return ParseOk(new_char(parser->ctx, token[2])); - if (strcmp(token+2, "newline") == 0) return ParseOk(new_char(parser->ctx, '\n')); - if (strcmp(token+2, "space") == 0) return ParseOk(new_char(parser->ctx, ' ')); - if (strcmp(token+2, "tab") == 0) return ParseOk(new_char(parser->ctx, '\t')); - if (strcmp(token+2, "return") == 0) return ParseOk(new_char(parser->ctx, '\r')); - return ParseErr(parser, "Unknown character name: %s.\n", token + 2); - } - } - if (is_symbol_init(token[0])) { - for (int i = 1; i < len; i++) { - if (!is_symbol_subsequent(token[i])) { - return ParseErr(parser, "Not a symbol, containing illegal character: %s\n", token); - } - } - return ParseOk(new_symbol(parser->ctx, token)); - } - char *endptr; - int64_t integer = strtoll(token, &endptr, 10); - if (endptr == token + len) return ParseOk(new_integer(parser->ctx, integer)); - double real = strtod(token, &endptr); - if (endptr == token + len) return ParseOk(new_real(parser->ctx, real)); - return ParseErr(parser, "Not a number : %s.\n", token); -} - -ParseResult parse_string(Parser *parser) { - ParseResult ret; - CharVector buf; - CharVector_init(&buf); - Parser_getchar(parser); - while (Parser_peek(parser) != '"') { - if (Parser_peek(parser) == EOF) { - ret = ParseErr(parser, "Unexpected EOF.\n"); - goto end; - } - if (Parser_peek(parser) == '\0') { - ret = ParseErr(parser, "Unexpected zero terminator.\n"); - goto end; - } - if (Parser_peek(parser) != '\\') { - CharVector_push_back(&buf, Parser_getchar(parser)); - } else { - Parser_getchar(parser); - if (Parser_peek(parser) == EOF) { - ret = ParseErr(parser, "Unexpected EOF.\n"); - goto end; - } - int c = Parser_getchar(parser); - if (c == EOF) { - ret = ParseErr(parser, "Unexpected EOF: %c.\n", c); - goto end; - } else if (c == '\\') CharVector_push_back(&buf, '\\'); - else if (c == 't') CharVector_push_back(&buf, '\t'); - else if (c == 'n') CharVector_push_back(&buf, '\n'); - else if (c == 'r') CharVector_push_back(&buf, '\r'); - else if (c == '"') CharVector_push_back(&buf, '"'); - else { - ret = ParseErr(parser, "Unexpected escape char: %c.\n", c); - goto end; - } - } - } - Parser_getchar(parser); - CharVector_push_back(&buf, '\0'); - ret = ParseOk(new_string(parser->ctx, buf.buffer)); -end: - CharVector_free(&buf); - return ret; -} - -ParseResult parse_atom(Parser *parser) { - ParseResult ret; - if (Parser_peek(parser) == EOF) { - return ParseErr(parser, "Unexpected EOF.\n"); - } - if (Parser_peek(parser) == '"') return parse_string(parser); - const char *token = read_token(parser); - if (token == NULL) return ParseErr(parser, "Token too long.\n"); - return parse_token(parser, token); -} - -ParseResult parse_abbrev(Parser *parser, const char *name) { - if (isspace(Parser_peek(parser))) { - return ParseErr(parser, "Unexpected space.\n"); - } - ParseResult ret; - ret = parse_sexp(parser); - if (ParseResult_is_err(ret)) return ret; - SExpRef sym = new_symbol(parser->ctx, name); - return ParseOk(lisp_cons(parser->ctx, sym, lisp_cons(parser->ctx, ret.val, parser->ctx->nil))); -} - -ParseResult parse_quote(Parser *parser) { - return parse_abbrev(parser, "quote"); -} - -ParseResult parse_unquote(Parser *parser) { - return parse_abbrev(parser, "unquote"); -} - -ParseResult parse_slicing_unquote(Parser *parser) { - return parse_abbrev(parser, "slicing-unquote"); -} - -ParseResult parse_quasi(Parser *parser) { - return parse_abbrev(parser, "quasiquote"); -} - diff --git a/src/parser.h b/src/parser.h deleted file mode 100644 index 0721675..0000000 --- a/src/parser.h +++ /dev/null @@ -1,66 +0,0 @@ -#ifndef BAMBOO_LISP_PARSER_H_ -#define BAMBOO_LISP_PARSER_H_ - -#include <stdbool.h> - -#include "interp.h" -#include "sexp.h" - -typedef enum { - kParseString, - kParseFile, - kParseReadline, -} ParseType; - -struct parser { - Interp *ctx; - char *errmsg_buf; - char *token_buf; - - ParseType parse_type; - union { - struct { - const char *string; - const char *str_cursor; - bool readline_eof; - }; - FILE *fp; - }; -}; -typedef struct parser Parser; - -void Parser_init(Parser *self); -void Parser_free(Parser *self); -int Parser_getchar(Parser *self); -int Parser_peek(Parser *self); -void Parser_set_string(Parser *parser, const char *str); -void Parser_set_file(Parser *parser, FILE *fp); -void Parser_set_readline(Parser *parser); -bool Parser_is_end(Parser *parser); - -typedef struct { - SExpRef val; - const char *errmsg; -} ParseResult; - -ParseResult ParseOk(SExpRef ref); -ParseResult ParseErr(Parser *parser, const char *format, ...); -bool ParseResult_is_err(ParseResult res); - - -ParseResult parse_sexp(Parser *parser); -ParseResult parse_list(Parser *parser); -ParseResult parse_quote(Parser *parser); -ParseResult parse_unquote(Parser *parser); -ParseResult parse_slicing_unquote(Parser *parser); -ParseResult parse_quasi(Parser *parser); -ParseResult parse_atom(Parser *parser); -ParseResult parse_number(Parser *parser); -ParseResult parse_integer(Parser *parser); -ParseResult parse_real(Parser *parser); -ParseResult parse_symbol(Parser *parser); -ParseResult parse_string(Parser *parser); -ParseResult parse_char(Parser *parser); - -#endif - diff --git a/src/prelude.c b/src/prelude.c deleted file mode 100644 index 679b418..0000000 --- a/src/prelude.c +++ /dev/null @@ -1,6 +0,0 @@ - -#include "prelude.h" - -const char *bamboo_lisp_prelude = "(defvar nil \'())\n\n(defvar pi 3.1415926)\n(defvar e 2.718281828)\n\n(defmacro incq (i)\n `(setq ,i (+ ,i 1)))\n\n(defmacro decq (i)\n `(setq ,i (- ,i 1)))\n\n(defun zero? (x) (= x 0))\n(defun plus? (x) (> x 0))\n(defun minus? (x) (< x 0))\n\n(defmacro when (pred . body)\n `(if ,pred\n (progn ,@body)\n nil))\n\n(defmacro unless (pred . body)\n `(if ,pred\n nil\n (progn ,@body)))\n\n(defun take (n lst)\n (unless (integer? n)\n (error \"take: type error.\"))\n (unless (list? lst)\n (error \"take: type error.\"))\n (let ((i 0)\n (newlst nil))\n (while (and (< i n)\n (not (null? lst)))\n (setq newlst (cons (car lst) newlst))\n (setq lst (cdr lst))\n (incq i))\n (nreverse newlst)))\n\n(defun drop (n lst)\n (unless (integer? n)\n (error \"drop type error.\"))\n (unless (list? lst)\n (error \"drop: type error.\"))\n (let ((i 0))\n (while (and (< i n)\n (not (null? lst)))\n (setq lst (cdr lst))\n (incq i))\n lst))\n\n(defun take-while (pred lst)\n (unless (function? pred)\n (error \"take-while: type error.\"))\n (unless (list? lst)\n (error \"take-while: type error.\"))\n (let ((newlst nil))\n (while (and (not (null? lst))\n (funcall pred (car lst)))\n (setq newlst (cons (car lst) newlst))\n (setq lst (cdr lst)))\n (nreverse newlst)))\n\n(defun drop-while (pred lst)\n (unless (function? pred)\n (error \"drop-while: type error.\"))\n (unless (list? lst)\n (error \"drop-while: type error.\"))\n (while (and (not (null? lst))\n (funcall pred (car lst)))\n (setq lst (cdr lst)))\n lst)\n\n(defun sublist (start end lst)\n (unless (integer? start)\n (error \"sublist: type error.\"))\n (unless (integer? end)\n (error \"sublist: type error.\"))\n (unless (< start end)\n (error \"sublist: start must less than end.\"))\n (unless (list? lst)\n (error \"sublist: type error.\"))\n (drop start (take end lst)))\n\n(defun find (x lst)\n (unless (list? lst)\n (error \"find: type error.\"))\n (while (not (null? lst))\n (when (equal? x (car lst))\n (return lst))\n (setq lst (cdr lst)))\n nil)\n\n(defun contains? (x lst)\n (unless (list? lst)\n (error \"contains?: type error.\"))\n (while (not (null? lst))\n (when (equal? x (car lst))\n (return #t))\n (setq lst (cdr lst)))\n #f)\n\n(defun caar (x) (car (car x)))\n(defun cadr (x) (car (cdr x)))\n(defun cddr (x) (cdr (cdr x)))\n(defun cdar (x) (cdr (car x)))\n\n(defun caaar (x) (car (caar x)))\n(defun cadar (x) (car (cdar x)))\n(defun cddar (x) (cdr (cdar x)))\n(defun cdaar (x) (cdr (caar x)))\n(defun caadr (x) (car (cadr x)))\n(defun caddr (x) (car (cddr x)))\n(defun cdddr (x) (cdr (cddr x)))\n(defun cdadr (x) (cdr (cadr x)))\n\n(defun caaaar (x) (car (caaar x)))\n(defun cadaar (x) (car (cdaar x)))\n(defun cddaar (x) (cdr (cdaar x)))\n(defun cdaaar (x) (cdr (caaar x)))\n(defun caadar (x) (car (cadar x)))\n(defun caddar (x) (car (cddar x)))\n(defun cdddar (x) (cdr (cddar x)))\n(defun cdadar (x) (cdr (cadar x)))\n(defun caaadr (x) (car (caadr x)))\n(defun cadadr (x) (car (cdadr x)))\n(defun cddadr (x) (cdr (cdadr x)))\n(defun cdaadr (x) (cdr (caadr x)))\n(defun caaddr (x) (car (caddr x)))\n(defun cadddr (x) (car (cdddr x)))\n(defun cddddr (x) (cdr (cdddr x)))\n(defun cdaddr (x) (cdr (caddr x)))\n"; - - diff --git a/src/prelude.h b/src/prelude.h deleted file mode 100644 index 3acf146..0000000 --- a/src/prelude.h +++ /dev/null @@ -1,7 +0,0 @@ -#ifndef BAMBOO_LISP_PRELUDE_H_ -#define BAMBOO_LISP_PRELUDE_H_ - -extern const char *bamboo_lisp_prelude; - -#endif - diff --git a/src/prelude.lisp b/src/prelude.lisp deleted file mode 100644 index a1be068..0000000 --- a/src/prelude.lisp +++ /dev/null @@ -1,132 +0,0 @@ -(defvar nil '()) - -(defvar pi 3.1415926) -(defvar e 2.718281828) - -(defmacro incq (i) - `(setq ,i (+ ,i 1))) - -(defmacro decq (i) - `(setq ,i (- ,i 1))) - -(defun zero? (x) (= x 0)) -(defun plus? (x) (> x 0)) -(defun minus? (x) (< x 0)) - -(defmacro when (pred . body) - `(if ,pred - (progn ,@body) - nil)) - -(defmacro unless (pred . body) - `(if ,pred - nil - (progn ,@body))) - -(defun take (n lst) - (unless (integer? n) - (error "take: type error.")) - (unless (list? lst) - (error "take: type error.")) - (let ((i 0) - (newlst nil)) - (while (and (< i n) - (not (null? lst))) - (setq newlst (cons (car lst) newlst)) - (setq lst (cdr lst)) - (incq i)) - (nreverse newlst))) - -(defun drop (n lst) - (unless (integer? n) - (error "drop type error.")) - (unless (list? lst) - (error "drop: type error.")) - (let ((i 0)) - (while (and (< i n) - (not (null? lst))) - (setq lst (cdr lst)) - (incq i)) - lst)) - -(defun take-while (pred lst) - (unless (function? pred) - (error "take-while: type error.")) - (unless (list? lst) - (error "take-while: type error.")) - (let ((newlst nil)) - (while (and (not (null? lst)) - (funcall pred (car lst))) - (setq newlst (cons (car lst) newlst)) - (setq lst (cdr lst))) - (nreverse newlst))) - -(defun drop-while (pred lst) - (unless (function? pred) - (error "drop-while: type error.")) - (unless (list? lst) - (error "drop-while: type error.")) - (while (and (not (null? lst)) - (funcall pred (car lst))) - (setq lst (cdr lst))) - lst) - -(defun sublist (start end lst) - (unless (integer? start) - (error "sublist: type error.")) - (unless (integer? end) - (error "sublist: type error.")) - (unless (< start end) - (error "sublist: start must less than end.")) - (unless (list? lst) - (error "sublist: type error.")) - (drop start (take end lst))) - -(defun find (x lst) - (unless (list? lst) - (error "find: type error.")) - (while (not (null? lst)) - (when (equal? x (car lst)) - (return lst)) - (setq lst (cdr lst))) - nil) - -(defun contains? (x lst) - (unless (list? lst) - (error "contains?: type error.")) - (while (not (null? lst)) - (when (equal? x (car lst)) - (return #t)) - (setq lst (cdr lst))) - #f) - -(defun caar (x) (car (car x))) -(defun cadr (x) (car (cdr x))) -(defun cddr (x) (cdr (cdr x))) -(defun cdar (x) (cdr (car x))) - -(defun caaar (x) (car (caar x))) -(defun cadar (x) (car (cdar x))) -(defun cddar (x) (cdr (cdar x))) -(defun cdaar (x) (cdr (caar x))) -(defun caadr (x) (car (cadr x))) -(defun caddr (x) (car (cddr x))) -(defun cdddr (x) (cdr (cddr x))) -(defun cdadr (x) (cdr (cadr x))) - -(defun caaaar (x) (car (caaar x))) -(defun cadaar (x) (car (cdaar x))) -(defun cddaar (x) (cdr (cdaar x))) -(defun cdaaar (x) (cdr (caaar x))) -(defun caadar (x) (car (cadar x))) -(defun caddar (x) (car (cddar x))) -(defun cdddar (x) (cdr (cddar x))) -(defun cdadar (x) (cdr (cadar x))) -(defun caaadr (x) (car (caadr x))) -(defun cadadr (x) (car (cdadr x))) -(defun cddadr (x) (cdr (cdadr x))) -(defun cdaadr (x) (cdr (caadr x))) -(defun caaddr (x) (car (caddr x))) -(defun cadddr (x) (car (cdddr x))) -(defun cddddr (x) (cdr (cdddr x))) -(defun cdaddr (x) (cdr (caddr x))) diff --git a/src/primitives.c b/src/primitives.c deleted file mode 100644 index 971aa87..0000000 --- a/src/primitives.c +++ /dev/null @@ -1,576 +0,0 @@ -#include "primitives.h" -#include "interp.h" -#include "sexp.h" -#include "parser.h" - -SExpRef primitive_assert_exception(Interp *interp, SExpRef args, bool istail) { - SExpRef eargs = lisp_eval_args(interp, args); - if (VALTYPE(eargs) == kExceptionSignal) return interp->t; - - const char *expstr = lisp_to_string(interp, CAR(args)); - SExpRef ret = new_error(interp, "assert-exception failed, no exception: %s.\n", expstr); - free((void*)expstr); - return ret; -} - -SExpRef primitive_assert_error(Interp *interp, SExpRef args, bool istail) { - SExpRef eargs = lisp_eval_args(interp, args); - if (VALTYPE(eargs) == kErrSignal) { - interp->stacktrace = NIL; - return interp->t; - } - - const char *expstr = lisp_to_string(interp, CAR(args)); - SExpRef ret = new_error(interp, "assert-error failed, no error: %s.\n", expstr); - free((void*)expstr); - return ret; -} - -SExpRef primitive_try(Interp *interp, SExpRef args, bool istail) { - if (LENGTH(args) != 2) { - return new_error(interp, "try: syntax error.\n"); - } - SExpRef exp = CAR(args), ctch = CADR(args); - SExpRef ret = EVAL(exp); - PUSH_REG(ret); - SExpRef catch_func = EVAL(ctch); - POP_REG(); - if (VALTYPE(catch_func) != kUserFuncSExp - && VALTYPE(catch_func) != kFuncSExp) { - return new_error(interp, "try: syntax error, catch is not a function.\n"); - } - if (VALTYPE(ret) == kExceptionSignal) { - interp->stacktrace = NIL; - PUSH_REG(catch_func); - ret = lisp_apply(interp, catch_func, CONS(REF(ret)->ret, NIL), istail); - POP_REG(); - } - return ret; -} - -SExpRef primitive_load(Interp *interp, SExpRef args, bool istail) { - if (CAR(interp->stack).idx != interp->top_level.idx) { - return new_error(interp, "load: load can only be in top level.\n"); - } - if (LENGTH(args) != 1) return new_error(interp, "load: syntax error.\n"); - args = lisp_eval_args(interp, args); - if (VALTYPE(CAR(args)) != kStringSExp) return new_error(interp, "load: syntax error.\n"); - Parser *old_parser = interp->parser; - Parser *new_parser = malloc(sizeof(Parser)); - Parser_init(new_parser); - new_parser->ctx = interp; - interp->parser = new_parser; - PUSH_REG(args); - SExpRef ret = Interp_load_file(interp, REF(CAR(args))->str); - POP_REG(); - Parser_free(new_parser); - free(new_parser); - interp->parser = old_parser; - return ret; -} - -SExpRef primitive_return(Interp *interp, SExpRef args, bool istail) { - if (LENGTH(args) > 1) { - return new_error(interp, "return: syntax error.\n"); - } - SExpRef ret = NIL; - if (!NILP(args)) { - ret = lisp_eval(interp, CAR(args), true); - } - return new_return(interp, ret); -} - -SExpRef primitive_break(Interp *interp, SExpRef args, bool istail) { - if (LENGTH(args) > 0) { - return new_error(interp, "break: syntax error.\n"); - } - return new_break(interp); -} - -SExpRef primitive_continue(Interp *interp, SExpRef args, bool istail) { - if (LENGTH(args) > 0) { - return new_error(interp, "continue: syntax error.\n"); - } - return new_continue(interp); -} - -SExpRef primitive_assert(Interp *interp, SExpRef args, bool istail) { - SExpRef eargs = lisp_eval_args(interp, args); - if (LENGTH(args) != 1) { - return new_error(interp, "assert: expect 1 arg.\n"); - } - if (TRUEP(CAR(eargs)) && !CTL_FL(CAR(eargs))) { - return interp->t; - } else { - const char *expstr = lisp_to_string(interp, CAR(args)); - SExpRef ret = new_error(interp, "Assertion failed: %s.\n", expstr); - free((void*)expstr); - return ret; - } -} - -SExpRef primitive_eval(Interp *interp, SExpRef args, bool istail) { - if (LENGTH(args) != 1) { - return new_error(interp, "eval: syntax error."); - } - args = lisp_eval_args(interp, args); - return lisp_eval(interp, CAR(args), istail); -} - -SExpRef primitive_unwind_protect(Interp *interp, SExpRef args, bool istail) { - if (LENGTH(args) < 2) { - return new_error(interp, "unwind-protect: syntax error.\n"); - } - SExpRef ret = EVAL(CAR(args)); - PUSH_REG(ret); - for (SExpRef i = CDR(args); !NILP(i); i = CDR(i)) { - EVAL(CAR(i)); - } - POP_REG(); - return ret; -} - -SExpRef primitive_if(Interp *interp, SExpRef args, bool istail) { - SExpRef cond, tb, fb; - - if (LENGTH(args) != 3) goto error; - cond = CAR(args); - tb = CADR(args); - fb = CADDR(args); - cond = EVAL(cond); - if (CTL_FL(cond)) return cond; - if (TRUEP(cond)) return lisp_eval(interp, tb, istail); - else return lisp_eval(interp, fb, istail); -error: - return new_error(interp, "if: syntax error.\n"); -} - -SExpRef primitive_cond(Interp *interp, SExpRef args, bool istail) { - SExpRef pair, condition, exp, iter; - - if (LENGTH(args) < 1) goto error; - iter = args; - while (!NILP(iter)) { - pair = CAR(iter); - if (!lisp_check_list(interp, pair)) goto error; - if (LENGTH(pair) != 2) goto error; - condition = CAR(pair); - exp = CADR(pair); - condition = EVAL(condition); - if (CTL_FL(condition)) return condition; - if (TRUEP(condition)) return lisp_eval(interp, exp, istail); - iter = CDR(iter); - } - return NIL; -error: - return new_error(interp, "cond: syntax error.\n"); -} - -SExpRef primitive_progn(Interp *interp, SExpRef args, bool istail) { - SExpRef iter = args; - SExpRef ret; - - while (!NILP(iter)) { - if (NILP(CDR(iter))) { - return lisp_eval(interp, CAR(iter), istail); - } else { - ret = EVAL(CAR(iter)); - } - if (CTL_FL(ret)) return ret; - iter = CDR(iter); - } - return ret; -} - -SExpRef primitive_setq(Interp *interp, SExpRef args, bool istail) { - SExpRef name, exp, value; - - if (LENGTH(args) != 2) goto error; - name = CAR(args); - exp = CADR(args); - if (REF(name)->type != kSymbolSExp) goto error; - value = EVAL(exp); - if (CTL_FL(value)) return value; - return lisp_setq(interp, name, value); -error: - return new_error(interp, "setq: syntax error.\n"); -} - -static const char *binding_name(Interp *interp, SExpRef binding) { - SExpRef namesym = REF(binding)->binding.name; - return REF(namesym)->str; -} - -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; - } - return false; -} - -SExpRef primitive_let(Interp *interp, SExpRef args, bool istail) { - SExpRef binding, iter, bindings, env, x, - val, body, ret, exp; - - if (LENGTH(args) < 1) goto error; - bindings = CAR(args); - env = new_env(interp); - REF(env)->env.parent = CAR(interp->stack); - - iter = bindings; - while (!NILP(iter)) { - x = CAR(iter); - if (!lisp_check_list(interp, x)) goto error; - if (LENGTH(x) != 2) goto error; - if (REF(CAR(x))->type != kSymbolSExp) goto error; - if (is_binding_repeat(interp, CAR(x), env)) goto error; - 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); - - ret = NIL; - iter = bindings; - while (!NILP(iter)) { - x = CAR(iter); - val = EVAL(CADR(x)); - if (CTL_FL(val)) { - ret = val; - goto end; - } - ret = lisp_setq(interp, CAR(x), val); - if (CTL_FL(ret)) goto end; - iter = CDR(iter); - } - - body = CDR(args); - if (istail) { - SExpRef closure = new_lambda(interp, NIL, body, env); - ret = new_tailcall(interp, closure, NIL); - goto end; - } - iter = body; - while (!NILP(iter)) { - exp = CAR(iter); - if (NILP(CDR(iter))) { - ret = lisp_eval(interp, exp, true); - goto end; - } else { - ret = EVAL(exp); - } - if (CTL_FL(ret)) goto end; - iter = CDR(iter); - } -end: - interp->stack = CDR(interp->stack); - return ret; - -error: - return new_error(interp, "let: syntax error. \n"); -} - -SExpRef primitive_while(Interp *interp, SExpRef args, bool istail) { - SExpRef ret, pred, body, cond, iter, x; - - if (LENGTH(args) < 2) goto error; - ret = NIL; - pred = CAR(args); - body = CDR(args); - while (1) { -nextloop: - cond = EVAL(pred); - if (CTL_FL(cond)) { - if (VALTYPE(cond) != kErrSignal && VALTYPE(cond) != kExceptionSignal) { - return new_error(interp, "while: unexpected control flow.\n"); - } - return cond; - } - if (!TRUEP(cond)) return NIL; - iter = body; - while (!NILP(iter)) { - x = CAR(iter); - ret = EVAL(x); - if (VALTYPE(ret) == kErrSignal - || VALTYPE(ret) == kReturnSignal - || VALTYPE(ret) == kExceptionSignal) { - return ret; - } - if (VALTYPE(ret) == kBreakSignal) { - return NIL; - } - if (VALTYPE(ret) == kContinueSignal) { - goto nextloop; - } - iter = CDR(iter); - } - } -error: - return new_error(interp, "while: syntax error.\n"); -} - -SExpRef primitive_lambda(Interp *interp, SExpRef args, bool istail) { - SExpRef env, param, body; - - if (LENGTH(args) < 2) goto error; - 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, bool istail) { - SExpRef name, param, body, function; - - if (LENGTH(args) == 2) { - if (CAR(interp->stack).idx != interp->top_level.idx) { - return new_error(interp, "defun: functions can only be defined in top level.\n"); - } - name = CAR(args); - if (VALTYPE(name) != kSymbolSExp) goto error; - function = EVAL(CADR(args)); - if (!CALLABLE(function)) goto error; - lisp_defun(interp, name, function); - return name; - } else if (LENGTH(args) >= 3) { - if (CAR(interp->stack).idx != interp->top_level.idx) { - return new_error(interp, "defun: functions can only be defined in top level.\n"); - } - name = CAR(args); - if (VALTYPE(name) != kSymbolSExp) goto error; - param = CADR(args); - body = CDDR(args); - function = new_lambda(interp, param, body, interp->top_level); - lisp_defun(interp, name, function); - return name; - } else goto error; -error: - return new_error(interp, "defun: syntax error.\n"); -} -SExpRef primitive_defmacro(Interp *interp, SExpRef args, bool istail) { - SExpRef param, name, body, macro; - - if (LENGTH(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"); - } - name = CAR(args); - if (VALTYPE(name) != kSymbolSExp) goto error; - param = CADR(args); - body = CDDR(args); - macro = new_macro(interp, param, body); - lisp_defun(interp, name, macro); - return name; -error: - return new_error(interp, "defmacro: syntax error.\n"); -} - -SExpRef primitive_defvar(Interp *interp, SExpRef args, bool istail) { - SExpRef name, exp, val; - - if (LENGTH(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"); - } - name = CAR(args); - if (VALTYPE(name) != kSymbolSExp) goto error; - exp = CADR(args); - val = EVAL(exp); - if (CTL_FL(val)) return val; - lisp_defvar(interp, name, val); - return name; -error: - return new_error(interp, "defvar: syntax error.\n"); -} - -SExpRef primitive_function(Interp *interp, SExpRef args, bool istail) { - if (LENGTH(args) != 1) goto error; - if (VALTYPE(CAR(args)) != kSymbolSExp) goto error; - return lisp_lookup_func(interp, CAR(args)); -error: - return new_error(interp, "function: syntax error.\n"); -} - -static SExpRef build_function_env(Interp *interp, SExpRef func, SExpRef args) { - SExpRef param = REF(func)->func.args; - SExpRef iparam = param; - SExpRef iargs = args; - SExpRef env = new_env(interp); - SExpRef binding, name; - - while (!NILP(iparam)) { - if (VALTYPE(iparam) == kSymbolSExp) { - binding = new_binding(interp, iparam, iargs); - REF(binding)->binding.next = REF(env)->env.bindings; - REF(env)->env.bindings = binding; - return env; - } - 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"); - binding = new_binding(interp, name, CAR(iargs)); - REF(binding)->binding.next = REF(env)->env.bindings; - REF(env)->env.bindings = binding; - iargs = CDR(iargs); - iparam = CDR(iparam); - } - if (!NILP(iargs)) return new_error(interp, "funcall: wrong argument number.\n"); - return env; -} - -SExpRef primitive_funcall(Interp *interp, SExpRef args, bool istail) { - if (LENGTH(args) < 1) goto error; - SExpRef evaled = lisp_eval_args(interp, args); - if (CTL_FL(evaled)) return evaled; - SExpRef fn = CAR(evaled); - SExpRef fnargs = CDR(evaled); - PUSH_REG(fn); - SExpRef ret = lisp_apply(interp, fn, fnargs, istail); - POP_REG(); - return ret; -error: - return new_error(interp, "funcall: syntax error.\n"); -} - -SExpRef primitive_quote(Interp *interp, SExpRef args, bool istail) { - if (LENGTH(args) != 1) return new_error(interp, "quote: syntax error.\n"); - return CAR(args); -} - -SExpRef primitive_macroexpand1(Interp *interp, SExpRef args, bool istail) { - SExpRef macro; - - if (LENGTH(args) != 1) goto error; - args = CAR(args); - if (VALTYPE(CAR(args)) != kSymbolSExp) goto error; - macro = lisp_lookup_func(interp, CAR(args)); - if (VALTYPE(macro) != kMacroSExp) goto error; - return lisp_macroexpand1(interp, macro, CDR(args)); -error: - return new_error(interp, "macroexpand-1: syntax error.\n"); -} - -SExpRef primitive_apply(Interp *interp, SExpRef args, bool istail) { - SExpRef ret; - - if (LENGTH(args) != 2) goto error; - args = lisp_eval_args(interp, args); - if (CTL_FL(args)) return args; - if (!lisp_check_list(interp, CADR(args))) goto error; - SExpRef fn = CAR(args); - PUSH_REG(fn); - ret = lisp_apply(interp, fn, CADR(args), istail); - POP_REG(); - return ret; -error: - return new_error(interp, "apply: syntax error.\n"); -} - -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 - && strcmp("unquote", REF(CAR(obj))->str) == 0) { - if (LENGTH(obj) != 2) { - return new_error(interp, "unquote: syntax error.\n"); - } - return EVAL(CADR(obj)); - } - if (VALTYPE(CAR(obj)) == kSymbolSExp - && strcmp("slicing-unquote", REF(CAR(obj))->str) == 0) { - lst = EVAL(CADR(obj)); - if (CTL_FL(lst)) return lst; - if (LENGTH(obj) != 2) { - return new_error(interp, "slicing-unquote: syntax error.\n"); - } - if (!lisp_check_list(interp, lst)) { - return new_error(interp, "slicing-unquote: not a list.\n"); - } - *slicing = true; - return lst; - } - return quasi_on_list(interp, obj); -} - -static SExpRef quasi_on_list(Interp *interp, SExpRef lst) { - SExpRef newlst = NIL; - SExpRef iter, j, x, newx; - - bool slicing; - iter = lst; - while (!NILP(iter)) { - x = CAR(iter); - PUSH_REG(newlst); - newx = quasi_impl(interp, x, &slicing); - POP_REG(); - if (CTL_FL(newx)) return newx; - if (slicing) { - j = newx; - while (!NILP(j)) { - newlst = CONS(CAR(j), newlst); - j = CDR(j); - } - } else { - newlst = CONS(newx, newlst); - } - iter = CDR(iter); - } - - return lisp_nreverse(interp, newlst); -} - -SExpRef primitive_quasi(Interp *interp, SExpRef args, bool istail) { - SExpRef ret; - if (LENGTH(args) != 1) return new_error(interp, "quasiquote: syntax error.\n"); - bool 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, bool istail) { - SExpRef ret; - SExpRef i = args; - if (LENGTH(args) < 1) return new_error(interp, "and: syntax error.\n"); - while (!NILP(i)) { - if (!NILP(CDR(i))) { - ret = EVAL(CAR(i)); - } else { - return lisp_eval(interp, CAR(i), istail); - } - if (!TRUEP(ret)) return ret; - i = CDR(i); - } - return ret; -} - -SExpRef primitive_or(Interp *interp, SExpRef args, bool istail) { - SExpRef ret; - SExpRef i = args; - - if (LENGTH(args) < 1) return new_error(interp, "or: syntax error.\n"); - while (!NILP(i)) { - if (!NILP(CDR(i))) { - ret = EVAL(CAR(i)); - } else { - return lisp_eval(interp, CAR(i), istail); - } - if (TRUEP(ret)) return ret; - i = CDR(i); - } - return ret; -} - diff --git a/src/primitives.h b/src/primitives.h deleted file mode 100644 index cd686fe..0000000 --- a/src/primitives.h +++ /dev/null @@ -1,35 +0,0 @@ -#ifndef BAMBOO_LISP_PRIMITIVIE_H_ -#define BAMBOO_LISP_PRIMITIVIE_H_ - -#include "interp.h" - -SExpRef primitive_assert_error(Interp *interp, SExpRef sexp, bool istail); -SExpRef primitive_assert_exception(Interp *interp, SExpRef sexp, bool istail); -SExpRef primitive_load(Interp *interp, SExpRef sexp, bool istail); -SExpRef primitive_return(Interp *interp, SExpRef sexp, bool istail); -SExpRef primitive_break(Interp *interp, SExpRef sexp, bool istail); -SExpRef primitive_continue(Interp *interp, SExpRef sexp, bool istail); -SExpRef primitive_assert(Interp *interp, SExpRef sexp, bool istail); -SExpRef primitive_eval(Interp *interp, SExpRef sexp, bool istail); -SExpRef primitive_if(Interp *interp, SExpRef sexp, bool istail); -SExpRef primitive_cond(Interp *interp, SExpRef sexp, bool istail); -SExpRef primitive_progn(Interp *interp, SExpRef sexp, bool istail); -SExpRef primitive_setq(Interp *interp, SExpRef sexp, bool istail); -SExpRef primitive_let(Interp *interp, SExpRef sexp, bool istail); -SExpRef primitive_while(Interp *interp, SExpRef sexp, bool istail); -SExpRef primitive_lambda(Interp *interp, SExpRef sexp, bool istail); -SExpRef primitive_defun(Interp *interp, SExpRef sexp, bool istail); -SExpRef primitive_defvar(Interp *interp, SExpRef sexp, bool istail); -SExpRef primitive_defmacro(Interp *interp, SExpRef sexp, bool istail); -SExpRef primitive_function(Interp *interp, SExpRef sexp, bool istail); -SExpRef primitive_macroexpand1(Interp *interp, SExpRef sexp, bool istail); -SExpRef primitive_funcall(Interp *interp, SExpRef sexp, bool istail); -SExpRef primitive_apply(Interp *interp, SExpRef sexp, bool istail); -SExpRef primitive_quote(Interp *interp, SExpRef sexp, bool istail); -SExpRef primitive_quasi(Interp *interp, SExpRef sexp, bool istail); -SExpRef primitive_and(Interp *interp, SExpRef sexp, bool istail); -SExpRef primitive_or(Interp *interp, SExpRef sexp, bool istail); -SExpRef primitive_unwind_protect(Interp *interp, SExpRef sexp, bool istail); -SExpRef primitive_try(Interp *interp, SExpRef sexp, bool istail); - -#endif diff --git a/src/sexp.c b/src/sexp.c deleted file mode 100644 index d8feb4d..0000000 --- a/src/sexp.c +++ /dev/null @@ -1,12 +0,0 @@ -#include "sexp.h" -#include "algds/vec.h" - -#include <inttypes.h> - -void SExpRef_show(SExpRef self, FILE* fp) {} -void SExpPtr_show(SExpPtr self, FILE* fp) {} -void SExp_show(SExp self, FILE* fp) {} - -VECTOR_IMPL(SExp); -VECTOR_IMPL(SExpRef); -VECTOR_IMPL(SExpPtr); diff --git a/src/sexp.h b/src/sexp.h deleted file mode 100644 index ce47362..0000000 --- a/src/sexp.h +++ /dev/null @@ -1,125 +0,0 @@ -#ifndef BAMBOO_LISP_SEXP_H_ -#define BAMBOO_LISP_SEXP_H_ - -#include <stdint.h> -#include <stdbool.h> - -#include <algds/vec.h> - -struct sexp; -typedef struct sexp SExp; - -typedef struct { - int32_t idx; -} SExpRef; - -typedef struct { - SExpRef car; - SExpRef cdr; - SExpRef filename; - int32_t line; -} SExpPair; - -typedef struct { - SExpRef args; - SExpRef body; - SExpRef env; -} SExpFunc; - -struct interp; -typedef struct interp Interp; -typedef SExpRef (*LispUserFunc)(Interp *interp, SExpRef args); -typedef SExpRef (*LispPrimitive)(Interp *interp, SExpRef sexp, bool istail); - -typedef struct { - SExpRef args; - SExpRef body; -} SExpMacro; - -typedef struct { - SExpRef parent; - SExpRef bindings; -} SExpEnv; - -typedef struct { - SExpRef name; - SExpRef value; - SExpRef func; - SExpRef next; -} SExpBinding; - -typedef struct { - SExpRef fn; - SExpRef args; -} SExpTailcall; - -typedef enum { - kEmptySExp, - kIntegerSExp, - kRealSExp, - kBooleanSExp, - kNilSExp, - kCharSExp, - kStringSExp, - kSymbolSExp, - kUserDataSExp, - kPairSExp, - kFuncSExp, - kUserFuncSExp, - kPrimitiveSExp, - kEnvSExp, - kBindingSExp, - kMacroSExp, - kErrSignal, - kReturnSignal, - kBreakSignal, - kContinueSignal, - kTailcallSExp, - kExceptionSignal, -} SExpType; - -VECTOR_DEF(SExpRef); - -typedef SExp *SExpPtr; -VECTOR_DEF(SExpPtr); - -typedef struct { - const char *type; - void (*free)(void *self); - void (*gcmark)(Interp *interp, SExpPtrVector *gcstack, void *self); -} LispUserdataMeta; - -struct sexp { - bool marked; - SExpType type; - union { - int64_t integer; - double real; - bool boolean; - char character; - const char *str; - struct { - void *userdata; - LispUserdataMeta *userdata_meta; - }; - SExpPair pair; - SExpFunc func; - LispUserFunc userfunc; - LispPrimitive primitive; - SExpEnv env; - SExpBinding binding; - SExpMacro macro; - SExpRef ret; - SExpTailcall tailcall; - }; -}; - - -void SExp_show(SExp self, FILE* fp); -void SExpRef_show(SExpRef self, FILE* fp); -void SExpPtr_show(SExpPtr self, FILE* fp); - -VECTOR_DEF(SExp); - -#endif - diff --git a/src/vector.c b/src/vector.c deleted file mode 100644 index 453800b..0000000 --- a/src/vector.c +++ /dev/null @@ -1,128 +0,0 @@ -#include "vector.h" -#include "interp.h" -#include "sexp.h" - -LispUserdataMeta bamboo_lisp_array_meta; - -static bool is_vector_impl(Interp *interp, SExpRef vec) { - if (VALTYPE(vec) == kUserDataSExp && strcmp("vector", REF(vec)->userdata_meta->type) == 0) { - return true; - } - return false; -} - -static SExpRef is_vector(Interp* interp, SExpRef args) { - if (LENGTH(args) != 1) return new_error(interp, "vector?: wrongs args num.\n"); - return new_boolean(interp, is_vector_impl(interp, CAR(args))); -} - -static SExpRef make_vector(Interp* interp, SExpRef args) { - SExpRef ret = new_sexp(interp); - REF(ret)->type = kUserDataSExp; - REF(ret)->userdata_meta = &bamboo_lisp_array_meta; - SExpRefVector *data = malloc(sizeof(SExpRefVector)); - SExpRefVector_init(data); - REF(ret)->userdata = data; - return ret; -} - -static SExpRef vector_ref(Interp* interp, SExpRef args) { - if (LENGTH(args) != 2) return new_error(interp, "vector-ref: wrong args num.\n"); - if (!is_vector_impl(interp, CAR(args)) - || REF(CADR(args))->type != kIntegerSExp) { - return new_error(interp, "vector-ref: wrong type.\n"); - } - int n = REF(CADR(args))->integer; - SExpRefVector *vec = REF(CAR(args))->userdata; - if (n >= SExpRefVector_len(vec)) return new_error(interp, "vector-ref: out of bound.\n"); - SExpRef ret = new_sexp(interp); - return *SExpRefVector_ref(vec, n); -} - -static SExpRef vector_append(Interp* interp, SExpRef args) { - if (LENGTH(args) != 2) return new_error(interp, "vector-append: wrong args num.\n"); - if (!is_vector_impl(interp, CAR(args))) return new_error(interp, "vector-append: first arg not a vector.\n"); - - SExpRefVector *vec = REF(CAR(args))->userdata; - SExpRef elem = CADR(args); - SExpRefVector_push_back(vec, elem); - return NIL; -} - -static SExpRef vector_insert(Interp* interp, SExpRef args) { - if (LENGTH(args) != 3) return new_error(interp, "vector-insert: wrong args num.\n"); - if (!is_vector_impl(interp, CAR(args)) || REF(CADR(args))->type != kIntegerSExp) - return new_error(interp, "vector-insert: wrong types.\n"); - - int pos = REF(CADR(args))->integer; - SExpRefVector *vec = REF(CAR(args))->userdata; - SExpRef elem = CADDR(args); - SExpRefVector_insert_before(vec, pos, elem); - return NIL; -} - -static SExpRef vector_delete(Interp* interp, SExpRef args) { - if (LENGTH(args) != 2) return new_error(interp, "vector-remove: wrong args num.\n"); - if (!is_vector_impl(interp, CAR(args)) || REF(CADR(args))->type != kIntegerSExp) - return new_error(interp, "vector-remove: wrong types.\n"); - - int pos = REF(CADR(args))->integer; - SExpRefVector *vec = REF(CAR(args))->userdata; - if (pos >= SExpRefVector_len(vec)) return new_error(interp, "vector-remove: out of bound.\n"); - SExpRefVector_remove(vec, pos); - return NIL; -} - -static SExpRef vector_length(Interp* interp, SExpRef args) { - if (LENGTH(args) != 1) return new_error(interp, "vector-length: wrong args num.\n"); - if (!is_vector_impl(interp, CAR(args))) return new_error(interp, "vector-length: not a vector.\n"); - - SExpRefVector *vec = REF(CAR(args))->userdata; - return new_integer(interp, SExpRefVector_len(vec)); -} - -static SExpRef vector_set(Interp* interp, SExpRef args) { - if (LENGTH(args) != 3) return new_error(interp, "vector-set: wrong args num.\n"); - if (!is_vector_impl(interp, CAR(args)) || REF(CADR(args))->type != kIntegerSExp) - return new_error(interp, "vector-set: wrong types.\n"); - - int pos = REF(CADR(args))->integer; - SExpRefVector *vec = REF(CAR(args))->userdata; - if (pos >= SExpRefVector_len(vec)) return new_error(interp, "vector-set: out of bound.\n"); - - *SExpRefVector_ref(vec, pos) = CADDR(args); - return NIL; -} - -static void vector_free(void *vself) { - SExpRefVector *self = vself; - SExpRefVector_free(self); - free(self); -} - -static void vector_gcmark(Interp *interp, SExpPtrVector *gcstack, void *vself) { - SExpRefVector *vec = (SExpRefVector *)vself; - int vecsize = SExpRefVector_len(vec); - for (int i = 0; i < vecsize; ++i) { - SExpPtr child = REF(*SExpRefVector_ref(vec, i)); - if (child && !child->marked) { - SExpPtrVector_push_back(gcstack, child); - } - } -} - - -void bamboo_lisp_init_vector(Interp *interp) { - bamboo_lisp_array_meta.type = "vector"; - bamboo_lisp_array_meta.free = &vector_free; - bamboo_lisp_array_meta.gcmark = &vector_gcmark; - - Interp_add_userfunc(interp, "vector?", &is_vector); - Interp_add_userfunc(interp, "make-vector", &make_vector); - Interp_add_userfunc(interp, "vector-ref", &vector_ref); - Interp_add_userfunc(interp, "vector-append", &vector_append); - Interp_add_userfunc(interp, "vector-insert", &vector_insert); - Interp_add_userfunc(interp, "vector-remove", &vector_delete); - Interp_add_userfunc(interp, "vector-length", &vector_length); - Interp_add_userfunc(interp, "vector-set", &vector_set); -} diff --git a/src/vector.h b/src/vector.h deleted file mode 100644 index 34113d1..0000000 --- a/src/vector.h +++ /dev/null @@ -1,8 +0,0 @@ -#ifndef BAMBOO_LISP_VECTOR_H_ -#define BAMBOO_LISP_VECTOR_H_ - -#include "interp.h" - -void bamboo_lisp_init_vector(Interp *interp); - -#endif |