From 2b47c650a161fe2c2c4c7f4d74a19c2c6fe6021e Mon Sep 17 00:00:00 2001 From: LLLL Colonq Date: Fri, 13 Feb 2026 17:32:00 -0500 Subject: Update --- array.lisp | 2 + broken.lisp | 5 + fold.lisp | 12 + include/lcq/pit/lexer.h | 2 + include/lcq/pit/library.h | 1 + include/lcq/pit/runtime.h | 20 +- nonbroken.lisp | 2 + src/lexer.c | 19 +- src/library.c | 562 ++++++++++++++++++++++++++++++++++++++++++++-- src/main.c | 7 +- src/parser.c | 57 ++++- src/runtime.c | 188 ++++++++++++---- struct.lisp | 11 + test.lisp | 22 ++ thebug.lisp | 9 + x86.lisp | 330 +++++++++++++++++++++++++++ y.lisp | 5 + 17 files changed, 1181 insertions(+), 73 deletions(-) create mode 100644 array.lisp create mode 100644 broken.lisp create mode 100644 fold.lisp create mode 100644 nonbroken.lisp create mode 100644 struct.lisp create mode 100644 test.lisp create mode 100644 thebug.lisp create mode 100644 x86.lisp create mode 100644 y.lisp diff --git a/array.lisp b/array.lisp new file mode 100644 index 0000000..976f70d --- /dev/null +++ b/array.lisp @@ -0,0 +1,2 @@ +(print! (array/repeat 'foo 1000)) +(array/repeat 'foo 10000) diff --git a/broken.lisp b/broken.lisp new file mode 100644 index 0000000..09f4afc --- /dev/null +++ b/broken.lisp @@ -0,0 +1,5 @@ +;; (let ((foo (+ 1 1))) +;; (print! foo)) +((lambda (foo) + (print! foo)) + (+ 1 1)) diff --git a/fold.lisp b/fold.lisp new file mode 100644 index 0000000..89031d0 --- /dev/null +++ b/fold.lisp @@ -0,0 +1,12 @@ +(defun! foo (x) + (+ x 1)) +(print! (foo 1)) +(print! (funcall 'foo 1)) +(print! (list/map 'foo '(1 2 3))) +(print! (list/foldl '+ 0 '(1 2 3))) +(print! (list/take 2 '(1 2 3))) +(print! (list/take 0 '(1 2 3))) +(print! (list/take 100 '(1 2 3))) +(print! (list/drop 2 '(1 2 3))) +(print! (list/drop 10 '(1 2 3))) +(print! (list/filter 'integer? '(1 foo 2 bar baz 3 quux))) diff --git a/include/lcq/pit/lexer.h b/include/lcq/pit/lexer.h index d6e4611..7664e87 100644 --- a/include/lcq/pit/lexer.h +++ b/include/lcq/pit/lexer.h @@ -8,6 +8,8 @@ typedef enum { PIT_LEX_TOKEN_EOF=0, PIT_LEX_TOKEN_LPAREN, PIT_LEX_TOKEN_RPAREN, + PIT_LEX_TOKEN_LSQUARE, + PIT_LEX_TOKEN_RSQUARE, PIT_LEX_TOKEN_DOT, PIT_LEX_TOKEN_QUOTE, PIT_LEX_TOKEN_INTEGER_LITERAL, diff --git a/include/lcq/pit/library.h b/include/lcq/pit/library.h index 6bca3a6..dc57655 100644 --- a/include/lcq/pit/library.h +++ b/include/lcq/pit/library.h @@ -6,6 +6,7 @@ void pit_install_library_essential(pit_runtime *rt); void pit_install_library_io(pit_runtime *rt); void pit_install_library_plist(pit_runtime *rt); +void pit_install_library_alist(pit_runtime *rt); void pit_install_library_bytestring(pit_runtime *rt); #endif diff --git a/include/lcq/pit/runtime.h b/include/lcq/pit/runtime.h index 0e92b7f..41ca3ec 100644 --- a/include/lcq/pit/runtime.h +++ b/include/lcq/pit/runtime.h @@ -22,7 +22,7 @@ void *pit_arena_alloc_bulk(pit_arena *a, i64 num); /* nil is always the symbol with index 0 */ #define PIT_NIL 0xfff4000000000000 /* 0b1111111111110100000000000000000000000000000000000000000000000000 */ -#define PIT_T 0xfff4000000000001 /* 0b1111111111110100000000000000000000000000000000000000000000000001 */ +#define PIT_T (PIT_NIL+sizeof(pit_symtab_entry)) enum pit_value_sort { PIT_VALUE_SORT_DOUBLE = 0, /* 0b00 - double */ @@ -95,6 +95,7 @@ void pit_runtime_eval_program_push_apply(struct pit_runtime *rt, pit_runtime_eva typedef struct pit_runtime { /* interpreter state */ pit_arena *values; /* all heavy values - effectively an array of pit_value_heavy - MUTABLE! */ + pit_arena *arrays; /* all arrays - MUTABLE! */ pit_arena *bytes; /* all bytestrings (including symbol names) - immutable */ pit_arena *symtab; i64 symtab_len; /* all symbols - effectively an array of pit_symtab_entry - MUTABLE! */ /* temporary/"scratch" memory */ @@ -105,7 +106,7 @@ typedef struct pit_runtime { pit_runtime_eval_program *program; /* intermediate stack-based program constructed during evaluation */ /* bookkeeping */ /* "frozen" values offsets: values before these offsets are immutable, and we can reset here later */ - i64 frozen_values, frozen_bytes, frozen_symtab; + i64 frozen_values, frozen_arrays, frozen_bytes, frozen_symtab; pit_value error; /* error value - if this is non-nil, an error has occured! only tracks the first error */ i64 source_line, source_column; /* for error reporting only; line and column of token start */ i64 error_line, error_column; /* line and column of token start at time of error */ @@ -127,6 +128,7 @@ double pit_as_double(pit_runtime *rt, pit_value v); pit_value pit_double_new(pit_runtime *rt, double d); i64 pit_as_integer(pit_runtime *rt, pit_value v); pit_value pit_integer_new(pit_runtime *rt, i64 i); +pit_value pit_bool_new(pit_runtime *rt, bool i); pit_symbol pit_as_symbol(pit_runtime *rt, pit_value v); pit_value pit_symbol_new(pit_runtime *rt, pit_symbol s); pit_ref pit_as_ref(pit_runtime *rt, pit_value v); @@ -163,6 +165,7 @@ pit_value pit_read_bytes(pit_runtime *rt, pit_value v); /* working with the symbol table */ pit_value pit_intern(pit_runtime *rt, u8 *nm, i64 len); pit_value pit_intern_cstr(pit_runtime *rt, char *nm); +pit_value pit_symbol_name(pit_runtime *rt, pit_value sym); bool pit_symbol_name_match(pit_runtime *rt, pit_value sym, u8 *buf, i64 len); bool pit_symbol_name_match_cstr(pit_runtime *rt, pit_value sym, char *s); pit_symtab_entry *pit_symtab_lookup(pit_runtime *rt, pit_value sym); @@ -183,12 +186,20 @@ pit_value pit_unbind(pit_runtime *rt, pit_value sym); /* working with cells */ pit_value pit_cell_new(pit_runtime *rt, pit_value v); -pit_value pit_cell_get(pit_runtime *rt, pit_value cell); -void pit_cell_set(pit_runtime *rt, pit_value cell, pit_value v); +pit_value pit_cell_get(pit_runtime *rt, pit_value cell, pit_value sym); +void pit_cell_set(pit_runtime *rt, pit_value cell, pit_value v, pit_value sym); + +/* working with arrays */ +pit_value pit_array_new(pit_runtime *rt, i64 len); +pit_value pit_array_from_buf(pit_runtime *rt, pit_value *xs, i64 len); +i64 pit_array_len(pit_runtime *rt, pit_value arr); +pit_value pit_array_get(pit_runtime *rt, pit_value arr, i64 idx); +pit_value pit_array_set(pit_runtime *rt, pit_value arr, i64 idx, pit_value v); /* working with cons cells */ pit_value pit_cons(pit_runtime *rt, pit_value car, pit_value cdr); pit_value pit_list(pit_runtime *rt, i64 num, ...); +i64 pit_list_len(pit_runtime *rt, pit_value xs); pit_value pit_car(pit_runtime *rt, pit_value v); pit_value pit_cdr(pit_runtime *rt, pit_value v); void pit_setcar(pit_runtime *rt, pit_value v, pit_value x); @@ -196,6 +207,7 @@ void pit_setcdr(pit_runtime *rt, pit_value v, pit_value x); pit_value pit_append(pit_runtime *rt, pit_value xs, pit_value ys); pit_value pit_reverse(pit_runtime *rt, pit_value xs); pit_value pit_contains_eq(pit_runtime *rt, pit_value needle, pit_value haystack); +pit_value pit_contains_equal(pit_runtime *rt, pit_value needle, pit_value haystack); pit_value pit_plist_get(pit_runtime *rt, pit_value k, pit_value vs); /* working with functions */ diff --git a/nonbroken.lisp b/nonbroken.lisp new file mode 100644 index 0000000..350f64f --- /dev/null +++ b/nonbroken.lisp @@ -0,0 +1,2 @@ +(+ 1 + (fwefwfwfwe 1 1)) diff --git a/src/lexer.c b/src/lexer.c index 019dcc5..623dd39 100644 --- a/src/lexer.c +++ b/src/lexer.c @@ -11,6 +11,8 @@ const char *PIT_LEX_TOKEN_NAMES[PIT_LEX_TOKEN__SENTINEL] = { /* [PIT_LEX_TOKEN_EOF] = */ "eof", /* [PIT_LEX_TOKEN_LPAREN] = */ "lparen", /* [PIT_LEX_TOKEN_RPAREN] = */ "rparen", + /* [PIT_LEX_TOKEN_LSQUARE] = */ "lsquare", + /* [PIT_LEX_TOKEN_RSQUARE] = */ "rsquare", /* [PIT_LEX_TOKEN_DOT] = */ "dot", /* [PIT_LEX_TOKEN_QUOTE] = */ "quote", /* [PIT_LEX_TOKEN_INTEGER_LITERAL] = */ "integer_literal", @@ -30,6 +32,11 @@ static int is_symchar(int c) { return c != '(' && c != ')' && c != '.' && c != '\'' && c != '"' && isprint(c) && !isspace(c); } +static int is_hexdigit(int c) { + return isdigit(c) || (c >= 'a' && c <= 'f') || (c >= 'A' && c <= 'F'); +} + + static char peek(pit_lexer *st) { if (is_more_input(st)) return st->input[st->end]; else return 0; @@ -104,6 +111,8 @@ restart: case ';': while (is_more_input(st) && advance(st) != '\n'); goto restart; case '(': return PIT_LEX_TOKEN_LPAREN; case ')': return PIT_LEX_TOKEN_RPAREN; + case '[': return PIT_LEX_TOKEN_LSQUARE; + case ']': return PIT_LEX_TOKEN_RSQUARE; case '.': return PIT_LEX_TOKEN_DOT; case '\'': return PIT_LEX_TOKEN_QUOTE; case '"': @@ -119,10 +128,14 @@ restart: default: if (isspace(c)) goto restart; if (isdigit(c)) { - while (match(st, isdigit)) {} + if (c == '0') { + int next = peek(st); + if (next != 'x' && next != 'o' && next != 'b') return PIT_LEX_TOKEN_INTEGER_LITERAL; + advance(st); /* skip base specifier */ + } + while (match(st, is_hexdigit)) {} return PIT_LEX_TOKEN_INTEGER_LITERAL; - } - else { + } else { while (match(st, is_symchar)) {} return PIT_LEX_TOKEN_SYMBOL; } 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; diff --git a/src/main.c b/src/main.c index bc697de..0b9a336 100644 --- a/src/main.c +++ b/src/main.c @@ -12,6 +12,7 @@ int main(int argc, char **argv) { pit_install_library_essential(rt); pit_install_library_io(rt); pit_install_library_plist(rt); + pit_install_library_alist(rt); pit_install_library_bytestring(rt); if (argc < 2) { /* run repl */ char buf[1024] = {0}; @@ -49,11 +50,11 @@ int main(int argc, char **argv) { } pit_parser_from_lexer(&parse, &lex); while (p = pit_parse(rt, &parse, &eof), !eof) { + if (pit_runtime_print_error(rt)) exit(1); pit_eval(rt, p); - if (pit_runtime_print_error(rt)) { - exit(1); - } + if (pit_runtime_print_error(rt)) exit(1); } + if (pit_runtime_print_error(rt)) exit(1); } return 0; } diff --git a/src/parser.c b/src/parser.c index 4403323..9c112c2 100644 --- a/src/parser.c +++ b/src/parser.c @@ -37,6 +37,18 @@ static void get_token_string(pit_parser *st, char *buf, i64 len) { buf[tlen] = 0; } +static i64 digit_value(char c) { + if (c >= '0' && c <= '9') { + return c - '0'; + } else if (c >= 'a' && c <= 'f') { + return c - 'a' + 10; + } else if (c >= 'A' && c <= 'F') { + return c - 'A' + 10; + } else { + return 0; + } +} + void pit_parser_from_lexer(pit_parser *ret, pit_lexer *lex) { ret->lexer = lex; ret->cur.token = ret->next.token = PIT_LEX_TOKEN_ERROR; @@ -76,7 +88,10 @@ pit_value pit_parse(pit_runtime *rt, pit_parser *st, bool *eof) { while (!match(st, PIT_LEX_TOKEN_RPAREN)) { pit_value *cell = pit_arena_alloc_bulk(rt->scratch, sizeof(pit_value)); *cell = pit_parse(rt, st, eof); - if (rt->error != PIT_NIL) return PIT_NIL; /* if we hit an error, stop!*/ + if (rt->error != PIT_NIL || (eof != NULL && *eof)) { + pit_error(rt, "unterminated list"); + return PIT_NIL; /* if we hit an error, stop!*/ + } } for (i64 i = rt->scratch->next - (i64) sizeof(pit_value); i >= scratch_reset; @@ -88,11 +103,45 @@ pit_value pit_parse(pit_runtime *rt, pit_parser *st, bool *eof) { rt->scratch->next = scratch_reset; return ret; } + case PIT_LEX_TOKEN_LSQUARE: { + i64 scratch_reset = rt->scratch->next; + i64 len = 0; + while (!match(st, PIT_LEX_TOKEN_RSQUARE)) { + pit_value *cell = pit_arena_alloc_bulk(rt->scratch, sizeof(pit_value)); + *cell = pit_parse(rt, st, eof); + len += 1; + if (rt->error != PIT_NIL || (eof != NULL && *eof)) { + pit_error(rt, "unterminated array literal"); + return PIT_NIL; + } + } + rt->scratch->next = scratch_reset; + return pit_array_from_buf(rt, pit_arena_idx(rt->scratch, (i32) scratch_reset), len); + } case PIT_LEX_TOKEN_QUOTE: return pit_list(rt, 2, pit_intern_cstr(rt, "quote"), pit_parse(rt, st, eof)); - case PIT_LEX_TOKEN_INTEGER_LITERAL: - get_token_string(st, buf, sizeof(buf)); - return pit_integer_new(rt, atoi(buf)); + case PIT_LEX_TOKEN_INTEGER_LITERAL: { + i64 idx = st->cur.start; + i64 base = 10; + i64 total = 0; + char c = st->lexer->input[idx++]; + if (c == '0' && idx + 1 < st->cur.end) { + switch (st->lexer->input[idx++]) { + case 'b': base = 2; break; + case 'o': base = 8; break; + case 'x': base = 16; break; + default: pit_error(rt, "unknown integer base"); return PIT_NIL; + } + } else { total = digit_value(c); } + while (idx < st->cur.end) { + total *= base; + total += digit_value(st->lexer->input[idx++]); + if (total > 0x1ffffffffffff) { + pit_error(rt, "integer literal too large"); return PIT_NIL; + } + } + return pit_integer_new(rt, total); + } case PIT_LEX_TOKEN_STRING_LITERAL: { get_token_string(st, buf, sizeof(buf)); i64 len = (i64) strlen(buf); diff --git a/src/runtime.c b/src/runtime.c index b7e722a..6ea9aa1 100644 --- a/src/runtime.c +++ b/src/runtime.c @@ -68,16 +68,18 @@ u64 pit_value_data(pit_value v) { pit_runtime *pit_runtime_new() { pit_runtime *ret = malloc(sizeof(*ret)); - ret->values = pit_arena_new(64 * 1024, sizeof(pit_value_heavy)); - ret->bytes = pit_arena_new(64 * 1024, sizeof(u8)); - ret->symtab = pit_arena_new(64 * 1024, sizeof(pit_symtab_entry)); + ret->values = pit_arena_new(1024 * 1024, sizeof(pit_value_heavy)); + ret->arrays = pit_arena_new(1024 * 1024, sizeof(pit_value)); + ret->bytes = pit_arena_new(1024 * 1024, sizeof(u8)); + ret->symtab = pit_arena_new(1024 * 1024, sizeof(pit_symtab_entry)); ret->symtab_len = 0; - ret->scratch = pit_arena_new(64 * 1024, sizeof(u8)); + ret->scratch = pit_arena_new(1024 * 1024, sizeof(u8)); ret->expr_stack = pit_values_new(1024); ret->result_stack = pit_values_new(1024); ret->program = pit_runtime_eval_program_new(64 * 1024); ret->saved_bindings = pit_values_new(1024); ret->frozen_values = 0; + ret->frozen_arrays = 0; ret->frozen_bytes = 0; ret->frozen_symtab = 0; ret->error = PIT_NIL; @@ -93,24 +95,29 @@ pit_runtime *pit_runtime_new() { void pit_runtime_freeze(pit_runtime *rt) { rt->frozen_values = pit_arena_next_idx(rt->values); + rt->frozen_arrays = pit_arena_next_idx(rt->arrays); rt->frozen_bytes = pit_arena_next_idx(rt->bytes); rt->frozen_symtab = pit_arena_next_idx(rt->symtab); } void pit_runtime_reset(pit_runtime *rt) { rt->values->next = rt->frozen_values; + rt->arrays->next = rt->frozen_arrays; rt->bytes->next = rt->frozen_bytes; rt->symtab->next = rt->frozen_symtab; } bool pit_runtime_print_error(pit_runtime *rt) { if (!pit_eq(rt->error, PIT_NIL)) { char buf[1024] = {0}; - pit_dump(rt, buf, sizeof(buf), rt->error, false); + i64 end = pit_dump(rt, buf, sizeof(buf) - 1, rt->error, false); + buf[end] = 0; fprintf(stderr, "error at line %ld, column %ld: %s\n", rt->error_line, rt->error_column, buf); return true; } return false; } +#define CHECK_BUF if (buf >= end) { return buf - start; } +#define CHECK_BUF_LABEL(label) if (buf >= end) { goto label; } i64 pit_dump(pit_runtime *rt, char *buf, i64 len, pit_value v, bool readable) { pit_value_heavy *h = NULL; if (len <= 0) return 0; @@ -136,46 +143,60 @@ i64 pit_dump(pit_runtime *rt, char *buf, i64 len, pit_value v, bool readable) { } case PIT_VALUE_SORT_REF: { pit_ref r = pit_as_ref(rt, v); + char *end = buf + len; + char *start = buf; h = pit_deref(rt, r); if (!h) snprintf(buf, (size_t) len, "", r); else { switch (h->hsort) { case PIT_VALUE_HEAVY_SORT_CELL: { - char *end = buf + len; - char *start = buf; - *(buf++) = '{'; - buf += pit_dump(rt, buf, end - buf, pit_car(rt, h->in.cell), readable); - *(buf++) = '}'; + CHECK_BUF; *(buf++) = '{'; + CHECK_BUF; buf += pit_dump(rt, buf, end - buf, pit_car(rt, h->in.cell), readable); + CHECK_BUF; *(buf++) = '}'; return buf - start; } case PIT_VALUE_HEAVY_SORT_CONS: { - char *end = buf + len; - char *start = buf; pit_value cur = v; + CHECK_BUF_LABEL(list_end); do { if (pit_is_cons(rt, cur)) { - *(buf++) = ' '; if (buf >= end) return end - buf; - buf += pit_dump(rt, buf, end - buf, pit_car(rt, cur), readable); - if (buf >= end) return end - buf; + CHECK_BUF_LABEL(list_end); *(buf++) = ' '; + CHECK_BUF_LABEL(list_end); buf += pit_dump(rt, buf, end - buf, pit_car(rt, cur), readable); } else { - buf += snprintf(buf, (size_t) (end - buf), " . "); - if (buf >= end) return end - buf; - buf += pit_dump(rt, buf, end - buf, cur, readable); - if (buf >= end) return end - buf; + CHECK_BUF_LABEL(list_end); buf += snprintf(buf, (size_t) (end - buf), " . "); + CHECK_BUF_LABEL(list_end); buf += pit_dump(rt, buf, end - buf, cur, readable); } } while (!pit_eq((cur = pit_cdr(rt, cur)), PIT_NIL)); + CHECK_BUF_LABEL(list_end); *(buf++) = ')'; + list_end: *start = '('; - *(buf++) = ')'; + return buf - start; + } + case PIT_VALUE_HEAVY_SORT_ARRAY: { + i64 i = 0; + CHECK_BUF_LABEL(array_end); + if (h->in.array.len == 0) { + CHECK_BUF_LABEL(array_end); *(buf++) = '['; + } else for (; i < h->in.array.len; ++i) { + CHECK_BUF_LABEL(array_end); *(buf++) = ' '; + CHECK_BUF_LABEL(array_end); buf += pit_dump(rt, buf, end - buf, h->in.array.data[i], readable); + } + CHECK_BUF_LABEL(array_end); *(buf++) = ']'; + array_end: + *start = '['; return buf - start; } case PIT_VALUE_HEAVY_SORT_BYTES: { i64 i = 0; - if (readable) buf[i++] = '"'; + if (readable) { CHECK_BUF; buf[i++] = '"'; } i64 maxlen = len - i; for (i64 j = 0; i < maxlen && j < h->in.bytes.len;) { - if (buf[i - 1] != '\\' && (h->in.bytes.data[j] == '\\' || h->in.bytes.data[j] == '"')) - buf[i++] = '\\'; - else buf[i++] = (char) h->in.bytes.data[j++]; + if (buf[i - 1] != '\\' && (h->in.bytes.data[j] == '\\' || h->in.bytes.data[j] == '"')) { + CHECK_BUF; buf[i++] = '\\'; + } + else { + CHECK_BUF; buf[i++] = (char) h->in.bytes.data[j++]; + } } if (readable && i < len - 1) buf[i++] = '"'; return i; @@ -192,7 +213,8 @@ i64 pit_dump(pit_runtime *rt, char *buf, i64 len, pit_value v, bool readable) { void pit_trace_(pit_runtime *rt, const char *format, pit_value v) { char buf[1024] = {0}; - pit_dump(rt, buf, sizeof(buf), v, true); + i64 end = pit_dump(rt, buf, sizeof(buf) - 1, v, true); + buf[end] = 0; fprintf(stderr, format, buf); } @@ -249,7 +271,11 @@ i64 pit_as_integer(pit_runtime *rt, pit_value v) { } pit_value pit_integer_new(pit_runtime *rt, i64 i) { - return pit_value_new(rt, PIT_VALUE_SORT_INTEGER, (u64) i); + return pit_value_new(rt, PIT_VALUE_SORT_INTEGER, 0x1ffffffffffff & (u64) i); +} +pit_value pit_bool_new(pit_runtime *rt, bool i) { + (void) rt; + return i ? PIT_T : PIT_NIL; } pit_symbol pit_as_symbol(pit_runtime *rt, pit_value v) { @@ -435,7 +461,7 @@ bool pit_bytes_match(pit_runtime *rt, pit_value v, u8 *buf, i64 len) { return true; } i64 pit_as_bytes(pit_runtime *rt, pit_value v, u8 *buf, i64 maxlen) { - if (pit_value_sort(v) != PIT_VALUE_SORT_REF) return -1; + if (pit_value_sort(v) != PIT_VALUE_SORT_REF) { pit_error(rt, "not a ref"); return -1; } pit_value_heavy *h = pit_deref(rt, pit_as_ref(rt, v)); if (!h) { pit_error(rt, "bad ref"); return -1; } if (h->hsort != PIT_VALUE_HEAVY_SORT_BYTES) { @@ -493,6 +519,11 @@ pit_value pit_intern(pit_runtime *rt, u8 *nm, i64 len) { pit_value pit_intern_cstr(pit_runtime *rt, char *nm) { return pit_intern(rt, (u8 *) nm, (i64) strlen(nm)); } +pit_value pit_symbol_name(pit_runtime *rt, pit_value sym) { + pit_symtab_entry *ent = pit_symtab_lookup(rt, sym); + if (!ent) { pit_error(rt, "bad symbol"); return PIT_NIL; } + return ent->name; +} bool pit_symbol_name_match(pit_runtime *rt, pit_value sym, u8 *buf, i64 len) { pit_symtab_entry *ent = pit_symtab_lookup(rt, sym); if (!ent) { pit_error(rt, "bad symbol"); return PIT_NIL; } @@ -516,7 +547,7 @@ pit_value pit_get_function_cell(pit_runtime *rt, pit_value sym) { return ent->function; } pit_value pit_get(pit_runtime *rt, pit_value sym) { - return pit_cell_get(rt, pit_get_value_cell(rt, sym)); + return pit_cell_get(rt, pit_get_value_cell(rt, sym), sym); } void pit_set(pit_runtime *rt, pit_value sym, pit_value v) { pit_symbol idx = pit_as_symbol(rt, sym); @@ -526,10 +557,11 @@ void pit_set(pit_runtime *rt, pit_value sym, pit_value v) { if (pit_value_sort(ent->value) != PIT_VALUE_SORT_REF) { ent->value = pit_cell_new(rt, PIT_NIL); } - pit_cell_set(rt, ent->value, v); + fprintf(stderr, "setting "); pit_trace(rt, sym); fprintf(stderr, " to "); pit_trace(rt, v); + pit_cell_set(rt, ent->value, v, sym); } pit_value pit_fget(pit_runtime *rt, pit_value sym) { - return pit_cell_get(rt, pit_get_function_cell(rt, sym)); + return pit_cell_get(rt, pit_get_function_cell(rt, sym), sym); } void pit_fset(pit_runtime *rt, pit_value sym, pit_value v) { pit_symbol idx = pit_as_symbol(rt, sym); @@ -539,7 +571,7 @@ void pit_fset(pit_runtime *rt, pit_value sym, pit_value v) { if (pit_value_sort(ent->function) != PIT_VALUE_SORT_REF) { ent->function = pit_cell_new(rt, PIT_NIL); } - pit_cell_set(rt, ent->function, v); + pit_cell_set(rt, ent->function, v, sym); } bool pit_is_symbol_macro(pit_runtime *rt, pit_value sym) { pit_symtab_entry *ent = pit_symtab_lookup(rt, sym); @@ -574,6 +606,7 @@ void pit_bind(pit_runtime *rt, pit_value sym, pit_value cell) { pit_symtab_entry *ent = pit_symtab_lookup(rt, sym); if (!ent) { pit_error(rt, "bad symbol"); return; } pit_values_push(rt, rt->saved_bindings, ent->value); + fprintf(stderr, "binding "); pit_trace(rt, sym); fprintf(stderr, " to "); pit_trace(rt, cell); ent->value = cell; } pit_value pit_unbind(pit_runtime *rt, pit_value sym) { @@ -592,9 +625,12 @@ pit_value pit_cell_new(pit_runtime *rt, pit_value v) { h->in.cell = v; return ret; } -pit_value pit_cell_get(pit_runtime *rt, pit_value cell) { +pit_value pit_cell_get(pit_runtime *rt, pit_value cell, pit_value sym) { if (pit_value_sort(cell) != PIT_VALUE_SORT_REF) { - pit_error(rt, "attempted to get cell value that is not ref"); + char buf[256]; + i64 end = pit_dump(rt, buf, sizeof(buf) - 1, sym, false); + buf[end] = 0; + pit_error(rt, "attempted to get unbound variable/function: %s", buf); return PIT_NIL; } pit_value_heavy *h = pit_deref(rt, pit_as_ref(rt, cell)); @@ -605,9 +641,12 @@ pit_value pit_cell_get(pit_runtime *rt, pit_value cell) { } return h->in.cell; } -void pit_cell_set(pit_runtime *rt, pit_value cell, pit_value v) { +void pit_cell_set(pit_runtime *rt, pit_value cell, pit_value v, pit_value sym) { if (pit_value_sort(cell) != PIT_VALUE_SORT_REF) { - pit_error(rt, "attempted to set cell value that is not ref"); + char buf[256]; + i64 end = pit_dump(rt, buf, sizeof(buf) - 1, sym, false); + buf[end] = 0; + pit_error(rt, "attempted to set unbound variable/function: %s", buf); return; } pit_ref idx = pit_as_ref(rt, cell); @@ -621,6 +660,58 @@ void pit_cell_set(pit_runtime *rt, pit_value cell, pit_value v) { h->in.cell = v; } +pit_value pit_array_new(pit_runtime *rt, i64 len) { + if (len < 0) { pit_error(rt, "failed to create array of negative size"); return PIT_NIL; } + int i = 0; + pit_value *dest = pit_arena_alloc_bulk(rt->arrays, len); + if (!dest) { pit_error(rt, "failed to allocate array"); return PIT_NIL; } + for (; i < len; ++i) dest[i] = PIT_NIL; + pit_value ret = pit_heavy_new(rt); + pit_value_heavy *h = pit_deref(rt, pit_as_ref(rt, ret)); + if (!h) { pit_error(rt, "failed to create new heavy value for array"); return PIT_NIL; } + h->hsort = PIT_VALUE_HEAVY_SORT_ARRAY; + h->in.array.data = dest; + h->in.array.len = len; + return ret; +} +pit_value pit_array_from_buf(pit_runtime *rt, pit_value *xs, i64 len) { + pit_value ret = pit_array_new(rt, len); + 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; } + memcpy(h->in.array.data, xs, (size_t) len * (size_t) sizeof(pit_value)); + return ret; +} +i64 pit_array_len(pit_runtime *rt, pit_value arr) { + if (pit_value_sort(arr) != PIT_VALUE_SORT_REF) { pit_error(rt, "not a ref"); return -1; } + pit_value_heavy *h = pit_deref(rt, pit_as_ref(rt, arr)); + if (!h) { pit_error(rt, "bad ref"); return -1; } + if (h->hsort != PIT_VALUE_HEAVY_SORT_ARRAY) { pit_error(rt, "not an array"); return -1; } + return h->in.array.len; +} +pit_value pit_array_get(pit_runtime *rt, pit_value arr, i64 idx) { + if (pit_value_sort(arr) != PIT_VALUE_SORT_REF) { pit_error(rt, "not a ref"); return PIT_NIL; } + pit_value_heavy *h = pit_deref(rt, pit_as_ref(rt, arr)); + if (!h) { pit_error(rt, "bad ref"); return PIT_NIL; } + if (h->hsort != PIT_VALUE_HEAVY_SORT_ARRAY) { pit_error(rt, "not an array"); return PIT_NIL; } + if (idx < 0 || idx >= h->in.array.len) { + pit_error(rt, "array index out of bounds: %d", idx); + return PIT_NIL; + } + return h->in.array.data[idx]; +} +pit_value pit_array_set(pit_runtime *rt, pit_value arr, i64 idx, pit_value v) { + if (pit_value_sort(arr) != PIT_VALUE_SORT_REF) { pit_error(rt, "not a ref"); return PIT_NIL; } + pit_value_heavy *h = pit_deref(rt, pit_as_ref(rt, arr)); + if (!h) { pit_error(rt, "bad ref"); return PIT_NIL; } + if (h->hsort != PIT_VALUE_HEAVY_SORT_ARRAY) { pit_error(rt, "not an array"); return PIT_NIL; } + if (idx < 0 || idx >= h->in.array.len) { + pit_error(rt, "array index out of bounds: %d", idx); + return PIT_NIL; + } + h->in.array.data[idx] = v; + return v; +} + pit_value pit_cons(pit_runtime *rt, pit_value car, pit_value cdr) { pit_value ret = pit_heavy_new(rt); pit_value_heavy *h = pit_deref(rt, pit_as_ref(rt, ret)); @@ -645,6 +736,14 @@ pit_value pit_list(pit_runtime *rt, i64 num, ...) { } return ret; } +i64 pit_list_len(pit_runtime *rt, pit_value xs) { + i64 ret = 0; + while (xs != PIT_NIL) { + ret += 1; + xs = pit_cdr(rt, xs); + } + return ret; +} pit_value pit_car(pit_runtime *rt, pit_value v) { if (pit_value_sort(v) != PIT_VALUE_SORT_REF) return PIT_NIL; pit_value_heavy *h = pit_deref(rt, pit_as_ref(rt, v)); @@ -696,7 +795,14 @@ pit_value pit_reverse(pit_runtime *rt, pit_value xs) { } pit_value pit_contains_eq(pit_runtime *rt, pit_value needle, pit_value haystack) { while (haystack != PIT_NIL) { - if (pit_eq(needle, pit_car(rt, haystack))) return pit_intern_cstr(rt, "t"); + if (pit_eq(needle, pit_car(rt, haystack))) return PIT_T; + haystack = pit_cdr(rt, haystack); + } + return PIT_NIL; +} +pit_value pit_contains_equal(pit_runtime *rt, pit_value needle, pit_value haystack) { + while (haystack != PIT_NIL) { + if (pit_equal(rt, needle, pit_car(rt, haystack))) return PIT_T; haystack = pit_cdr(rt, haystack); } return PIT_NIL; @@ -792,6 +898,12 @@ pit_value pit_nativefunc_new(pit_runtime *rt, pit_nativefunc f) { return ret; } pit_value pit_apply(pit_runtime *rt, pit_value f, pit_value args) { + if (pit_is_symbol(rt, f)) { + f = pit_fget(rt, f); + } + /* 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 */ switch (pit_value_sort(f)) { case PIT_VALUE_SORT_REF: { pit_value_heavy *h = pit_deref(rt, pit_as_ref(rt, f)); @@ -813,11 +925,11 @@ pit_value pit_apply(pit_runtime *rt, pit_value f, pit_value args) { pit_value nm = pit_car(rt, aform); pit_value cell = pit_cdr(rt, aform); if (h->in.func.arg_rest_nm != PIT_NIL && pit_eq(nm, h->in.func.arg_rest_nm)) { - pit_cell_set(rt, cell, args); + pit_cell_set(rt, cell, args, nm); pit_bind(rt, nm, cell); break; } else { - pit_cell_set(rt, cell, pit_car(rt, args)); + pit_cell_set(rt, cell, pit_car(rt, args), nm); pit_bind(rt, nm, cell); } bound = pit_cons(rt, nm, bound); diff --git a/struct.lisp b/struct.lisp new file mode 100644 index 0000000..9e35654 --- /dev/null +++ b/struct.lisp @@ -0,0 +1,11 @@ +(defstruct! foo + x + y + z) + +(setq! x (foo/new :y 10 :x 5 :z 111)) +(print! x) +(print! (foo/get-y x)) +(foo/set-y! x 42) +(print! (foo/get-y x)) +(print! (foo/get-z x)) diff --git a/test.lisp b/test.lisp new file mode 100644 index 0000000..ef13abb --- /dev/null +++ b/test.lisp @@ -0,0 +1,22 @@ +(print! (list/map (lambda (x) (+ x 1)) (list 1 2 3 4 5))) +(print! (eval! '(cons 1 2))) +(defun! say-hi () + (princ! "hello computer")) +(say-hi) +(setq! counter 42) +(let ((counter 0)) + (print! counter) + (fset! 'count (lambda () (setq! counter (+ counter 1)))) + (fset! 'query (lambda () counter))) +(print! (count)) (print! (query)) +(print! (count)) (print! (query)) +(defun! bar (x & xs) + (print! x) + (print! xs)) +(bar 1 2 3 4 5) +(defun! baz (& kwargs) + (print! kwargs) + (let ((foo (plist/get :foo kwargs)) + (bar (plist/get :bar kwargs))) + bar)) +(print! (baz :foo 10 :bar 5 :baz 3)) diff --git a/thebug.lisp b/thebug.lisp new file mode 100644 index 0000000..ad87bd7 --- /dev/null +++ b/thebug.lisp @@ -0,0 +1,9 @@ +(defun! foo (x) + (lambda (y) + (+ x y))) + +(setq! bar (foo 10)) +(setq! baz (foo 100)) + +(print! (funcall bar 4)) + diff --git a/x86.lisp b/x86.lisp new file mode 100644 index 0000000..7a9640f --- /dev/null +++ b/x86.lisp @@ -0,0 +1,330 @@ +(defun! x86/split16le (w) + "Split the 16-bit W16 into a little-endian list of 8-bit integers." + (list + (bitwise/and 0xff w) + (bitwise/and 0xff (bitwise/rshift w 8)))) + +(defun! x86/split32le (w) + "Split the 32-bit W32 into a little-endian list of 8-bit integers." + (list + (bitwise/and 0xff w) + (bitwise/and 0xff (bitwise/rshift w 8)) + (bitwise/and 0xff (bitwise/rshift w 16)) + (bitwise/and 0xff (bitwise/rshift w 24)))) + +(defun! x86/register-1byte? (r) + "Return the register index for 1-byte register R." + (case r + (al 0) (cl 1) (dl 2) (bl 3) + (ah 4) (ch 5) (dh 6) (bh 7) + (r8b 8) (r9b 9) (r10b 10) (r11b 11) + (r12b 12) (r13b 13) (r14b 14) (r15b 15))) + +(defun! x86/register-2byte? (r) + "Return the register index for 2-byte register R." + (case r + (ax 0) (cx 1) (dx 2) (bx 3) + (sp 4) (bp 5) (si 6) (di 7) + (r8w 8) (r9w 9) (r10w 10) (r11w 11) + (r12w 12) (r13w 13) (r14w 14) (r15w 15))) + +(defun! x86/register-4byte? (r) + "Return the register index for 4-byte register R." + (case r + (eax 0) (ecx 1) (edx 2) (ebx 3) + (esp 4) (ebp 5) (esi 6) (edi 7) + (r8d 8) (r9d 9) (r10d 10) (r11d 11) + (r12d 12) (r13d 13) (r14d 14) (r15d 15))) + +(defun! x86/register-8byte? (r) + "Return the register index for 8-byte register R." + (case r + (rax 0) (rcx 1) (rdx 2) (rbx 3) + (rsp 4) (rbp 5) (rsi 6) (rdi 7) + (r8 8) (r9 9) (r10 10) (r11 11) + (r12 12) (r13 13) (r14 14) (r15 15))) + +(defun! x86/register? (r) + "Return the register index of R." + (or + (x86/register-1byte? r) + (x86/register-2byte? r) + (x86/register-4byte? r) + (x86/register-8byte? r))) + +(defun! x86/register-extended? (r) + "Return non-nil if R is an extended register." + (list/contains? r + '( r8b r9b r10b r11b r12b r13b r14b r15b + r8w r9w r10w r11w r12w r13w r14w r15w + r8d r9d r10d r11d r12d r13d r14d r15d + r8 r9 r10 r11 r12 r13 r14 r15))) + +(defun! x86/integer-fits-in-bits? (bits x) + "Determine if X fits in BITS." + (if (integer? x) + (let ((bound (bitwise/lshift 1 bits))) + (or + (and (>= x 0) (< x bound)) + (and (< x 0) (<= (abs x) (/ bound 2))))))) +(defun! x86/operand-immediate-fits? (sz x) + "Determine if immediate operand X fits in SZ." + (let + ((bits + (or + (case sz + ("b" 8) ("c" 16) ("d" 32) ("i" 16) + ("j" 32) ("q" 64) ("v" 64) ("w" 16) + ("y" 64) ("z" 32)) + (error! "unknown operand pattern size")))) + (x86/integer-fits-in-bits? bits x))) + +(defun! x86/operand-register-fits? (sz r) + "Determine if register operand R fits in SZ." + (case sz + ("b" (x86/register-1byte? r)) + ("c" (or (x86/register-1byte? r) (x86/register-2byte? r))) + ("d" (x86/register-4byte? r)) + ("i" (x86/register-2byte? r)) + ("j" (x86/register-4byte? r)) + ("q" (x86/register-8byte? r)) + ("v" (or (x86/register-2byte? r) (x86/register-4byte? r) (x86/register-8byte? r))) + ("w" (x86/register-2byte? r)) + ("y" (or (x86/register-4byte? r) (x86/register-8byte? r))) + ("z" (or (x86/register-2byte? r) (x86/register-4byte? r))))) + +(defun! x86/memory-operand-base (m) + (and + (eq? (car m) 'mem) + (car (cdr m)))) +(defun! x86/memory-operand-off (m) + (and + (eq? (car m) 'mem) + (or (car (cdr (cdr m))) 0))) + +(defun! x86/operand-memory-location? (op) + "Return non-nil if OP represents a memory location." + (let ( (base (x86/memory-operand-base op)) + (off (x86/memory-operand-off op))) + (and + (or (x86/register-4byte? base) (x86/register-8byte? base)) + (integer? off)))) + +(defun! x86/operand-match? (pat op) + "Determine if operand OP matches PAT." + (cond + ((symbol? pat) (eq? pat op)) + ((cons? pat) (list/contains? op pat)) + ((bytes? pat) + (let ( (loc (bytes/range 0 1 pat)) + (sz (bytes/range 1 (bytes/len pat) pat))) + (cond + ((or (equal? loc "I") (equal? loc "J")) (x86/operand-immediate-fits? sz op)) + ((or (equal? loc "G") (equal? loc "R")) (x86/operand-register-fits? sz op)) + ((equal? loc "M") (x86/operand-memory-location? op)) + ((equal? loc "E") + (or (x86/operand-register-fits? sz op) (x86/operand-memory-location? op))) + (t (error! "unknown operand pattern location"))))))) + +(defun! x86/operand-size (op) + "Return the minimum power-of-2 size in bytes that contains OP." + (cond + ((symbol? op) + (cond + ((x86/register-1byte? op) 1) + ((x86/register-2byte? op) 2) + ((x86/register-4byte? op) 4) + ((x86/register-8byte? op) 8) + (t (error! "attempted to take size of unknown register")))) + ((integer? op) + (cond + ((x86/integer-fits-in-bits? 8 op) 1) + ((x86/integer-fits-in-bits? 16 op) 2) + ((x86/integer-fits-in-bits? 32 op) 4) + ((x86/integer-fits-in-bits? 64 op) 8) + (t (error! "attempted to take size of too-large immediate")))) + ((x86/operand-memory-location? op) 1) + (t (error! "attempted to take size of unknown operand")))) + +(defstruct! x86/ins + operand-size-prefix + address-size-prefix + rex-w + rex-r + rex-x + rex-b + opcode + modrm-mod + modrm-reg + modrm-rm + disp ;; pair of size and value + imm ;; pair of size and value + ) + +(defun! x86/ins-bytes (ins) + "Return a list of bytes encoding INS." + (let ( (opcode (x86/ins/get-opcode ins)) + (rex-w (x86/ins/get-rex-w ins)) + (rex-r (x86/ins/get-rex-r ins)) + (rex-x (x86/ins/get-rex-x ins)) + (rex-b (x86/ins/get-rex-b ins)) + (modrm-mod (x86/ins/get-modrm-mod ins)) + (modrm-reg (x86/ins/get-modrm-reg ins)) + (modrm-rm (x86/ins/get-modrm-rm ins)) + (disp (x86/ins/get-disp ins)) + (imm (x86/ins/get-imm ins))) + (list/append + (if (x86/ins/get-operand-size-prefix ins) '(0x66)) + (if (x86/ins/get-address-size-prefix ins) '(0x67)) + (if (or rex-w rex-r rex-x rex-b) + (list + (bitwise/or + 0x40 + (if rex-w 0b1000 0) + (if rex-r 0b0100 0) + (if rex-x 0b0010 0) + (if rex-b 0b0001 0)))) + (cond + ((not opcode) (error! "no opcode for instruction")) + ((cons? opcode) opcode) + ((integer? opcode) (list opcode)) + (t (error! "malformed opcode for instruction"))) + (if (or modrm-mod modrm-reg modrm-rm) + (list + (bitwise/or + (bitwise/lshift (or modrm-mod 0) 6) + (bitwise/lshift (or modrm-reg 0) 3) + (or modrm-rm 0)))) + (if disp + (cond + ((= (car disp) 1) (list (cdr disp))) + ((= (car disp) 4) (x86/split32le (cdr disp))) + (t (error! "malformed displacement for instruction")))) + (if imm + (cond + ((= (car imm) 1) (list (cdr imm))) + ((= (car imm) 2) (x86/split16le (cdr imm))) + ((= (car imm) 4) (x86/split32le (cdr imm))) + (t (error! "malformed immediate for instruction"))))))) + +(defun! x86/instruction-update-sizes (ins ops default-size) + "Update INS to account for the sizes of OPS. +DEFAULT-SIZE is the default operand size." + (let ((defsz (or default-size 4))) + (if (> (list/len ops) 0) + (let ((regs (list/uniq (list/map 'x86/operand-size (list/filter 'x86/register? ops))))) + (if (> (list/len regs) 1) + (error! "invalid mix of register sizes in operands")) + (let ((sz (if (eq? (list/len regs) 0) defsz (car regs)))) + (cond + ((eq? sz 1) nil) + ((eq? defsz sz) nil) + ((and (not (eq? defsz 2)) (eq? sz 2)) (x86/ins/set-operand-size-prefix! ins t)) + ((and (not (eq? defsz 8)) (eq? sz 8)) (x86/ins/set-rex-w! ins t)) + (t (error! "unable to encode operands with default size"))) + sz))))) + +(defun! x86/instruction-update-operand (esz ins pat op) + "Update INS to account for an operand OP according to PAT. +The effective operand size is ESZ." + (cond + ((bytes? pat) + (let ((loc (bytes/range 0 1 pat))) + (cond + ((equal? loc "I") + (let ((immsz (min esz 4))) + (if (not (x86/integer-fits-in-bits? (* 8 immsz) op)) + (error! "Immediate too large" op)) + (x86/ins/set-imm! ins (cons immsz op)))) + ((equal? loc "J") + (let ((immsz (if (= esz 1) 1 4))) + (if (not (x86/integer-fits-in-bits? (* 8 immsz) op)) + (error! "jump displacement too large")) + (x86/ins/set-disp! ins (cons immsz op)))) + ((equal? loc "G") + (x86/ins/set-modrm-reg! ins + (or (x86/register? op) (error "Invalid register: %s" op)))) + ((or (equal? loc "R") (and (equal? loc "E") (x86/register? op))) + (x86/ins/set-modrm-mod! ins 0b11) + (x86/ins/set-modrm-rm! ins + (or (x86/register? op) (error "Invalid register: %s" op)))) + ((or (equal? loc "M") (and (equal? loc "E") (x86/operand-memory-location? op))) + (let ( (base (x86/memory-location-base op)) + (off (x86/memory-location-off op))) + (cond + ((eq? base 'eip) + (x86/ins/set-modrm-rm! ins 0b101) + (x86/ins/set-modrm-mod! ins 0b00) + (x86/ins/set-disp! ins (cons 4 off)) + (x86/ins/set-address-size-prefix! ins t)) + ((eq? base 'rip) + (x86/ins/set-modrm-rm! ins 0b101) + (x86/ins/set-modrm-mod! ins 0b00) + (x86/ins/set-disp! ins (cons 4 off))) + (t + (x86/ins/set-modrm-rm! ins + (or + (x86/register-4byte? base) + (x86/register-8byte? base) + (error! "invalid base register"))) + (if (x86/register-4byte? base) + (x86/ins/set-address-size-prefix! ins t)) + (cond + ((x86/integer-fits-in-bits? 8 off) + (x86/ins/set-disp! ins (cons 1 off)) + (x86/ins/set-modrm-mod! ins 0b01)) + ((x86/integer-fits-in-bits? 32 off) + (x86/ins/set-disp! ins (cons 4 off)) + (x86/ins/set-modrm-mod! ins 0b10)) + (t (error! "invalid offset"))))))) + (t (error! "invalid operand location code"))))))) + +(defun! x86/default-instruction-handler (opcode & kwargs) + "Return an instruction handler for OPCODE. +The instruction handler will run POSTHOOK on the instruction at the end. +DEFAULT-SIZE is the default operand size." + (print! opcode) + (let ( (posthook (plist/get :posthook kwargs)) + (default-size (plist/get :default-size kwargs))) + (lambda (pats ops) + (print! opcode) + ;; (print! default-size) + ;; (print! posthook) + (let ((ret (x86/ins/new :opcode opcode))) + (let ((esz + (or (x86/instruction-update-sizes ret ops default-size) + (error! "malformed size for operands")))) + (list/zip-with + (lambda (it other) + (x86/instruction-update-operand esz ret it other)) + pats + ops)) + (if posthook + (funcall posthook ret ops)) + ret)))) + +(defun! x86/asm (op) + "Assemble OP to an instruction." + (let ((mnem (car op)) (operands (cdr op))) + (let ((variants (or (alist/get mnem x86/mnemonic-table) (error! "unknown mnemonic")))) + (let ((v + (list/find + (lambda (it) + (and (eq? (list/len (car it)) (list/len operands)) + (list/all? (lambda (x) x) (list/zip-with 'x86/operand-match? (car it) operands)))) + variants))) + (if (and v (function? (cdr v))) + (funcall (cdr v) (car v) operands) + (error! "could not identify instruction")))))) + +(setq! + x86/mnemonic-table + (list + (cons 'add + (list + (cons (list "Eb" "Gb") (x86/default-instruction-handler 0)) + (cons (list "Ev" "Gv") (x86/default-instruction-handler 1)))))) + +(setq! test-ins (x86/asm '(add al bl))) +(print! test-ins) +(print! (x86/ins-bytes test-ins)) diff --git a/y.lisp b/y.lisp new file mode 100644 index 0000000..5e9218b --- /dev/null +++ b/y.lisp @@ -0,0 +1,5 @@ +(setq! Y + (lambda (f) + (funcall + (lambda (x) (funcall f (funcall x x))) + (lambda (x) (funcall f (funcall x x)))))) -- cgit v1.2.3