diff options
| author | LLLL Colonq <llll@colonq> | 2026-02-13 17:32:00 -0500 |
|---|---|---|
| committer | LLLL Colonq <llll@colonq> | 2026-02-13 17:32:00 -0500 |
| commit | 2b47c650a161fe2c2c4c7f4d74a19c2c6fe6021e (patch) | |
| tree | 357e6484f707faaafae41aa4a35bbb418c791bf1 /src/library.c | |
| parent | e6329f2ce1df83fd729e79f7e92e55fe96a2e826 (diff) | |
Update
Diffstat (limited to 'src/library.c')
| -rw-r--r-- | src/library.c | 562 |
1 files changed, 541 insertions, 21 deletions
diff --git a/src/library.c b/src/library.c index 33982dc..2cdbef7 100644 --- a/src/library.c +++ b/src/library.c @@ -20,6 +20,21 @@ static pit_value impl_sf_if(pit_runtime *rt, pit_value args) { } return PIT_NIL; } +static pit_value impl_sf_cond(pit_runtime *rt, pit_value args) { + while (args != PIT_NIL) { + pit_value clause = pit_car(rt, args); + pit_value cond = pit_car(rt, clause); + if (pit_eval(rt, cond) != PIT_NIL) { + pit_values_push(rt, rt->expr_stack, + pit_cons(rt, pit_intern_cstr(rt, "progn"), pit_cdr(rt, clause)) + ); + return PIT_NIL; + } + args = pit_cdr(rt, args); + } + pit_values_push(rt, rt->expr_stack, PIT_NIL); + return PIT_NIL; +} static pit_value impl_sf_progn(pit_runtime *rt, pit_value args) { pit_value bodyforms = args; pit_value final = PIT_NIL; @@ -30,6 +45,17 @@ static pit_value impl_sf_progn(pit_runtime *rt, pit_value args) { pit_runtime_eval_program_push_literal(rt, rt->program, final); return PIT_NIL; } +static pit_value impl_sf_or(pit_runtime *rt, pit_value args) { + pit_value bodyforms = args; + pit_value final = PIT_NIL; + while (bodyforms != PIT_NIL) { + final = pit_eval(rt, pit_car(rt, bodyforms)); + if (final != PIT_NIL) break; + bodyforms = pit_cdr(rt, bodyforms); + } + pit_runtime_eval_program_push_literal(rt, rt->program, final); + return PIT_NIL; +} static pit_value impl_sf_lambda(pit_runtime *rt, pit_value args) { pit_value as = pit_car(rt, args); pit_value body = pit_cdr(rt, args); @@ -54,6 +80,92 @@ static pit_value impl_m_defmacro(pit_runtime *rt, pit_value args) { pit_list(rt, 2, pit_intern_cstr(rt, "set-symbol-macro!"), nm) ); } +static pit_value impl_m_defstruct(pit_runtime *rt, pit_value args) { + pit_value ret = PIT_NIL; + pit_value df = PIT_NIL; + pit_value aargs = PIT_NIL; + char nm_str[128]; + char field_str[128]; + char buf[512]; + pit_value nm = pit_car(rt, args); + pit_value fields = pit_cdr(rt, args); + i64 field_idx = 0; + i64 nm_len = pit_as_bytes(rt, pit_symbol_name(rt, nm), (u8 *) nm_str, sizeof(nm_str) - 1); + if (nm_len < 0) return PIT_NIL; + nm_str[nm_len] = 0; + /* constructor */ + snprintf(buf, sizeof(buf), ":%s", nm_str); + aargs = pit_cons(rt, pit_intern_cstr(rt, buf), pit_cons(rt, pit_intern_cstr(rt, "array"), PIT_NIL)); + fields = pit_cdr(rt, args); + while (fields != PIT_NIL) { + i64 field_len = pit_as_bytes(rt, + pit_symbol_name(rt, pit_car(rt, fields)), + (u8 *) field_str, sizeof(field_str) - 1 + ); + if (field_len < 0) return PIT_NIL; + field_str[field_len] = 0; + snprintf(buf, sizeof(buf), ":%s", field_str); + aargs = pit_cons(rt, + pit_list(rt, 3, pit_intern_cstr(rt, "plist/get"), pit_intern_cstr(rt, buf), pit_intern_cstr(rt, "kwargs")), + aargs + ); + fields = pit_cdr(rt, fields); + } + snprintf(buf, sizeof(buf), "%s/new", nm_str); + df = pit_list(rt, 4, + pit_intern_cstr(rt, "defun!"), + pit_intern_cstr(rt, buf), + pit_list(rt, 2, pit_intern_cstr(rt, "&"), pit_intern_cstr(rt, "kwargs")), + pit_reverse(rt, aargs) + ); + ret = pit_cons(rt, df, ret); + /* getters and setters */ + fields = pit_cdr(rt, args); + field_idx = 0; + while (fields != PIT_NIL) { + i64 field_len = pit_as_bytes(rt, + pit_symbol_name(rt, pit_car(rt, fields)), + (u8 *) field_str, sizeof(field_str) - 1 + ); + if (field_len < 0) return PIT_NIL; + field_str[field_len] = 0; + /* getter */ + snprintf(buf, sizeof(buf), "%s/get-%s", nm_str, field_str); + df = pit_list(rt, 4, + pit_intern_cstr(rt, "defun!"), + pit_intern_cstr(rt, buf), + pit_list(rt, 1, pit_intern_cstr(rt, "v")), + pit_list(rt, 3, + pit_intern_cstr(rt, "array/get"), + pit_integer_new(rt, field_idx + 1), + pit_intern_cstr(rt, "v") + ) + ); + ret = pit_cons(rt, df, ret); + /* setter */ + snprintf(buf, sizeof(buf), "%s/set-%s!", nm_str, field_str); + df = pit_list(rt, 4, + pit_intern_cstr(rt, "defun!"), + pit_intern_cstr(rt, buf), + pit_list(rt, 2, pit_intern_cstr(rt, "v"), pit_intern_cstr(rt, "x")), + pit_list(rt, 4, + pit_intern_cstr(rt, "array/set!"), + pit_integer_new(rt, field_idx + 1), + pit_intern_cstr(rt, "x"), + pit_intern_cstr(rt, "v") + ) + ); + ret = pit_cons(rt, df, ret); + fields = pit_cdr(rt, fields); + field_idx += 1; + } + // (defstruct foo x y z) + // (defun foo/new (kwargs) ...) + // (defun foo/get-x (f) ...) + // (defun foo/set-x! (f v) ...) + // pit_trace(rt, ret); + return pit_cons(rt, pit_intern_cstr(rt, "progn"), ret); +} static pit_value impl_m_let(pit_runtime *rt, pit_value args) { pit_value lparams = PIT_NIL; pit_value largs = PIT_NIL; @@ -94,6 +206,34 @@ static pit_value impl_m_setq(pit_runtime *rt, pit_value args) { v ); } + +// (case x (y 'foo) (z 'bar)) +// (cond ((eq x 'y) 'foo) ((eq x 'z) 'bar)) +static pit_value impl_m_case(pit_runtime *rt, pit_value args) { + pit_value x = pit_car(rt, args); + pit_value cases = pit_cdr(rt, args); + pit_value clauses = PIT_NIL; + pit_value xvar = pit_intern_cstr(rt, "(internal case)"); + while (cases != PIT_NIL) { + pit_value c = pit_car(rt, cases); + clauses = pit_cons(rt, + pit_list(rt, 2, + pit_list(rt, 3, pit_intern_cstr(rt, "equal?"), + xvar, + pit_list(rt, 2, pit_intern_cstr(rt, "quote"), pit_car(rt, c)) + ), + pit_car(rt, pit_cdr(rt, c)) + ), + clauses + ); + cases = pit_cdr(rt, cases); + } + return pit_list(rt, 3, + pit_intern_cstr(rt, "let"), + pit_list(rt, 1, pit_list(rt, 2, xvar, x)), + pit_cons(rt, pit_intern_cstr(rt, "cond"), pit_reverse(rt, clauses)) + ); +} static pit_value impl_set(pit_runtime *rt, pit_value args) { pit_value sym = pit_car(rt, args); pit_value v = pit_car(rt, pit_cdr(rt, args)); @@ -112,51 +252,53 @@ static pit_value impl_symbol_is_macro(pit_runtime *rt, pit_value args) { return PIT_NIL; } static pit_value impl_funcall(pit_runtime *rt, pit_value args) { - pit_value fsym = pit_car(rt, args); - pit_value f = PIT_NIL; - if (pit_is_symbol(rt, fsym)) { - f = pit_fget(rt, fsym); - } else { - /* if f is not a symbol, assume it is a func or nativefunc - most commonly, this happens when you funcall a variable - with a function in the value cell, e.g. passing a lambda to a function */ - f = fsym; - } + pit_value f = pit_car(rt, args); return pit_apply(rt, f, pit_cdr(rt, args)); } +static pit_value impl_error(pit_runtime *rt, pit_value args) { + rt->error = PIT_T; + rt->error = pit_car(rt, args); + rt->error_line = rt->source_line; + rt->error_column = rt->source_column; + return PIT_NIL; +} static pit_value impl_eval(pit_runtime *rt, pit_value args) { return pit_eval(rt, pit_car(rt, args)); } static pit_value impl_eq_p(pit_runtime *rt, pit_value args) { pit_value x = pit_car(rt, args); pit_value y = pit_car(rt, pit_cdr(rt, args)); - return pit_eq(x, y); + return pit_bool_new(rt, pit_eq(x, y)); } static pit_value impl_equal_p(pit_runtime *rt, pit_value args) { pit_value x = pit_car(rt, args); pit_value y = pit_car(rt, pit_cdr(rt, args)); - return pit_equal(rt, x, y); + return pit_bool_new(rt, pit_equal(rt, x, y)); } static pit_value impl_integer_p(pit_runtime *rt, pit_value args) { - return pit_is_integer(rt, pit_car(rt, args)); + return pit_bool_new(rt, pit_is_integer(rt, pit_car(rt, args))); } static pit_value impl_double_p(pit_runtime *rt, pit_value args) { - return pit_is_double(rt, pit_car(rt, args)); + return pit_bool_new(rt, pit_is_double(rt, pit_car(rt, args))); } static pit_value impl_symbol_p(pit_runtime *rt, pit_value args) { - return pit_is_symbol(rt, pit_car(rt, args)); + return pit_bool_new(rt, pit_is_symbol(rt, pit_car(rt, args))); } static pit_value impl_cons_p(pit_runtime *rt, pit_value args) { - return pit_is_cons(rt, pit_car(rt, args)); + return pit_bool_new(rt, pit_is_cons(rt, pit_car(rt, args))); } static pit_value impl_array_p(pit_runtime *rt, pit_value args) { - return pit_is_array(rt, pit_car(rt, args)); + return pit_bool_new(rt, pit_is_array(rt, pit_car(rt, args))); } static pit_value impl_bytes_p(pit_runtime *rt, pit_value args) { - return pit_is_bytes(rt, pit_car(rt, args)); + return pit_bool_new(rt, pit_is_bytes(rt, pit_car(rt, args))); } static pit_value impl_function_p(pit_runtime *rt, pit_value args) { - return pit_is_bytes(rt, pit_car(rt, args)); + pit_value a = pit_car(rt, args); + bool b = (pit_is_symbol(rt, a) && pit_fget(rt, a) != PIT_NIL) + || pit_is_func(rt, a) + || pit_is_nativefunc(rt, a); + return pit_bool_new(rt, b); } static pit_value impl_cons(pit_runtime *rt, pit_value args) { return pit_cons(rt, pit_car(rt, args), pit_car(rt, pit_cdr(rt, args))); @@ -181,6 +323,62 @@ static pit_value impl_list(pit_runtime *rt, pit_value args) { (void) rt; return args; } +static pit_value impl_list_len(pit_runtime *rt, pit_value args) { + pit_value arr = pit_car(rt, args); + return pit_integer_new(rt, pit_list_len(rt, arr)); +} +static pit_value impl_list_reverse(pit_runtime *rt, pit_value args) { + return pit_reverse(rt, pit_car(rt, args)); +} +static pit_value impl_list_uniq(pit_runtime *rt, pit_value args) { + pit_value xs = pit_car(rt, args); + pit_value ret = PIT_NIL; + while (xs != PIT_NIL) { + pit_value x = pit_car(rt, xs); + if (pit_contains_equal(rt, x, ret) == PIT_NIL) { + ret = pit_cons(rt, x, ret); + } + xs = pit_cdr(rt, xs); + } + return pit_reverse(rt, ret); +} +static pit_value impl_list_append(pit_runtime *rt, pit_value args) { + args = pit_reverse(rt, args); + pit_value ret = pit_car(rt, args); + pit_value ls = pit_cdr(rt, args); + while (ls != PIT_NIL) { + pit_value xs = pit_reverse(rt, pit_car(rt, ls)); + while (xs != PIT_NIL) { + ret = pit_cons(rt, pit_car(rt, xs), ret); + xs = pit_cdr(rt, xs); + } + ls = pit_cdr(rt, ls); + } + return ret; +} +static pit_value impl_list_concat(pit_runtime *rt, pit_value args) { + return impl_list_append(rt, pit_car(rt, args)); +} +static pit_value impl_list_take(pit_runtime *rt, pit_value args) { + i64 num = pit_as_integer(rt, pit_car(rt, args)); + pit_value arr = pit_car(rt, pit_cdr(rt, args)); + pit_value ret = PIT_NIL; + while (num > 0 && arr != PIT_NIL) { + ret = pit_cons(rt, pit_car(rt, arr), ret); + arr = pit_cdr(rt, arr); + num -= 1; + } + return pit_reverse(rt, ret); +} +static pit_value impl_list_drop(pit_runtime *rt, pit_value args) { + i64 num = pit_as_integer(rt, pit_car(rt, args)); + pit_value arr = pit_car(rt, pit_cdr(rt, args)); + while (num > 0 && arr != PIT_NIL) { + arr = pit_cdr(rt, arr); + num -= 1; + } + return arr; +} static pit_value impl_list_map(pit_runtime *rt, pit_value args) { pit_value func = pit_car(rt, args); pit_value xs = pit_car(rt, pit_cdr(rt, args)); @@ -192,6 +390,200 @@ static pit_value impl_list_map(pit_runtime *rt, pit_value args) { } return pit_reverse(rt, ret); } +static pit_value impl_list_foldl(pit_runtime *rt, pit_value args) { + pit_value func = pit_car(rt, args); + pit_value acc = pit_car(rt, pit_cdr(rt, args)); + pit_value xs = pit_car(rt, pit_cdr(rt, pit_cdr(rt, args))); + while (xs != PIT_NIL) { + acc = pit_apply(rt, func, pit_list(rt, 2, pit_car(rt, xs), acc)); + xs = pit_cdr(rt, xs); + } + return acc; +} +static pit_value impl_list_filter(pit_runtime *rt, pit_value args) { + pit_value func = pit_car(rt, args); + pit_value xs = pit_car(rt, pit_cdr(rt, args)); + pit_value ret = PIT_NIL; + while (xs != PIT_NIL) { + pit_value x = pit_car(rt, xs); + pit_value y = pit_apply(rt, func, pit_cons(rt, x, PIT_NIL)); + if (y != PIT_NIL) { + ret = pit_cons(rt, x, ret); + } + xs = pit_cdr(rt, xs); + } + return pit_reverse(rt, ret); +} +static pit_value impl_list_find(pit_runtime *rt, pit_value args) { + pit_value func = pit_car(rt, args); + pit_value xs = pit_car(rt, pit_cdr(rt, args)); + while (xs != PIT_NIL) { + pit_value x = pit_car(rt, xs); + pit_value y = pit_apply(rt, func, pit_cons(rt, x, PIT_NIL)); + if (y != PIT_NIL) { + return x; + } + xs = pit_cdr(rt, xs); + } + return PIT_NIL; +} +static pit_value impl_list_contains_p(pit_runtime *rt, pit_value args) { + pit_value needle = pit_car(rt, args); + pit_value haystack = pit_car(rt, pit_cdr(rt, args)); + while (haystack != PIT_NIL) { + if (pit_equal(rt, needle, pit_car(rt, haystack))) return PIT_T; + haystack = pit_cdr(rt, haystack); + } + return PIT_NIL; +} +static pit_value impl_list_all_p(pit_runtime *rt, pit_value args) { + pit_value f = pit_car(rt, args); + pit_value xs = pit_car(rt, pit_cdr(rt, args)); + while (xs != PIT_NIL) { + pit_value x = pit_car(rt, xs); + if (pit_apply(rt, f, pit_cons(rt, x, PIT_NIL)) == PIT_NIL) { + return PIT_NIL; + } + xs = pit_cdr(rt, xs); + } + return PIT_T; +} +static pit_value impl_list_zip_with(pit_runtime *rt, pit_value args) { + pit_value f = pit_car(rt, args); + pit_value xs = pit_car(rt, pit_cdr(rt, args)); + pit_value ys = pit_car(rt, pit_cdr(rt, pit_cdr(rt, args))); + pit_value ret = PIT_NIL; + while (xs != PIT_NIL && ys != PIT_NIL) { + pit_value z = pit_apply(rt, f, pit_list(rt, 2, pit_car(rt, xs), pit_car(rt, ys))); + ret = pit_cons(rt, z, ret); + xs = pit_cdr(rt, xs); ys = pit_cdr(rt, ys); + } + return pit_reverse(rt, ret); +} +static pit_value impl_bytes_len(pit_runtime *rt, pit_value args) { + pit_value v = pit_car(rt, args); + if (pit_value_sort(v) != PIT_VALUE_SORT_REF) { + pit_error(rt, "value is not a ref"); + return PIT_NIL; + } + pit_value_heavy *h = pit_deref(rt, pit_as_ref(rt, v)); + if (!h) { pit_error(rt, "bad ref"); return PIT_NIL; } + if (h->hsort != PIT_VALUE_HEAVY_SORT_BYTES) { pit_error(rt, "ref is not bytes"); return PIT_NIL; } + return pit_integer_new(rt, h->in.bytes.len); +} +static pit_value impl_bytes_range(pit_runtime *rt, pit_value args) { + i64 start = pit_as_integer(rt, pit_car(rt, args)); + i64 end = pit_as_integer(rt, pit_car(rt, pit_cdr(rt, args))); + pit_value v = pit_car(rt, pit_cdr(rt, pit_cdr(rt, args))); + if (pit_value_sort(v) != PIT_VALUE_SORT_REF) { + pit_error(rt, "value is not a ref"); + return PIT_NIL; + } + pit_value_heavy *h = pit_deref(rt, pit_as_ref(rt, v)); + if (!h) { pit_error(rt, "bad ref"); return PIT_NIL; } + if (h->hsort != PIT_VALUE_HEAVY_SORT_BYTES) { pit_error(rt, "ref is not bytes"); return PIT_NIL; } + if (start < 0 || start >= h->in.bytes.len) { + pit_error(rt, "bytes range start index out of bounds: %d", start); + return PIT_NIL; + } + if (end < start || end < 0 || end > h->in.bytes.len) { + pit_error(rt, "bytes range end index out of bounds: %d", end); + return PIT_NIL; + } + return pit_bytes_new(rt, h->in.bytes.data + start, end - start); +} +static pit_value impl_array(pit_runtime *rt, pit_value args) { + i64 scratch_reset = rt->scratch->next; + i64 len = 0; + while (args != PIT_NIL) { + pit_value *cell = pit_arena_alloc_bulk(rt->scratch, sizeof(pit_value)); + *cell = pit_car(rt, args); + len += 1; + args = pit_cdr(rt, args); + } + rt->scratch->next = scratch_reset; + return pit_array_from_buf(rt, pit_arena_idx(rt->scratch, (i32) scratch_reset), len); +} +static pit_value impl_array_to_list(pit_runtime *rt, pit_value args) { + pit_value arr = pit_car(rt, args); + i64 ilen = pit_array_len(rt, arr); + pit_value ret = PIT_NIL; + i64 i = 0; + for (; i < ilen; ++i) { + ret = pit_cons(rt, pit_array_get(rt, arr, i), ret); + } + return pit_reverse(rt, ret); +} +static pit_value impl_array_from_list(pit_runtime *rt, pit_value args) { + i64 i = 0; + pit_value xs = pit_car(rt, args); + i64 ilen = pit_list_len(rt, xs); + pit_value ret = pit_array_new(rt, ilen); + pit_value_heavy *h = pit_deref(rt, pit_as_ref(rt, ret)); + if (!h) { pit_error(rt, "failed to deref heavy value for array"); return PIT_NIL; } + while (xs != PIT_NIL) { + h->in.array.data[i] = pit_car(rt, xs); + xs = pit_cdr(rt, xs); + i += 1; + } + return ret; +} +static pit_value impl_array_repeat(pit_runtime *rt, pit_value args) { + i64 i = 0; + pit_value v = pit_car(rt, args); + pit_value len = pit_car(rt, pit_cdr(rt, args)); + i64 ilen = pit_as_integer(rt, len); + pit_value ret = pit_array_new(rt, ilen); + pit_value_heavy *h = pit_deref(rt, pit_as_ref(rt, ret)); + if (!h) { pit_error(rt, "failed to deref heavy value for array"); return PIT_NIL; } + for (; i < ilen; ++i) { + h->in.array.data[i] = v; + } + return ret; +} +static pit_value impl_array_len(pit_runtime *rt, pit_value args) { + pit_value arr = pit_car(rt, args); + return pit_integer_new(rt, pit_array_len(rt, arr)); +} +static pit_value impl_array_get(pit_runtime *rt, pit_value args) { + pit_value idx = pit_car(rt, args); + pit_value arr = pit_car(rt, pit_cdr(rt, args)); + return pit_array_get(rt, arr, pit_as_integer(rt, idx)); +} +static pit_value impl_array_set(pit_runtime *rt, pit_value args) { + pit_value idx = pit_car(rt, args); + pit_value v = pit_car(rt, pit_cdr(rt, args)); + pit_value arr = pit_car(rt, pit_cdr(rt, pit_cdr(rt, args))); + return pit_array_set(rt, arr, pit_as_integer(rt, idx), v); +} +static pit_value impl_array_map(pit_runtime *rt, pit_value args) { + pit_value func = pit_car(rt, args); + pit_value arr = pit_car(rt, pit_cdr(rt, args)); + i64 len = pit_array_len(rt, arr); + pit_value ret = pit_array_new(rt, len); + i64 i = 0; + for (i = 0; i < len; ++i) { + pit_value y = pit_apply(rt, func, pit_cons(rt, pit_array_get(rt, arr, i), PIT_NIL)); + pit_array_set(rt, ret, i, y); + } + return ret; +} +static pit_value impl_array_map_mut(pit_runtime *rt, pit_value args) { + pit_value func = pit_car(rt, args); + pit_value arr = pit_car(rt, pit_cdr(rt, args)); + i64 len = pit_array_len(rt, arr); + i64 i = 0; + for (i = 0; i < len; ++i) { + pit_value y = pit_apply(rt, func, pit_cons(rt, pit_array_get(rt, arr, i), PIT_NIL)); + pit_array_set(rt, arr, i, y); + } + return arr; +} +static pit_value impl_abs(pit_runtime *rt, pit_value args) { + i64 x = pit_as_integer(rt, pit_car(rt, args)); + if (x < 0) return pit_integer_new(rt, -x); + return pit_integer_new(rt, x); +} static pit_value impl_add(pit_runtime *rt, pit_value args) { i64 total = 0; while (args != PIT_NIL) { @@ -201,8 +593,7 @@ static pit_value impl_add(pit_runtime *rt, pit_value args) { return pit_integer_new(rt, total); } static pit_value impl_sub(pit_runtime *rt, pit_value args) { - i64 total = pit_as_integer(rt, pit_car(rt, args)); - args = pit_cdr(rt, args); + i64 total = 0; while (args != PIT_NIL) { total -= pit_as_integer(rt, pit_car(rt, args)); args = pit_cdr(rt, args); @@ -231,18 +622,89 @@ static pit_value impl_div(pit_runtime *rt, pit_value args) { } return pit_integer_new(rt, total); } +static pit_value impl_not(pit_runtime *rt, pit_value args) { + if (pit_car(rt, args) == PIT_NIL) { + return PIT_T; + } else { + return PIT_NIL; + } +} +static pit_value impl_lt(pit_runtime *rt, pit_value args) { + i64 x = pit_as_integer(rt, pit_car(rt, args)); + i64 y = pit_as_integer(rt, pit_car(rt, pit_cdr(rt, args))); + return pit_bool_new(rt, x < y); +} +static pit_value impl_gt(pit_runtime *rt, pit_value args) { + i64 x = pit_as_integer(rt, pit_car(rt, args)); + i64 y = pit_as_integer(rt, pit_car(rt, pit_cdr(rt, args))); + return pit_bool_new(rt, x > y); +} +static pit_value impl_le(pit_runtime *rt, pit_value args) { + i64 x = pit_as_integer(rt, pit_car(rt, args)); + i64 y = pit_as_integer(rt, pit_car(rt, pit_cdr(rt, args))); + return pit_bool_new(rt, x <= y); +} +static pit_value impl_ge(pit_runtime *rt, pit_value args) { + i64 x = pit_as_integer(rt, pit_car(rt, args)); + i64 y = pit_as_integer(rt, pit_car(rt, pit_cdr(rt, args))); + return pit_bool_new(rt, x >= y); +} +static pit_value impl_bitwise_and(pit_runtime *rt, pit_value args) { + i64 total = -1; + while (args != PIT_NIL) { + total &= pit_as_integer(rt, pit_car(rt, args)); + args = pit_cdr(rt, args); + } + return pit_integer_new(rt, total); +} +static pit_value impl_bitwise_or(pit_runtime *rt, pit_value args) { + i64 total = 0; + while (args != PIT_NIL) { + total |= pit_as_integer(rt, pit_car(rt, args)); + args = pit_cdr(rt, args); + } + return pit_integer_new(rt, total); +} +static pit_value impl_bitwise_xor(pit_runtime *rt, pit_value args) { + i64 total = 0; + while (args != PIT_NIL) { + total ^= pit_as_integer(rt, pit_car(rt, args)); + args = pit_cdr(rt, args); + } + return pit_integer_new(rt, total); +} +static pit_value impl_bitwise_not(pit_runtime *rt, pit_value args) { + i64 x = pit_as_integer(rt, pit_car(rt, args)); + return pit_integer_new(rt, ~x); +} +static pit_value impl_bitwise_lshift(pit_runtime *rt, pit_value args) { + i64 val = pit_as_integer(rt, pit_car(rt, args)); + i64 shift = pit_as_integer(rt, pit_car(rt, pit_cdr(rt, args))); + return pit_integer_new(rt, val << shift); +} +static pit_value impl_bitwise_rshift(pit_runtime *rt, pit_value args) { + i64 val = pit_as_integer(rt, pit_car(rt, args)); + i64 shift = pit_as_integer(rt, pit_car(rt, pit_cdr(rt, args))); + return pit_integer_new(rt, val >> shift); +} void pit_install_library_essential(pit_runtime *rt) { /* special forms */ pit_sfset(rt, pit_intern_cstr(rt, "quote"), pit_nativefunc_new(rt, impl_sf_quote)); pit_sfset(rt, pit_intern_cstr(rt, "if"), pit_nativefunc_new(rt, impl_sf_if)); + pit_sfset(rt, pit_intern_cstr(rt, "cond"), pit_nativefunc_new(rt, impl_sf_cond)); pit_sfset(rt, pit_intern_cstr(rt, "progn"), pit_nativefunc_new(rt, impl_sf_progn)); + pit_sfset(rt, pit_intern_cstr(rt, "or"), pit_nativefunc_new(rt, impl_sf_or)); pit_sfset(rt, pit_intern_cstr(rt, "lambda"), pit_nativefunc_new(rt, impl_sf_lambda)); /* macros */ pit_mset(rt, pit_intern_cstr(rt, "defun!"), pit_nativefunc_new(rt, impl_m_defun)); pit_mset(rt, pit_intern_cstr(rt, "defmacro!"), pit_nativefunc_new(rt, impl_m_defmacro)); + pit_mset(rt, pit_intern_cstr(rt, "defstruct!"), pit_nativefunc_new(rt, impl_m_defstruct)); pit_mset(rt, pit_intern_cstr(rt, "let"), pit_nativefunc_new(rt, impl_m_let)); pit_mset(rt, pit_intern_cstr(rt, "and"), pit_nativefunc_new(rt, impl_m_and)); pit_mset(rt, pit_intern_cstr(rt, "setq!"), pit_nativefunc_new(rt, impl_m_setq)); + pit_mset(rt, pit_intern_cstr(rt, "case"), pit_nativefunc_new(rt, impl_m_case)); + /* error */ + pit_fset(rt, pit_intern_cstr(rt, "error!"), pit_nativefunc_new(rt, impl_error)); /* eval */ pit_fset(rt, pit_intern_cstr(rt, "eval!"), pit_nativefunc_new(rt, impl_eval)); /* predicates */ @@ -268,12 +730,53 @@ void pit_install_library_essential(pit_runtime *rt) { pit_fset(rt, pit_intern_cstr(rt, "setcdr!"), pit_nativefunc_new(rt, impl_setcdr)); /* cons lists*/ pit_fset(rt, pit_intern_cstr(rt, "list"), pit_nativefunc_new(rt, impl_list)); + pit_fset(rt, pit_intern_cstr(rt, "list/len"), pit_nativefunc_new(rt, impl_list_len)); + pit_fset(rt, pit_intern_cstr(rt, "list/reverse"), pit_nativefunc_new(rt, impl_list_reverse)); + pit_fset(rt, pit_intern_cstr(rt, "list/uniq"), pit_nativefunc_new(rt, impl_list_uniq)); + pit_fset(rt, pit_intern_cstr(rt, "list/append"), pit_nativefunc_new(rt, impl_list_append)); + pit_fset(rt, pit_intern_cstr(rt, "list/concat"), pit_nativefunc_new(rt, impl_list_concat)); + pit_fset(rt, pit_intern_cstr(rt, "list/take"), pit_nativefunc_new(rt, impl_list_take)); + pit_fset(rt, pit_intern_cstr(rt, "list/drop"), pit_nativefunc_new(rt, impl_list_drop)); pit_fset(rt, pit_intern_cstr(rt, "list/map"), pit_nativefunc_new(rt, impl_list_map)); + pit_fset(rt, pit_intern_cstr(rt, "list/foldl"), pit_nativefunc_new(rt, impl_list_foldl)); + pit_fset(rt, pit_intern_cstr(rt, "list/filter"), pit_nativefunc_new(rt, impl_list_filter)); + pit_fset(rt, pit_intern_cstr(rt, "list/find"), pit_nativefunc_new(rt, impl_list_find)); + pit_fset(rt, pit_intern_cstr(rt, "list/contains?"), pit_nativefunc_new(rt, impl_list_contains_p)); + pit_fset(rt, pit_intern_cstr(rt, "list/all?"), pit_nativefunc_new(rt, impl_list_all_p)); + pit_fset(rt, pit_intern_cstr(rt, "list/zip-with"), pit_nativefunc_new(rt, impl_list_zip_with)); + /* bytestrings */ + pit_fset(rt, pit_intern_cstr(rt, "bytes/len"), pit_nativefunc_new(rt, impl_bytes_len)); + pit_fset(rt, pit_intern_cstr(rt, "bytes/range"), pit_nativefunc_new(rt, impl_bytes_range)); + /* array */ + pit_fset(rt, pit_intern_cstr(rt, "array"), pit_nativefunc_new(rt, impl_array)); + pit_fset(rt, pit_intern_cstr(rt, "array/to-list"), pit_nativefunc_new(rt, impl_array_to_list)); + pit_fset(rt, pit_intern_cstr(rt, "array/from-list"), pit_nativefunc_new(rt, impl_array_from_list)); + pit_fset(rt, pit_intern_cstr(rt, "array/repeat"), pit_nativefunc_new(rt, impl_array_repeat)); + pit_fset(rt, pit_intern_cstr(rt, "array/len"), pit_nativefunc_new(rt, impl_array_len)); + pit_fset(rt, pit_intern_cstr(rt, "array/get"), pit_nativefunc_new(rt, impl_array_get)); + pit_fset(rt, pit_intern_cstr(rt, "array/set!"), pit_nativefunc_new(rt, impl_array_set)); + pit_fset(rt, pit_intern_cstr(rt, "array/map"), pit_nativefunc_new(rt, impl_array_map)); + pit_fset(rt, pit_intern_cstr(rt, "array/map!"), pit_nativefunc_new(rt, impl_array_map_mut)); /* arithmetic */ + pit_fset(rt, pit_intern_cstr(rt, "abs"), pit_nativefunc_new(rt, impl_abs)); pit_fset(rt, pit_intern_cstr(rt, "+"), pit_nativefunc_new(rt, impl_add)); pit_fset(rt, pit_intern_cstr(rt, "-"), pit_nativefunc_new(rt, impl_sub)); pit_fset(rt, pit_intern_cstr(rt, "*"), pit_nativefunc_new(rt, impl_mul)); pit_fset(rt, pit_intern_cstr(rt, "/"), pit_nativefunc_new(rt, impl_div)); + /* booleans */ + pit_fset(rt, pit_intern_cstr(rt, "not"), pit_nativefunc_new(rt, impl_not)); + /* comparisons */ + pit_fset(rt, pit_intern_cstr(rt, "<"), pit_nativefunc_new(rt, impl_lt)); + pit_fset(rt, pit_intern_cstr(rt, ">"), pit_nativefunc_new(rt, impl_gt)); + pit_fset(rt, pit_intern_cstr(rt, "<="), pit_nativefunc_new(rt, impl_le)); + pit_fset(rt, pit_intern_cstr(rt, ">="), pit_nativefunc_new(rt, impl_ge)); + /* bitwise arithmetic */ + pit_fset(rt, pit_intern_cstr(rt, "bitwise/and"), pit_nativefunc_new(rt, impl_bitwise_and)); + pit_fset(rt, pit_intern_cstr(rt, "bitwise/or"), pit_nativefunc_new(rt, impl_bitwise_or)); + pit_fset(rt, pit_intern_cstr(rt, "bitwise/xor"), pit_nativefunc_new(rt, impl_bitwise_xor)); + pit_fset(rt, pit_intern_cstr(rt, "bitwise/not"), pit_nativefunc_new(rt, impl_bitwise_not)); + pit_fset(rt, pit_intern_cstr(rt, "bitwise/lshift"), pit_nativefunc_new(rt, impl_bitwise_lshift)); + pit_fset(rt, pit_intern_cstr(rt, "bitwise/rshift"), pit_nativefunc_new(rt, impl_bitwise_rshift)); } static pit_value impl_print(pit_runtime *rt, pit_value args) { @@ -332,6 +835,23 @@ void pit_install_library_plist(pit_runtime *rt) { pit_fset(rt, pit_intern_cstr(rt, "plist/get"), pit_nativefunc_new(rt, impl_plist_get)); } +static pit_value impl_alist_get(pit_runtime *rt, pit_value args) { + pit_value k = pit_car(rt, args); + pit_value vs = pit_car(rt, pit_cdr(rt, args)); + while (vs != PIT_NIL) { + pit_value v = pit_car(rt, vs); + if (pit_equal(rt, k, pit_car(rt, v))) { + return pit_cdr(rt, v); + } + vs = pit_cdr(rt, vs); + } + return PIT_NIL; +} +void pit_install_library_alist(pit_runtime *rt) { + /* association lists */ + pit_fset(rt, pit_intern_cstr(rt, "alist/get"), pit_nativefunc_new(rt, impl_alist_get)); +} + struct bytestring { i64 len, cap; u8 *data; |
