From 5503b2f317e5e579cbc53b9f4fe3fdc3bc16a575 Mon Sep 17 00:00:00 2001 From: Alexander Rosenberg Date: Mon, 7 Sep 2026 16:29:06 -0700 Subject: [PATCH] Arithmatic --- Makefile | 9 +- lisp/kernel.gl | 2 +- src/base.c | 12 ++ src/base.h | 6 +- src/function.c | 7 + src/function.h | 1 + src/gc.c | 10 +- src/hashtable.c | 4 + src/hashtable.h | 1 + src/lisp.c | 2 + src/lisp.h | 1 + src/lisp_math.c | 388 ++++++++++++++++++++++++++++++++++++++++++++++ src/lisp_math.h | 53 +++++++ src/lisp_string.c | 4 + src/lisp_string.h | 2 + src/list.c | 8 + src/list.h | 2 + src/macro.c | 2 +- src/memory.c | 10 +- src/memory.h | 5 + src/print.c | 14 ++ src/read.c | 41 +++-- src/stack.c | 1 + 23 files changed, 554 insertions(+), 31 deletions(-) create mode 100644 src/lisp_math.c create mode 100644 src/lisp_math.h diff --git a/Makefile b/Makefile index 363bec9..a5f7c2c 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,8 @@ DEBUG=2 LLVM_SAN=1 +FAST_MATH_BUILTINS=1 + ifeq ($(DEBUG),1) DEBUG_CFLAGS=-g -Og else ifeq ($(DEBUG),2) @@ -17,11 +19,12 @@ else LLVM_SAN_FLAGS= endif +LIBS=gmp CC=gcc -CFLAGS=$(DEBUG_CFLAGS) $(LLVM_SAN_FLAGS) -std=c11 -Wall -Wpedantic $\ - -D_POSIX_C_SOURCE=200112L +CFLAGS=$(DEBUG_CFLAGS) $(LLVM_SAN_FLAGS) $(MATH_FLAGS) -std=c23 -Wall $\ + -Wpedantic -D_POSIX_C_SOURCE=200112L `pkg-config --cflags $(LIBS)` LD=gcc -LDFLAGS=-lm $(LLVM_SAN_FLAGS) +LDFLAGS=-lm `pkg-config --libs $(LIBS)` $(LLVM_SAN_FLAGS) SRCS:=$(wildcard src/*.c) OBJS:=$(SRCS:src/%.c=bin/%.o) diff --git a/lisp/kernel.gl b/lisp/kernel.gl index c1663ec..bb7ff20 100644 --- a/lisp/kernel.gl +++ b/lisp/kernel.gl @@ -23,4 +23,4 @@ (princ datum print-char-fun) (funcall (or print-char-fun 'write-byte) ?\n)) -(princln '#'princ) +(princln (/ 1 0.0)) diff --git a/src/base.c b/src/base.c index eedfbb5..44dc5b1 100644 --- a/src/base.c +++ b/src/base.c @@ -19,6 +19,7 @@ const char *LISP_TYPE_NAMES[N_LISP_TYPES] = { [TYPE_VECTOR] = "vector", [TYPE_HASH_TABLE] = "hash-table", [TYPE_FUNCTION] = "function", + [TYPE_GMP] = "bignum", }; bool lisp_gc_on_alloc; @@ -141,6 +142,14 @@ DEFUN(make_symbol, "make-symbol", (LispVal * name), "(name)", return obj; } +DEFUN(vectorp, "vectorp", (LispVal * data), "(data)", "") { + return VECTORP(data) ? Qt : Qnil; +} + +DEFUN(symbolp, "symbolp", (LispVal * data), "(data)", "") { + return SYMBOLP(data) ? Qt : Qnil; +} + DEFUN(intern, "intern", (LispVal * name), "(name)", "") { CHECK_TYPE(name, TYPE_STRING); LispVal *res = Fgethash(obarray, name, Qunbound); @@ -220,6 +229,7 @@ DEFINE_SYMBOL(symbol, "symbol"); // vector defined above DEFINE_SYMBOL(hash_table, "hash-table"); // function defind above +DEFINE_SYMBOL(bignum, "bignum"); LispVal *symbol_for_type(LispValType type) { switch (type) { @@ -239,6 +249,8 @@ LispVal *symbol_for_type(LispValType type) { return Qhash_table; case TYPE_FUNCTION: return Qfunction; + case TYPE_GMP: + return Qbignum; default: abort(); } diff --git a/src/base.h b/src/base.h index 8042824..dc0edd8 100644 --- a/src/base.h +++ b/src/base.h @@ -99,6 +99,7 @@ typedef enum { TYPE_VECTOR = 5, TYPE_HASH_TABLE = 6, TYPE_FUNCTION = 7, + TYPE_GMP = 8, N_LISP_TYPES, } LispValType; extern const char *LISP_TYPE_NAMES[N_LISP_TYPES]; @@ -366,6 +367,8 @@ DECLARE_FUNCTION(function, (LispVal * form)); LispVal *make_vector(LispVal **data, size_t length, bool take); DECLARE_FUNCTION(vector, (LispVal * data)); DECLARE_FUNCTION(make_symbol, (LispVal * name)); +DECLARE_FUNCTION(vectorp, (LispVal * data)); +DECLARE_FUNCTION(symbolp, (LispVal * data)); DECLARE_FUNCTION(intern, (LispVal * name)); DECLARE_FUNCTION(symbol_value, (LispVal * sym)); DECLARE_FUNCTION(symbol_function, (LispVal * sym, LispVal *resolve)); @@ -429,7 +432,8 @@ DECLARE_SYMBOL(string); DECLARE_SYMBOL(symbol); // vector defined above DECLARE_SYMBOL(hash_table); -DECLARE_SYMBOL(function); +// function defined above +DECLARE_SYMBOL(bignum); LispVal *symbol_for_type(LispValType type); diff --git a/src/function.c b/src/function.c index 21f39da..3826f47 100644 --- a/src/function.c +++ b/src/function.c @@ -491,6 +491,9 @@ DEFUN(apply, "apply", (LispVal * func, LispVal *args), "(func &rest args)", if (NILP(args)) { return CALL0(func); } + if (NILP(Fproper_list_p(XCDR(Flast(args))))) { + signal_type_error(args, Qlist); + } return Ffuncall(func, Flist_star(XCAR(args), XCDR(args))); } @@ -554,6 +557,10 @@ DEFSPECIAL(lambda, "lambda", (LispVal * args, LispVal *body), return fobj; } +DEFUN(functionp, "functionp", (LispVal * obj), "(obj)", "") { + return FUNCTIONP(obj) ? Qt : Qnil; +} + DEFUN(callablep, "callablep", (LispVal * obj), "(obj)", "") { if (FUNCTIONP(obj) || (CONSP(obj) && EQ(XCAR(obj), Qlambda)) || (SYMBOLP(obj) && FUNCTIONP(Fsymbol_function(obj, Qt)))) { diff --git a/src/function.h b/src/function.h index 4d770a6..6e39883 100644 --- a/src/function.h +++ b/src/function.h @@ -101,6 +101,7 @@ DECLARE_FUNCTION(funcall, (LispVal * func, LispVal *args)); DECLARE_FUNCTION(apply, (LispVal * func, LispVal *args)); DECLARE_FUNCTION(lambda, (LispVal * args, LispVal *body)); +DECLARE_FUNCTION(functionp, (LispVal * obj)); DECLARE_FUNCTION(callablep, (LispVal * obj)); DECLARE_FUNCTION(function_arity, (LispVal * func)); diff --git a/src/gc.c b/src/gc.c index 848d84a..e32f05c 100644 --- a/src/gc.c +++ b/src/gc.c @@ -3,9 +3,11 @@ #include "function.h" #include "hashtable.h" #include "lisp.h" +#include "lisp_math.h" #include "list.h" #include "stack.h" +#include #include bool lisp_doing_gc; @@ -172,6 +174,9 @@ static void free_object(LispVal *val) { lisp_free(vec->data); break; } + case TYPE_GMP: + mpz_clear(((LispGmp *) val)->val); + break; case TYPE_CONS: case TYPE_SYMBOL: case TYPE_FUNCTION: @@ -236,6 +241,7 @@ static void mark_object(LispVal *val) { break; } case TYPE_STRING: + case TYPE_GMP: // no held refs break; case TYPE_FIXNUM: @@ -335,7 +341,7 @@ static void unmark_the_stack(void) { } } -static void mark_GRAY_objects(size_t *restrict limit) { +static void mark_gray_objects(size_t *restrict limit) { while (gray_objects && saturating_dec(limit, 1)) { mark_object(gray_objects->obj); } @@ -394,7 +400,7 @@ void lisp_gc_yield(struct timespec *restrict time_took, bool full) { mark_the_stack(&limit); break; case GC_STEP_HEAP: - mark_GRAY_objects(&limit); + mark_gray_objects(&limit); break; case GC_STEP_FREE: gc_sweep_objects(&limit); diff --git a/src/hashtable.c b/src/hashtable.c index 0cb1732..520f1ab 100644 --- a/src/hashtable.c +++ b/src/hashtable.c @@ -31,6 +31,10 @@ void release_hash_table_no_gc(LispVal *val) { lisp_free(ht); } +DEFUN(hash_table_p, "hash-table-p", (LispVal * val), "(val)", "") { + return HASH_TABLE_P(val) ? Qt : Qnil; +} + DEFUN(make_hash_table, "make-hash-table", (LispVal * hash_fn, LispVal *eq_fn), "(hash-fn eq-fn)", "") { LispHashTable *obj = diff --git a/src/hashtable.h b/src/hashtable.h index d4ef6cf..9743989 100644 --- a/src/hashtable.h +++ b/src/hashtable.h @@ -23,6 +23,7 @@ DEFOBJTYPE(HashTable, HASH_TABLE, HASH_TABLE_P, { LispVal *make_hash_table_no_gc(LispVal *hash_fn, LispVal *eq_fn); void release_hash_table_no_gc(LispVal *val); +DECLARE_FUNCTION(hash_table_p, (LispVal * val)); DECLARE_FUNCTION(make_hash_table, (LispVal * hash_fn, LispVal *eq_fn)); DECLARE_FUNCTION(gethash, (LispVal * ht, LispVal *key, LispVal *def)); DECLARE_FUNCTION(puthash, (LispVal * ht, LispVal *key, LispVal *val)); diff --git a/src/lisp.c b/src/lisp.c index 96f8e05..936f8c0 100644 --- a/src/lisp.c +++ b/src/lisp.c @@ -49,6 +49,7 @@ static void register_manual_symbols(void) { } void lisp_init(void) { + mp_set_memory_functions(lisp_malloc, lisp_realloc_gmp, lisp_free_gmp); construct_manual_symbols(); Vlexical_environment = Qnil; obarray = Fmake_hash_table(Qhash_string, Qstrings_equal); @@ -109,6 +110,7 @@ LispVal *eval(LispVal *form) { return form; } switch (((LispObject *) form)->type) { + case TYPE_GMP: case TYPE_HASH_TABLE: case TYPE_FUNCTION: case TYPE_STRING: diff --git a/src/lisp.h b/src/lisp.h index ff65322..a5d6560 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4,6 +4,7 @@ #include "base.h" #include "function.h" // IWYU pragma: export #include "hashtable.h" // IWYU pragma: export +#include "lisp_math.h" // IWYU pragma: export #include "lisp_string.h" // IWYU pragma: export #include "list.h" // IWYU pragma: export #include "macro.h" // IWYU pragma: export diff --git a/src/lisp_math.c b/src/lisp_math.c new file mode 100644 index 0000000..d756300 --- /dev/null +++ b/src/lisp_math.c @@ -0,0 +1,388 @@ +#include "lisp_math.h" + +#include "list.h" +#include "stack.h" + +#include +#include + +LispVal *copy_lisp_gmp(LispVal *gmp) { + assert(LISP_GMP_P(gmp)); + LispGmp *n = lisp_alloc_object(sizeof(LispGmp), TYPE_GMP); + mpz_init_set(n->val, ((LispGmp *) gmp)->val); + return n; +} + +LispVal *make_gmp(fixnum_t value) { + LispGmp *n = lisp_alloc_object(sizeof(LispGmp), TYPE_GMP); + mpz_init_set_si(n->val, value); + return n; +} + +LispVal *make_gmp_unsigned(unsigned long value) { + LispGmp *n = lisp_alloc_object(sizeof(LispGmp), TYPE_GMP); + mpz_init_set_ui(n->val, value); + return n; +} + +LispVal *parse_gmp(const char *str, int base) { + LispGmp *n = lisp_alloc_object(sizeof(LispGmp), TYPE_GMP); + mpz_init(n->val); + int res = mpz_set_str(n->val, str, base); + if (res != 0) { + free(n); + return NULL; + } + return n; +} + +LispVal *parse_number(const char *str, int base) { + char *endptr; + errno = 0; + intmax_t n = strtoimax(str, &endptr, base); + if ((n == INTMAX_MIN || n == INTMAX_MAX) && errno == ERANGE) { + return parse_gmp(str, base); + } else if (n < MOST_NEGATIVE_FIXNUM || n > MOST_POSITIVE_FIXNUM) { + return parse_gmp(str, base); + } else if (*endptr) { // trailing garbage + return NULL; + } + return MAKE_FIXNUM(n); +} + +DEFUN(fixnump, "fixnump", (LispVal * val), "(val)", "") { + return FIXNUMP(val) ? Qt : Qnil; +} + +DEFUN(integerp, "integerp", (LispVal * val), "(val)", "") { + return LISP_GMP_P(val) ? Qt : Qnil; +} + +DEFUN(floatp, "floatp", (LispVal * val), "(val)", "") { + return LISP_FLOAT_P(val) ? Qt : Qnil; +} + +DEFUN(numberp, "numberp", (LispVal * val), "(val)", "") { + return FIXNUMP(val) || LISP_FLOAT_P(val) || LISP_GMP_P(val) ? Qt : Qnil; +} + +enum Operator { + OPERATOR_ADD, + OPERATOR_SUB, + OPERATOR_MUL, + OPERATOR_DIV, + OPERATOR_AND, + OPERATOR_IOR, + OPERATOR_XOR, +}; + +static inline LispVal *type_for_operator(enum Operator op) { + switch (op) { + case OPERATOR_ADD: + case OPERATOR_SUB: + case OPERATOR_MUL: + case OPERATOR_DIV: + return Qnumber; + case OPERATOR_AND: + case OPERATOR_IOR: + case OPERATOR_XOR: + return Qinteger; + default: + abort(); + } +} + +LispVal *float_math_driver(enum Operator op, bool first, lisp_float_t acc, + LispVal *nums) { + assert(LISP_FLOAT_P(XCAR(nums))); + switch (op) { + case OPERATOR_AND: + case OPERATOR_IOR: + case OPERATOR_XOR: + signal_type_error(XCAR(nums), Qinteger); + break; + default: + break; + } + if (first) { + acc = XLISP_FLOAT(XCAR(nums)); + nums = XCDR(nums); + } + DOLIST(cur, nums) { + lisp_float_t n; + if (FIXNUMP(cur)) { + n = XFIXNUM(cur); + } else if (LISP_FLOAT_P(cur)) { + n = XLISP_FLOAT(cur); + } else if (LISP_GMP_P(cur)) { + n = mpz_get_d(((LispGmp *) cur)->val); + } else { + signal_type_error(cur, Qnumber); + } + switch (op) { + case OPERATOR_ADD: + acc += n; + break; + case OPERATOR_SUB: + acc -= n; + break; + case OPERATOR_MUL: + acc *= n; + break; + case OPERATOR_DIV: + acc /= n; + break; + default: + abort(); + } + } + return MAKE_LISP_FLOAT(acc); +} + +LispVal *gmp_math_driver(enum Operator op, bool first, fixnum_t fixnum_acc, + LispVal *nums) { + assert(LISP_GMP_P(XCAR(nums))); + LispGmp *acc = make_gmp(fixnum_acc); + if (first) { + mpz_set(acc->val, ((LispGmp *) XCAR(nums))->val); + nums = XCDR(nums); + first = false; + } + DOTAILS(rest, nums) { + LispVal *cur = XCAR(rest); + if (FIXNUMP(cur)) { + fixnum_t f = XFIXNUM(cur); + switch (op) { + case OPERATOR_ADD: + if (f < 0) { + mpz_sub_ui(acc->val, acc->val, -f); + } else { + mpz_add_ui(acc->val, acc->val, f); + } + break; + case OPERATOR_SUB: + if (f < 0) { + mpz_add_ui(acc->val, acc->val, -f); + } else { + mpz_sub_ui(acc->val, acc->val, f); + } + break; + case OPERATOR_MUL: + mpz_mul_si(acc->val, acc->val, f); + break; + case OPERATOR_DIV: + if (f == 0) { + lisp_signal(Qdivision_by_zero, Qnil); + } + if (f > 0) { + mpz_mul_si(acc->val, acc->val, -1); + } + mpz_tdiv_ui(acc->val, f); + break; +#define BITWISE(o) \ + { \ + mpz_t n; \ + mpz_init_set_si(n, f); \ + mpz_##o(acc->val, acc->val, n); \ + mpz_clear(n); \ + } + case OPERATOR_AND: + BITWISE(and); + break; + case OPERATOR_IOR: + BITWISE(ior); + break; + case OPERATOR_XOR: + BITWISE(xor); + break; +#undef BITWISE + default: + abort(); + } + } else if (LISP_GMP_P(cur)) { + mpz_srcptr cv = ((LispGmp *) cur)->val; + switch (op) { + case OPERATOR_ADD: + mpz_add(acc->val, acc->val, cv); + break; + case OPERATOR_SUB: + mpz_sub(acc->val, acc->val, cv); + break; + case OPERATOR_MUL: + mpz_mul(acc->val, acc->val, cv); + break; + case OPERATOR_DIV: + mpz_tdiv_q(acc->val, acc->val, cv); + break; + case OPERATOR_AND: + mpz_and(acc->val, acc->val, cv); + break; + case OPERATOR_IOR: + mpz_ior(acc->val, acc->val, cv); + break; + case OPERATOR_XOR: + mpz_xor(acc->val, acc->val, cv); + break; + default: + abort(); + } + } else if (LISP_FLOAT_P(cur)) { + return float_math_driver(op, first, mpz_get_d(acc->val), rest); + } else { + signal_type_error(cur, type_for_operator(op)); + } + } + if (mpz_cmp_si(acc->val, MOST_POSITIVE_FIXNUM) <= 0 + || mpz_cmp_si(acc->val, MOST_NEGATIVE_FIXNUM) >= 0) { + return MAKE_FIXNUM(mpz_get_si(acc->val)); + } + return acc; +} + +LispVal *math_driver(enum Operator op, LispVal *nums) { + assert(!NILP(nums)); + bool first = true; + fixnum_t acc; + LispVal *rest; + if (FIXNUMP(XCAR(nums))) { + rest = XCDR(nums); + acc = XFIXNUM(XCAR(nums)); + first = false; + } else { + rest = nums; + acc = 0; + goto change_type; + } + while (FIXNUMP(XCAR(rest))) { + bool did_overflow = false; + fixnum_t cur = XFIXNUM(XCAR(rest)); + fixnum_t out; + switch (op) { + case OPERATOR_ADD: + did_overflow = ckd_add(&out, acc, cur); + break; + case OPERATOR_SUB: + did_overflow = ckd_sub(&out, acc, cur); + break; + case OPERATOR_MUL: + did_overflow = ckd_mul(&out, acc, cur); + break; + case OPERATOR_DIV: + if (cur == 0) { + lisp_signal(Qdivision_by_zero, Qnil); + } + out = acc / cur; + break; + case OPERATOR_AND: + out = acc & cur; + break; + case OPERATOR_IOR: + out = acc | cur; + break; + case OPERATOR_XOR: + out = acc ^ cur; + break; + default: + abort(); + } + if (did_overflow) { + break; + } + acc = out; + rest = XCDR(rest); + if (NILP(rest)) { + return MAKE_FIXNUM(acc); + } + } +change_type: + return LISP_FLOAT_P(XCAR(rest)) ? float_math_driver(op, first, acc, rest) + : gmp_math_driver(op, first, acc, rest); +} + +DEFUN(plus, "+", (LispVal * nums), "(&rest nums)", "") { + if (NILP(nums)) { + return MAKE_FIXNUM(0); + } + return math_driver(OPERATOR_ADD, nums); +} + +DEFUN(minus, "-", (LispVal * nums), "(&rest nums)", "") { + if (NILP(nums)) { + return MAKE_FIXNUM(0); + } else if (NILP(XCDR(nums))) { + LispVal *num = XCAR(nums); + if (FIXNUMP(num)) { + return MAKE_FIXNUM(-XFIXNUM(num)); + } else if (LISP_FLOAT_P(num)) { + return MAKE_LISP_FLOAT(-XLISP_FLOAT(num)); + } else if (LISP_GMP_P(num)) { + LispGmp *o = make_gmp(0); + LispGmp *a = num; + mpz_mul_si(o->val, a->val, -1); + return o; + } + signal_type_error(num, Qnumber); + } + return math_driver(OPERATOR_SUB, nums); +} + +DEFUN(times, "*", (LispVal * nums), "(&rest nums)", "") { + if (NILP(nums)) { + return MAKE_FIXNUM(1); + } + return math_driver(OPERATOR_MUL, nums); +} + +DEFUN(divide, "/", (LispVal * num, LispVal *nums), "(num &rest nums)", "") { + if (NILP(nums)) { + if (FIXNUMP(num)) { + fixnum_t fv = XFIXNUM(num); + if (fv == 0) { + lisp_signal(Qdivision_by_zero, Qnil); + } else if (fv == 1) { + return MAKE_FIXNUM(1); + } else if (fv == -1) { + return MAKE_FIXNUM(-1); + } + return MAKE_FIXNUM(0); + } else if (LISP_GMP_P(num)) { + mpz_srcptr n = ((LispGmp *) num)->val; + if (mpz_cmp_ui(n, 0) == 0) { + lisp_signal(Qdivision_by_zero, Qnil); + } else if (mpz_cmp_ui(n, 1) == 0) { + return MAKE_FIXNUM(1); + } else if (mpz_cmp_ui(n, -1) == 0) { + return MAKE_FIXNUM(-1); + } + return MAKE_FIXNUM(0); + } + } + return math_driver(OPERATOR_DIV, CONS(num, nums)); +} + +DEFUN(logand, "logand", (LispVal * nums), "(&rest nums)", "") { + if (NILP(nums)) { + return MAKE_FIXNUM(-1); + } + return math_driver(OPERATOR_AND, nums); +} + +DEFUN(logior, "logior", (LispVal * nums), "(&rest nums)", "") { + if (NILP(nums)) { + return MAKE_FIXNUM(0); + } + return math_driver(OPERATOR_IOR, nums); +} + +DEFUN(logxor, "logxor", (LispVal * nums), "(&rest nums)", "") { + if (NILP(nums)) { + return MAKE_FIXNUM(0); + } + return math_driver(OPERATOR_XOR, nums); +} + +DEFINE_SYMBOL(integer, "integer"); +DEFINE_SYMBOL(number, "number"); + +DEFINE_SYMBOL(division_by_zero, "division-by-zero"); +DEFINE_CONDITION_CLASS(division_by_zero, error); diff --git a/src/lisp_math.h b/src/lisp_math.h new file mode 100644 index 0000000..8f2cf1b --- /dev/null +++ b/src/lisp_math.h @@ -0,0 +1,53 @@ +#ifndef INCLUDED_LISP_MATH_H +#define INCLUDED_LISP_MATH_H + +#include "base.h" + +#include + +DEFOBJTYPE(Gmp, GMP, LISP_GMP_P, { + mpz_t val; // +}); + +LispVal *copy_lisp_gmp(LispVal *gmp); + +LispVal *make_gmp(long value); +static inline LispVal *make_number(long value) { + if (value <= MOST_POSITIVE_FIXNUM || value >= MOST_NEGATIVE_FIXNUM) { + return MAKE_FIXNUM(value); + } + return make_gmp(value); +} + +LispVal *make_gmp_unsigned(unsigned long value); +static inline LispVal *make_number_unsigned(unsigned long value) { + if (value <= MOST_POSITIVE_FIXNUM) { + return MAKE_FIXNUM(value); + } + return make_gmp_unsigned(value); +} + +// these return NULL if the passed string is invalid +LispVal *parse_gmp(const char *str, int base); +LispVal *parse_number(const char *str, int base); + +DECLARE_FUNCTION(fixnump, (LispVal * val)); +DECLARE_FUNCTION(integerp, (LispVal * val)); +DECLARE_FUNCTION(floatp, (LispVal * val)); +DECLARE_FUNCTION(numberp, (LispVal * val)); + +DECLARE_FUNCTION(plus, (LispVal * nums)); +DECLARE_FUNCTION(minus, (LispVal * nums)); +DECLARE_FUNCTION(times, (LispVal * nums)); +DECLARE_FUNCTION(divide, (LispVal * num, LispVal *nums)); +DECLARE_FUNCTION(logand, (LispVal * nums)); +DECLARE_FUNCTION(logior, (LispVal * nums)); +DECLARE_FUNCTION(logxor, (LispVal * nums)); + +DECLARE_SYMBOL(integer); +DECLARE_SYMBOL(number); + +DECLARE_SYMBOL(division_by_zero); +MAKE_CONDITION_CLASS(division_by_zero); + +#endif diff --git a/src/lisp_string.c b/src/lisp_string.c index 09c5fd9..9a4a895 100644 --- a/src/lisp_string.c +++ b/src/lisp_string.c @@ -38,6 +38,10 @@ LispVal *lisp_vsprintf(const char *format, va_list args) { return make_lisp_string(buffer, printed, true, false); } +DEFUN(stringp, "stringp", (LispVal * val), "(val)", "") { + return STRINGP(val) ? Qt : Qnil; +} + DEFUN(strings_equal, "strings-equal", (LispVal * string1, LispVal *string2), "(string1 string2)", "") { CHECK_TYPE(string1, TYPE_STRING); diff --git a/src/lisp_string.h b/src/lisp_string.h index 2536664..27101e4 100644 --- a/src/lisp_string.h +++ b/src/lisp_string.h @@ -15,6 +15,8 @@ LispVal *make_lisp_string(const char *data, size_t length, bool take, LispVal *lisp_sprintf(const char *format, ...) FORMAT(1, 2); LispVal *lisp_vsprintf(const char *format, va_list args); +DECLARE_FUNCTION(stringp, (LispVal * val)); + DECLARE_FUNCTION(strings_equal, (LispVal * string1, LispVal *string2)); DECLARE_FUNCTION(hash_string, (LispVal * string)); diff --git a/src/list.c b/src/list.c index a1b6d0b..c2008f5 100644 --- a/src/list.c +++ b/src/list.c @@ -30,6 +30,14 @@ bool list_length_eq(LispVal *list, intptr_t size) { return size == 0 && NILP(list); } +DEFUN(consp, "consp", (LispVal * val), "(val)", "") { + return CONSP(val) ? Qt : Qnil; +} + +DEFUN(atom, "atom", (LispVal * val), "(val)", "") { + return ATOM(val) ? Qt : Qnil; +} + DEFUN(cons, "cons", (LispVal * car, LispVal *cdr), "(car cdr)", "Construct a new cons object from CAR and CDR.") { return CONS(car, cdr); diff --git a/src/list.h b/src/list.h index 1287bd2..df5ad7d 100644 --- a/src/list.h +++ b/src/list.h @@ -120,6 +120,8 @@ intptr_t list_length(LispVal *list); // Return true if the length of LIST == SIZE bool list_length_eq(LispVal *list, intptr_t size); +DECLARE_FUNCTION(consp, (LispVal * val)); +DECLARE_FUNCTION(atom, (LispVal * val)); DECLARE_FUNCTION(cons, (LispVal * car, LispVal *cdr)); DECLARE_FUNCTION(car, (LispVal * list)); DECLARE_FUNCTION(cdr, (LispVal * list)); diff --git a/src/macro.c b/src/macro.c index b0db236..ee2da79 100644 --- a/src/macro.c +++ b/src/macro.c @@ -100,7 +100,7 @@ static LispVal *macroexpand_special_form(LispVal *fobj, LispVal *form, #define IS(n) (fobj == ((LispSymbol *) Q##n)->function) if (IS(lambda)) { return macroexpand_lambda_form(form, lexical_macros); - } else if (IS(quote)) { + } else if (IS(quote) || IS(function)) { return form; } else if (IS(progn) || IS(if) || IS(and) || IS(or)) { if (LISTP(XCDR(form))) { diff --git a/src/memory.c b/src/memory.c index 543f00b..bee3fee 100644 --- a/src/memory.c +++ b/src/memory.c @@ -18,6 +18,10 @@ void *lisp_realloc(void *oldptr, size_t size) { } } +void *lisp_realloc_gmp(void *oldptr, size_t oldsize, size_t size) { + return lisp_realloc(oldptr, size); +} + void *lisp_malloc(size_t size) { return lisp_realloc(NULL, size); } @@ -37,6 +41,10 @@ void *lisp_aligned_alloc(size_t alignment, size_t size) { return ptr; } +void lisp_free_gmp(void *ptr, size_t size) { + free(ptr); +} + #define STRING_STREAM_BLOCK_SIZE 32 static void ensure_string_stream_space(StringStream *restrict stream, size_t space) { @@ -99,7 +107,7 @@ bool strgetline(const char *restrict buf, size_t buf_length, *start += *length + 1; } size_t left = buf_length - (*start - buf); - char *found; + const char *found; if ((found = memchr(*start, '\n', left))) { *length = found - *start; } else { diff --git a/src/memory.h b/src/memory.h index 3f198c7..ab5542d 100644 --- a/src/memory.h +++ b/src/memory.h @@ -13,6 +13,9 @@ #ifndef __has_attribute # define __has_attribute(x) 0 #endif +#ifndef __has_builtin +# define __has_builtin(x) 0 +#endif #if __has_attribute(always_inline) && defined(_NDEBUG) # define ALWAYS_INLINE inline __attribute__((always_inline)) @@ -123,10 +126,12 @@ static ALWAYS_INLINE lisp_float64_t LISP_FLOAT64_INF(void) { // Allocator void *lisp_realloc(void *oldptr, size_t size); +void *lisp_realloc_gmp(void *oldptr, size_t oldsize, size_t size); void *lisp_malloc(size_t size); void *lisp_malloc0(size_t size); void *lisp_aligned_alloc(size_t alignment, size_t size); #define lisp_free free +void lisp_free_gmp(void *ptr, size_t size); // other useful things static ALWAYS_INLINE void sub_timespecs(const struct timespec *t1, diff --git a/src/print.c b/src/print.c index 7b7a325..f392663 100644 --- a/src/print.c +++ b/src/print.c @@ -212,6 +212,14 @@ static void print_float(struct PrintContext *restrict pc, LispVal *val) { } } +static void print_gmp(struct PrintContext *restrict pc, LispVal *val) { + LispGmp *n = val; + int base = pc->opts.base_upper ? -pc->opts.base : pc->opts.base; + char *buffer = mpz_get_str(NULL, base, n->val); + print_buffer(pc, buffer, strlen(buffer)); + free(buffer); +} + static bool seen_object_p(struct PrintContext *restrict pc, LispVal *val) { if (!pc->opts.circle) { return false; @@ -488,6 +496,9 @@ static void print_driver(struct PrintContext *restrict pc, LispVal *val) { case TYPE_FLOAT: print_float(pc, val); break; + case TYPE_GMP: + print_gmp(pc, val); + break; case TYPE_CONS: print_cons(pc, val); break; @@ -573,6 +584,9 @@ void debug_print(FILE *file, LispVal *obj) { case TYPE_FLOAT: fprintf(file, "%f", (double) XLISP_FLOAT(obj)); break; + case TYPE_GMP: + gmp_fprintf(file, "%Z", ((LispGmp *) obj)->val); + break; case TYPE_STRING: { LispString *s = obj; fputc('"', file); diff --git a/src/read.c b/src/read.c index d232cad..2813341 100644 --- a/src/read.c +++ b/src/read.c @@ -3,6 +3,7 @@ #include "function.h" #include "hashtable.h" #include "io.h" +#include "lisp_math.h" #include "lisp_string.h" #include "list.h" #include "stack.h" @@ -125,18 +126,18 @@ static void skip_whitespace(ReadStream *restrict stream) { } } -FORMAT(2, 3) -static noreturn void read_error(ReadStream *restrict stream, - const char *restrict msg, ...) { - int c = pop_char(stream); +FORMAT(4, 5) +static noreturn void read_error_at(ReadStream *restrict stream, size_t line, + size_t col, const char *restrict msg, ...) { va_list args; va_start(args, msg); LispVal *lmsg = lisp_vsprintf(msg, args); va_end(args); - lisp_signal(Qread_error, - LIST(MAKE_FIXNUM(stream->line), MAKE_FIXNUM(stream->col), lmsg, - c == READ_EOS ? Qnil : MAKE_FIXNUM(c))); + lisp_signal(Qread_error, LIST(MAKE_FIXNUM(line), MAKE_FIXNUM(col), lmsg)); } +#define SAVE_POS(l, c, s) size_t l = (s)->line, c = (s)->col + +#define read_error(s, ...) read_error_at((s), (s)->line, (s)->col, __VA_ARGS__) static ALWAYS_INLINE bool DOT_SYMBOL_P(LispVal *val) { if (!SYMBOLP(val)) { @@ -268,7 +269,7 @@ LispVal *next_char_literal(ReadStream *restrict stream) { if (c == READ_EOS) { read_error(stream, "unterminated character literal"); } else if (c == '\\') { - ReadStream save = *stream; + SAVE_POS(line, col, stream); switch (pop_char(stream)) { case 'n': return MAKE_FIXNUM('\n'); @@ -281,7 +282,7 @@ LispVal *next_char_literal(ReadStream *restrict stream) { case READ_EOS: read_error(stream, "unterminated character escape sequence"); default: - read_error(&save, "unknown escape sequence"); + read_error_at(stream, line, col, "unknown escape sequence"); } } else { return MAKE_FIXNUM(c); @@ -290,6 +291,7 @@ LispVal *next_char_literal(ReadStream *restrict stream) { LispVal *next_symbol(const char *restrict first, size_t first_size, ReadStream *restrict stream) { + // TODO error positions are off size_t read_from_first = 0; bool backslash = false; char *name = lisp_malloc(1); @@ -476,20 +478,15 @@ LispVal *next_number_or_symbol(ReadStream *restrict stream, int base) { return UNWIND_AND_RETURN(stack_ref, MAKE_LISP_FLOAT(value)); } else { // integer - // TODO handle large numbers - size_t fixnum_len = ((sizeof(fixnum_t) * 8) / 3) + 1; - char read_buf[fixnum_len + 1]; - if (len > fixnum_len) { - read_error(stream, "numeric literal too large"); + char *parse_buffer = lisp_malloc(len + 1); + memcpy(parse_buffer, &ss.buffer[number_start], len); + parse_buffer[len] = '\0'; + LispVal *num = parse_number(parse_buffer, base == ANY_BASE ? 10 : base); + free(parse_buffer); + if (!num) { + read_error(stream, "invalid numeric literal"); } - memcpy(read_buf, &ss.buffer[number_start], len); - read_buf[len] = '\0'; - intmax_t value = - strtoimax(read_buf, NULL, base == ANY_BASE ? 10 : base); - if (value < MOST_NEGATIVE_FIXNUM || value > MOST_POSITIVE_FIXNUM) { - read_error(stream, "numeric literal too large"); - } - return UNWIND_AND_RETURN(stack_ref, MAKE_FIXNUM(value)); + return UNWIND_AND_RETURN(stack_ref, num); } abort(); change_to_symbol: diff --git a/src/stack.c b/src/stack.c index 4369d4a..fa1f348 100644 --- a/src/stack.c +++ b/src/stack.c @@ -218,6 +218,7 @@ add_local_refs_for_object_sub_vals(StackFrame *restrict frame, break; } case TYPE_STRING: + case TYPE_GMP: // no held refs break; case TYPE_FIXNUM: