diff options
| author | LLLL Colonq <llll@colonq> | 2026-07-09 23:51:55 -0400 |
|---|---|---|
| committer | LLLL Colonq <llll@colonq> | 2026-07-09 23:51:55 -0400 |
| commit | 2bdcaf319b1d74ffbaccf08a58336f804761beab (patch) | |
| tree | c21de6df74ec79b5574ad2b89fcc275d10847802 /pit | |
Refactor into monorepo
Diffstat (limited to 'pit')
66 files changed, 4452 insertions, 0 deletions
diff --git a/pit/.envrc b/pit/.envrc new file mode 100644 index 0000000..c4b17d7 --- /dev/null +++ b/pit/.envrc @@ -0,0 +1 @@ +use_flake diff --git a/pit/.gitignore b/pit/.gitignore new file mode 100644 index 0000000..7969bdc --- /dev/null +++ b/pit/.gitignore @@ -0,0 +1,6 @@ +/build_*/ +/.direnv/ +/pit +/*.a +/result +TAGS
\ No newline at end of file diff --git a/pit/Makefile b/pit/Makefile new file mode 100644 index 0000000..2802d2e --- /dev/null +++ b/pit/Makefile @@ -0,0 +1,85 @@ +EXE ?= pit + +CC ?= gcc +AR ?= ar +override CPPFLAGS += -MMD -MP +override CFLAGS += -fPIC --std=c99 -g -Ideps/ -Isrc/ -Iinclude/ -Wall -Wextra -Wpedantic -Wconversion -Wformat-security -Wshadow -Wpointer-arith -Wstrict-prototypes -Wmissing-prototypes -Wnull-dereference -Wfloat-equal -Wundef -Wpointer-arith -Wbad-function-cast -Wlogical-op -Wmissing-braces -Wcast-align -Wstrict-overflow=5 -fwrapv # -ftrapv +override LDFLAGS += -g -static + +BUILD = build_$(CC) + +SRCS_CORE := \ + src/utils.c src/arena.c src/lexer.c src/parser.c src/runtime.c \ + src/runtime/value.c \ + src/runtime/value/small.c src/runtime/value/cell.c src/runtime/value/cons.c src/runtime/value/array.c src/runtime/value/bytes.c src/runtime/value/func.c src/runtime/value/nativedata.c \ + src/runtime/symtab.c src/runtime/dump.c src/runtime/macroexpand.c src/runtime/eval.c src/runtime/gc.c \ + src/library.c +OBJECTS_CORE := $(SRCS_CORE:src/%.c=$(BUILD)/%.o) +LIB_CORE := libcolonq-pit.a +SRCS_NATIVE := src/native.c +OBJECTS_NATIVE := $(SRCS_NATIVE:src/%.c=$(BUILD)/%.o) +LIB_NATIVE := libcolonq-pit-native.a + +SRCS := src/main.c $(SRCS_CORE) $(SRCS_NATIVE) +CHK_SOURCES ?= $(SRCS) + +prefix ?= /usr/local +exec_prefix ?= $(prefix) +bindir ?= $(exec_prefix)/bin +includedir ?= $(prefix)/include +libdir ?= $(exec_prefix)/lib + +.PHONY: all clean install install-bin install-headers install-core install-native check-syntax + +all: $(EXE) $(LIB_CORE) $(LIB_NATIVE) + +$(EXE): $(BUILD)/main.o $(LIB_NATIVE) $(LIB_CORE) + $(CC) -o $@ $^ $(LDFLAGS) + +$(LIB_CORE): $(OBJECTS_CORE) + $(AR) rcs $@ $^ + +$(LIB_NATIVE): $(OBJECTS_NATIVE) + $(AR) rcs $@ $^ + +$(BUILD): + mkdir $(BUILD)/ + mkdir $(BUILD)/runtime/ + mkdir $(BUILD)/runtime/value/ + +$(BUILD)/%.o: src/%.c | $(BUILD) + $(CC) $(CPPFLAGS) $(CFLAGS) -o $@ -c $< + +clean: + -rm $(EXE) + -rm $(LIB_CORE) + -rm $(LIB_NATIVE) + -rm -r $(BUILD)/ + +TAGS: $(SRCS) + ctags --output-format=etags $^ + +install: install-bin install-headers install-core install-native + +install-bin: $(EXE) + mkdir -p $(DESTDIR)$(bindir) $(DESTDIR)$(libdir) $(DESTDIR)$(includedir) + install $(EXE) $(DESTDIR)$(bindir)/$(EXE) + +install-headers: + mkdir -p $(DESTDIR)$(bindir) $(DESTDIR)$(libdir) $(DESTDIR)$(includedir) + cp -r include/* $(DESTDIR)$(includedir) + +install-core: $(LIB_CORE) + mkdir -p $(DESTDIR)$(bindir) $(DESTDIR)$(libdir) $(DESTDIR)$(includedir) + install $(LIB_CORE) $(DESTDIR)$(libdir)/$(LIB_CORE) + +install-native: $(LIB_NATIVE) + mkdir -p $(DESTDIR)$(bindir) $(DESTDIR)$(libdir) $(DESTDIR)$(includedir) + install $(LIB_NATIVE) $(DESTDIR)$(libdir)/$(LIB_NATIVE) + +check-syntax: TAGS + gcc $(CFLAGS) -fsyntax-only $(CHK_SOURCES) + +-include $(BUILD)/main.d +-include $(OBJECTS_CORE:.o=.d) +-include $(OBJECTS_NATIVE:.o=.d) diff --git a/pit/README.org b/pit/README.org new file mode 100644 index 0000000..b9c2e9e --- /dev/null +++ b/pit/README.org @@ -0,0 +1,35 @@ +#+title: pit - a little lisp + +~pit~ is a small Lisp. I made it for fun, to understand Lisp better, and maybe also to use as a scripting language for games and other things. +There are no dependencies - just run ~make~! + +It's a [[https://en.wikipedia.org/wiki/Common_Lisp#The_function_namespace][Lisp-2]] like Emacs Lisp and Common Lisp - symbols have separate bindings for functions and for values. +Variables have lexical scope. + +#+begin_src lisp +(defun say-hi () + (princ "hello computer")) +(say-hi) +(setq counter 42) +(let ((counter 0)) + (fset 'count (lambda () (setq counter (+ counter 1)))) + (fset 'query (lambda () counter))) +(print (count)) (print (query)) +(print (count)) (print (query)) +#+end_src +* embedding +It is easy to use ~pit~ from C. +Take a look at [[./src/library.c]] for examples of defining new functions and macros from C. +Not many standard Lisp functions and macros are currently defined, mostly for no particular good reason. +When using this, I'd probably define just what I need and not much else. +* memory +The interpreter uses an unconventional strategy for memory management: +- When the interpreter is initialized, it is provided with several memory regions of fixed size. +- During evaluation, some of these regions are used as temporary stacks, and others are used as arenas to allocate values (most values are NaN-boxed, so only "heavy" values like cons cells and bytestrings need to be allocated). +- There is no garbage collection - these arenas only grow during normal execution. +- By calling ~pit_runtime_freeze~, an interpreter can be "frozen", recording the next-free-position pointer for each arena. +- Subsequently, any attempt to modify values or symbol bindings that occur before these recorded pointers causes an error. +- By later calling ~pit_runtime_reset~, the arena next-free-positions are reset to the recorded ones, effectively undoing all memory usage that has happened since the interpreter was frozen. + +This model matches the intended usage of the interpreter as a scripting language for games. The intended usage is that the game engine will initialize the interpreter with all routines necessary for scripting, and then freeze the runtime. Scripts can be evaluated, and then the interpreter can be reset back to its starting state. This allows many scripts to be run on the interpreter without running out of memory, prevents undesirable changes to global state, and does not require any unpredictable garbage collection pass. Memory limits can also be easily enforced - simply specify smaller arena/stack sizes when initializing the interpreter. +Who knows how well this works in practice! It seemed interesting though, and it was simple to implement. diff --git a/pit/emacs/pit.el b/pit/emacs/pit.el new file mode 100644 index 0000000..3665d93 --- /dev/null +++ b/pit/emacs/pit.el @@ -0,0 +1,106 @@ +;;; pit --- support for pit -*- lexical-binding: t; -*- +;;; Commentary: +;;; Code: + +(require 'dash) +(require 's) +(require 'cl-lib) +(require 'rx) +(require 'hydra) +(require 'comint) + +(defcustom pit/repl-buffer-name "*pit-repl*" + "Name of the pit REPL buffer." + :type '(string) + :group 'pit) + +(defcustom pit/interpreter-path "~/src/libcolonq/pit/pit" + "Path to the pit interpreter." + :type '(string) + :group 'pit) + +(define-derived-mode pit/mode lisp-mode "pit" + "Major mode for pit source code." + ) +(add-to-list 'auto-mode-alist `(,(rx ".pit" eos) . pit/mode)) + +(defun pit/repl-buffer () + "Ensure the REPL is running and return its buffer." + (make-comint-in-buffer "pit" pit/repl-buffer-name pit/interpreter-path nil) + (get-buffer pit/repl-buffer-name)) + +(defun pit/repl-process () + "Return the Comint process for the REPL." + (get-buffer-process (pit/repl-buffer))) + +(defun pit/send-string (s) + "Send string S to the REPL." + (comint-send-string (pit/repl-process) (s-concat s "\n"))) + +(defun pit/eval-region (start end) + "Send the region from START to END to the REPL." + (interactive "r") + (comint-send-region (pit/repl-process) start end) + (comint-send-string (pit/repl-process) "\n")) + +(defun pit/eval-defun () + "Send the defun under point to the REPL." + (interactive) + (save-excursion + (end-of-defun) + (beginning-of-defun) + (let ((start (point))) + (forward-sexp) + (pit/eval-region start (point))))) + +(defun pit/eval-buffer () + "Send the current buffer to the REPL." + (interactive) + (pit/send-string (format "(progn %s 'done)" (buffer-string)))) + +(defun pit/restart () + "Restart the pit REPL." + (interactive) + (kill-buffer pit/repl-buffer-name) + (pit/repl)) + +(defun pit/repl () + "Launch the pit REPL." + (interactive) + (switch-to-buffer (pit/repl-buffer))) + +;;;; configuration +(defhydra pit/ide (:color teal :hint nil) + "Dispatcher > pit IDE." + ("<f12>" keyboard-escape-quit) + ("S" pit/restart "start") + ("e" pit/eval-defun "eval") + ("i" pit/eval-buffer "buffer") + ("r" pit/repl "repl")) +(defun pit/setup () + "Configuration for `pit/mode'." + (setq-local c/contextual-ide 'pit/ide/body)) +(add-hook 'pit/mode-hook #'pit/setup) + +;;;; nrepl client +;; (require 'nrepl-client) +;; (defun pit/repl/connect (&optional host port) +;; "Connect to pit nREPL server at HOST:PORT." +;; (let ((ret (get-buffer-create (generate-new-buffer-name " *pit-nrepl*") t))) +;; (nrepl-start-client-process (or host "localhost") (or port 7888) nil (lambda (_pl) ret)) +;; ret)) + +(require 'cider) +(defun pit/repl/connect (&optional host port) + "Connect to pit nREPL server at HOST:PORT." + (let ( (dir (if-let* ((p (project-current))) (project-root p) default-directory)) + (cider-repl-init-code nil)) + (cider-nrepl-connect + (print + (thread-first `(:host ,host :port ,port :project-dir ,dir :repl-init-function nil :session-name nil :repl-type pit) + (cider--update-project-dir) + (cider--update-host-port) + (cider--check-existing-session)))))) + +(provide 'pit) +;;; pit.el ends here diff --git a/pit/include/lcq/pit.h b/pit/include/lcq/pit.h new file mode 100644 index 0000000..8ff46c8 --- /dev/null +++ b/pit/include/lcq/pit.h @@ -0,0 +1,11 @@ +#ifndef LCOLONQ_PIT_H +#define LCOLONQ_PIT_H + +#include <lcq/prelude.h> +#include <lcq/pit/utils.h> +#include <lcq/pit/lexer.h> +#include <lcq/pit/parser.h> +#include <lcq/pit/runtime.h> +#include <lcq/pit/library.h> + +#endif diff --git a/pit/include/lcq/pit/arena.h b/pit/include/lcq/pit/arena.h new file mode 100644 index 0000000..18d7f96 --- /dev/null +++ b/pit/include/lcq/pit/arena.h @@ -0,0 +1,45 @@ +#ifndef LCOLONQ_PIT_ARENA_H +#define LCOLONQ_PIT_ARENA_H + +#include <lcq/prelude.h> + +typedef i64 pit_arena_index; + +static inline uintptr_t pit_align_down(uintptr_t addr, uintptr_t align) { + return addr & ~(align - 1); /* easy! just zero the low bits */ +} +static inline uintptr_t pit_align_up(uintptr_t addr, uintptr_t align) { + return (addr + align - 1) /* increment past the next aligned address... */ + & ~(align - 1); /* ...and then zero the low bits */ +} +typedef struct { + i64 elem_size, /* size of one element */ + capacity, /* capacity in of data in bytes - only used to reset */ + next, /* index (in elements) of next element to insert */ + back; /* index (in bytes) one past the end of data. */ + /* back starts at capacity, and decreases as you alloc_back */ + u8 data[]; +} pit_arena; + +/* create a new arena in a buffer of buf_len size in bytes that stores elements of elem_size */ +pit_arena *pit_arena_new(u8 *buf, i64 buf_len, i64 elem_size); + +/* remove all elements from an array */ +void pit_arena_reset(pit_arena *a); + +/* allocate space for one or multiple elements, and return the index of the first element */ +pit_arena_index pit_arena_alloc_index(pit_arena *a); +pit_arena_index pit_arena_alloc_array_index(pit_arena *a, i64 num); + +/* allocate space for one or multiple elements, and return a pointer */ +void *pit_arena_alloc(pit_arena *a); +void *pit_arena_alloc_array(pit_arena *a, i64 num); + +/* retrieve a pointer to the element(s) at a given index */ +void *pit_arena_get(pit_arena *a, pit_arena_index idx); + +/* allocate arbitrary bytes on the "back" of the arena. + this can be an arbitrary size in bytes */ +void *pit_arena_alloc_back(pit_arena *a, i64 sz); + +#endif diff --git a/pit/include/lcq/pit/lexer.h b/pit/include/lcq/pit/lexer.h new file mode 100644 index 0000000..d10d9c2 --- /dev/null +++ b/pit/include/lcq/pit/lexer.h @@ -0,0 +1,36 @@ +#ifndef LCOLONQ_PIT_LEXER_H +#define LCOLONQ_PIT_LEXER_H + +#include <lcq/prelude.h> + +typedef enum { + PIT_LEX_TOKEN_ERROR=-1, + 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, + PIT_LEX_TOKEN_STRING_LITERAL, + PIT_LEX_TOKEN_SYMBOL, + PIT_LEX_TOKEN__SENTINEL +} pit_lex_token; + +typedef struct { + char *input; + i64 len; /* length of input */ + i64 start, end; /* bounds of the current token */ + i64 line, column; /* for error reporting only; current line and column */ + i64 start_line, start_column; /* for error reporting only; line and column of token start */ + char *error; +} pit_lexer; + +void pit_lex_cstr(pit_lexer *ret, char *buf); +void pit_lex_bytes(pit_lexer *ret, char *buf, i64 len); +i64 pit_lex_file(pit_lexer *ret, char *path); +pit_lex_token pit_lex_next(pit_lexer *st); +const char *pit_lex_token_name(pit_lex_token t); + +#endif diff --git a/pit/include/lcq/pit/library.h b/pit/include/lcq/pit/library.h new file mode 100644 index 0000000..dc57655 --- /dev/null +++ b/pit/include/lcq/pit/library.h @@ -0,0 +1,12 @@ +#ifndef LCOLONQ_PIT_LIBRARY_H +#define LCOLONQ_PIT_LIBRARY_H + +#include <lcq/pit/runtime.h> + +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/pit/include/lcq/pit/parser.h b/pit/include/lcq/pit/parser.h new file mode 100644 index 0000000..c2f1597 --- /dev/null +++ b/pit/include/lcq/pit/parser.h @@ -0,0 +1,21 @@ +#ifndef LCOLONQ_PIT_PARSER_H +#define LCOLONQ_PIT_PARSER_H + +#include <lcq/pit/lexer.h> +#include <lcq/pit/runtime.h> + +typedef struct { + pit_lex_token token; + i64 start, end; + i64 line, column; /* for error reporting */ +} pit_parser_token_info; + +typedef struct { + pit_lexer *lexer; + pit_parser_token_info cur, next; +} pit_parser; + +void pit_parser_from_lexer(pit_parser *ret, pit_lexer *lex); +pit_value pit_parse(pit_runtime *rt, pit_parser *st, bool *eof); + +#endif diff --git a/pit/include/lcq/pit/runtime.h b/pit/include/lcq/pit/runtime.h new file mode 100644 index 0000000..d9311b2 --- /dev/null +++ b/pit/include/lcq/pit/runtime.h @@ -0,0 +1,96 @@ +#ifndef LCOLONQ_PIT_RUNTIME_H +#define LCOLONQ_PIT_RUNTIME_H + +#include <lcq/prelude.h> +#include <lcq/pit/utils.h> +#include <lcq/pit/vec.h> +#include <lcq/pit/arena.h> +#include <lcq/pit/lexer.h> + +typedef u64 pit_value; +typedef i64 pit_symbol; /* a symbol at runtime is an index into the runtime's symbol table */ +typedef i64 pit_ref; /* a reference is an index into the runtime's arena */ +PIT_DECLARE_VEC(pit_value) + +struct pit_runtime; + +/* symbol table entries. these are created/looked up when you intern a symbol */ +typedef struct { + pit_value name; /* ref to bytestring */ + pit_value value; /* ref to cell */ + pit_value function; /* ref to cell */ + bool is_macro, is_special_form, is_keyword; +} pit_symtab_entry; +PIT_DECLARE_VEC(pit_symtab_entry) + +/* annotation attached to (some) heavy values detailing things like line numbers */ +typedef struct { + i64 line, column; +} pit_annotation; +typedef struct { + pit_ref ref; + pit_annotation annotation; +} pit_annotated_ref; +PIT_DECLARE_VEC(pit_annotated_ref) +void pit_annotation_set(struct pit_runtime *rt, pit_ref ref, pit_annotation annotation); +pit_annotated_ref *pit_annotation_get(struct pit_runtime *rt, pit_ref ref); + +/* "programs"; vectors of "instructions" for a very simple VM used by the evaluator */ +typedef struct { + enum { + PIT_RUNTIME_EVAL_INS_LITERAL, + PIT_RUNTIME_EVAL_INS_APPLY + } sort; + union { + pit_value literal; + struct { i64 arity; pit_annotated_ref *annotation; } apply; + } in; +} pit_runtime_eval_ins; +PIT_DECLARE_VEC(pit_runtime_eval_ins) +void pit_runtime_eval_program_push_literal(struct pit_runtime *rt, pit_vec(pit_runtime_eval_ins) *s, pit_value x); +void pit_runtime_eval_program_push_apply(struct pit_runtime *rt, pit_vec(pit_runtime_eval_ins) *s, i64 arity, pit_annotated_ref *annotation); + +typedef struct pit_runtime { + /* interpreter state */ + pit_arena *heap; /* all heavy values, bytestrings, and arrays. */ + /* bytestrings and arrays are allocated at the end (descending), heavy values are allocated at the front */ + /* this allows us to iterate over only heavy values at the front (useful in Cheney's algorithm for GC */ + pit_arena *backbuffer; /* additional allocation, the same size as the heap (used by GC) */ + pit_vec(pit_annotated_ref) *annotations; + pit_vec(pit_annotated_ref) *backtrace; /* we reuse this vector for both backtraces and the GC */ + pit_vec(pit_symtab_entry) *symtab;/* all symbols */ + /* temporary/"scratch" memory */ + pit_vec(pit_value) *saved_bindings; /* stack used to save old values of bindings to be restored ("shallow binding") */ + pit_vec(pit_value) *expr_stack; /* stack of subexpressions to evaluate during evaluation */ + pit_vec(pit_value) *result_stack; /* stack of intermediate values during evaluation */ + pit_vec(pit_runtime_eval_ins) *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_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 */ +} pit_runtime; +pit_runtime *pit_runtime_new(u8 *buf, i64 len); + +void pit_runtime_freeze(pit_runtime *rt); /* freeze the runtime at the current point - everything currently defined becomes immutable */ +void pit_runtime_reset(pit_runtime *rt); /* restore the runtime to the frozen point, resetting everything that has happened since */ +bool pit_runtime_print_error(pit_runtime *rt); /* return true if an error has occured, and print to stderr */ + +#define pit_debug_trace(rt, v) pit_debug_trace_(rt, "Trace [" __FILE__ ":" PIT_STR(__LINE__) "] %s\n", v) +void pit_debug_trace_(pit_runtime *rt, char *format, pit_value v); +pit_value pit_error_get(pit_runtime *rt); +void pit_error(pit_runtime *rt, char *format, ...); + +/* repl / file loading */ +pit_value pit_load_file(pit_runtime *rt, char *path); +void pit_repl(pit_runtime *rt); + +#include <lcq/pit/runtime/value.h> +#include <lcq/pit/runtime/symtab.h> +#include <lcq/pit/runtime/dump.h> +#include <lcq/pit/runtime/macroexpand.h> +#include <lcq/pit/runtime/eval.h> +#include <lcq/pit/runtime/gc.h> + +#endif diff --git a/pit/include/lcq/pit/runtime/dump.h b/pit/include/lcq/pit/runtime/dump.h new file mode 100644 index 0000000..581cba0 --- /dev/null +++ b/pit/include/lcq/pit/runtime/dump.h @@ -0,0 +1,10 @@ +#ifndef LCOLONQ_PIT_RUNTIME_DUMP_H +#define LCOLONQ_PIT_RUNTIME_DUMP_H + +#include <lcq/pit/runtime.h> + +/* pretty-print a pit value + if readable is true, try to produce output that can be machine-read (quotes on strings, etc) */ +i64 pit_dump(pit_runtime *rt, char *buf, i64 len, pit_value v, bool readable); + +#endif diff --git a/pit/include/lcq/pit/runtime/eval.h b/pit/include/lcq/pit/runtime/eval.h new file mode 100644 index 0000000..3dc9e3c --- /dev/null +++ b/pit/include/lcq/pit/runtime/eval.h @@ -0,0 +1,8 @@ +#ifndef LCOLONQ_PIT_RUNTIME_EVAL_H +#define LCOLONQ_PIT_RUNTIME_EVAL_H + +#include <lcq/pit/runtime.h> + +pit_value pit_eval(pit_runtime *rt, pit_value e); + +#endif diff --git a/pit/include/lcq/pit/runtime/gc.h b/pit/include/lcq/pit/runtime/gc.h new file mode 100644 index 0000000..49921f0 --- /dev/null +++ b/pit/include/lcq/pit/runtime/gc.h @@ -0,0 +1,8 @@ +#ifndef LCOLONQ_PIT_RUNTIME_GC_H +#define LCOLONQ_PIT_RUNTIME_GC_H + +#include <lcq/pit/runtime.h> + +void pit_gc(pit_runtime *rt); + +#endif diff --git a/pit/include/lcq/pit/runtime/macroexpand.h b/pit/include/lcq/pit/runtime/macroexpand.h new file mode 100644 index 0000000..bc1f756 --- /dev/null +++ b/pit/include/lcq/pit/runtime/macroexpand.h @@ -0,0 +1,8 @@ +#ifndef LCOLONQ_PIT_RUNTIME_MACROEXPAND_H +#define LCOLONQ_PIT_RUNTIME_MACROEXPAND_H + +#include <lcq/pit/runtime.h> + +pit_value pit_macroexpand(pit_runtime *rt, pit_value top); + +#endif diff --git a/pit/include/lcq/pit/runtime/symtab.h b/pit/include/lcq/pit/runtime/symtab.h new file mode 100644 index 0000000..ac60523 --- /dev/null +++ b/pit/include/lcq/pit/runtime/symtab.h @@ -0,0 +1,27 @@ +#ifndef LCOLONQ_PIT_RUNTIME_SYMTAB_H +#define LCOLONQ_PIT_RUNTIME_SYMTAB_H + +#include <lcq/pit/runtime.h> + +pit_symtab_entry *pit_symtab_lookup(pit_runtime *rt, pit_value sym); +pit_value pit_symtab_intern(pit_runtime *rt, u8 *nm, i64 len); +pit_value pit_symtab_intern_cstr(pit_runtime *rt, char *nm); +pit_value pit_symtab_symbol_name(pit_runtime *rt, pit_value sym); +bool pit_symtab_symbol_name_match(pit_runtime *rt, pit_value sym, u8 *buf, i64 len); +bool pit_symtab_symbol_name_match_cstr(pit_runtime *rt, pit_value sym, char *s); +pit_value pit_symtab_get_value_cell(pit_runtime *rt, pit_value sym); +pit_value pit_symtab_get_function_cell(pit_runtime *rt, pit_value sym); +pit_value pit_symtab_get(pit_runtime *rt, pit_value sym); +void pit_symtab_set(pit_runtime *rt, pit_value sym, pit_value v); +pit_value pit_symtab_fget(pit_runtime *rt, pit_value sym); +void pit_symtab_fset(pit_runtime *rt, pit_value sym, pit_value v); +bool pit_symtab_is_symbol_macro(pit_runtime *rt, pit_value sym); +void pit_symtab_symbol_mark_macro(pit_runtime *rt, pit_value sym); +void pit_symtab_mset(pit_runtime *rt, pit_value sym, pit_value v); +bool pit_symtab_is_symbol_special_form(pit_runtime *rt, pit_value sym); +void pit_symtab_symbol_mark_special_form(pit_runtime *rt, pit_value sym); +void pit_symtab_sfset(pit_runtime *rt, pit_value sym, pit_value v); +void pit_symtab_bind(pit_runtime *rt, pit_value sym, pit_value v); +pit_value pit_symtab_unbind(pit_runtime *rt, pit_value sym); + +#endif diff --git a/pit/include/lcq/pit/runtime/value.h b/pit/include/lcq/pit/runtime/value.h new file mode 100644 index 0000000..5820bbd --- /dev/null +++ b/pit/include/lcq/pit/runtime/value.h @@ -0,0 +1,59 @@ +#ifndef LCOLONQ_PIT_RUNTIME_VALUE_H +#define LCOLONQ_PIT_RUNTIME_VALUE_H + +#include <lcq/prelude.h> +#include <lcq/pit/runtime.h> + +/* the basic value type - it's just a u64 */ +enum pit_value_sort { + PIT_VALUE_SORT_DOUBLE = 0, /* 0b00 - double */ + PIT_VALUE_SORT_INTEGER = 1, /* 0b01 - NaN-boxed 49-bit integer */ + PIT_VALUE_SORT_SYMBOL = 2, /* 0b10 - NaN-boxed index into symbol table */ + PIT_VALUE_SORT_REF = 3 /* 0b11 - NaN-boxed index into "heavy object" arena */ +}; +enum pit_value_sort pit_value_sort(pit_value v); +u64 pit_value_data(pit_value v); + +/* nil is always the symbol with index 0 */ +#define PIT_NIL 0xfff4000000000000 /* 0b1111111111110100000000000000000000000000000000000000000000000000 */ +#define PIT_T (PIT_NIL+1) + +/* "heavy" values, the targets of refs */ +typedef pit_value (*pit_nativefunc)(struct pit_runtime *rt, pit_value args, void *data); +typedef struct { + enum pit_value_heavy_sort { + PIT_VALUE_HEAVY_SORT_CELL=0, /* value cell - basically, a "location" referred to by a variable binding */ + PIT_VALUE_HEAVY_SORT_CONS, /* cons cell - a pair of two values */ + PIT_VALUE_HEAVY_SORT_ARRAY, /* fixed-size array of values */ + PIT_VALUE_HEAVY_SORT_BYTES, /* bytestring */ + PIT_VALUE_HEAVY_SORT_FUNC, /* Lisp closure */ + PIT_VALUE_HEAVY_SORT_NATIVEFUNC, /* native function */ + PIT_VALUE_HEAVY_SORT_NATIVEDATA, /* native data (C pointer) */ + PIT_VALUE_HEAVY_SORT_FORWARDING_POINTER /* forwarding pointer to to-space (during GC) */ + } hsort; + union { + pit_value cell; + struct { pit_value car, cdr; } cons; + struct { pit_value *data; i64 len; } array; + struct { u8 *data; i64 len; } bytes; + struct { pit_value env; pit_value args; pit_value arg_rest_nm; pit_value body; } func; + struct { pit_nativefunc f; void *data; } nativefunc; + struct { pit_value tag; void *data; } nativedata; + i64 forwarding_pointer; + } in; +} pit_value_heavy; + +pit_value pit_value_new(struct pit_runtime *rt, enum pit_value_sort s, u64 data); + +bool pit_value_eq(pit_value a, pit_value b); +bool pit_value_equal(pit_runtime *rt, pit_value a, pit_value b); + +#include <lcq/pit/runtime/value/small.h> +#include <lcq/pit/runtime/value/cell.h> +#include <lcq/pit/runtime/value/cons.h> +#include <lcq/pit/runtime/value/bytes.h> +#include <lcq/pit/runtime/value/array.h> +#include <lcq/pit/runtime/value/func.h> +#include <lcq/pit/runtime/value/nativedata.h> + +#endif diff --git a/pit/include/lcq/pit/runtime/value/array.h b/pit/include/lcq/pit/runtime/value/array.h new file mode 100644 index 0000000..0e5dd64 --- /dev/null +++ b/pit/include/lcq/pit/runtime/value/array.h @@ -0,0 +1,15 @@ +#ifndef LCOLONQ_PIT_RUNTIME_VALUE_ARRAY_H +#define LCOLONQ_PIT_RUNTIME_VALUE_ARRAY_H + +#include <lcq/pit/runtime.h> +#include <lcq/pit/runtime/value.h> + +/* heavy value - array */ +bool pit_value_is_array(pit_runtime *rt, pit_value a); +pit_value pit_value_array_new(pit_runtime *rt, i64 len); +pit_value pit_value_array_from_buf(pit_runtime *rt, pit_value *xs, i64 len); +i64 pit_value_array_len(pit_runtime *rt, pit_value arr); +pit_value pit_value_array_get(pit_runtime *rt, pit_value arr, i64 idx); +pit_value pit_value_array_set(pit_runtime *rt, pit_value arr, i64 idx, pit_value v); + +#endif diff --git a/pit/include/lcq/pit/runtime/value/bytes.h b/pit/include/lcq/pit/runtime/value/bytes.h new file mode 100644 index 0000000..cef5bed --- /dev/null +++ b/pit/include/lcq/pit/runtime/value/bytes.h @@ -0,0 +1,16 @@ +#ifndef LCOLONQ_PIT_RUNTIME_VALUE_BYTES_H +#define LCOLONQ_PIT_RUNTIME_VALUE_BYTES_H + +#include <lcq/pit/runtime.h> +#include <lcq/pit/runtime/value.h> + +/* heavy value - bytes */ + +bool pit_value_is_bytes(pit_runtime *rt, pit_value a); +pit_value pit_value_bytes_new(pit_runtime *rt, u8 *buf, i64 len); +pit_value pit_value_bytes_new_cstr(pit_runtime *rt, char *s); +pit_value pit_value_bytes_new_file(pit_runtime *rt, char *path); +bool pit_value_bytes_match(pit_runtime *rt, pit_value v, u8 *buf, i64 len); +i64 pit_value_bytes_copy(pit_runtime *rt, pit_value v, u8 *buf, i64 maxlen); + +#endif diff --git a/pit/include/lcq/pit/runtime/value/cell.h b/pit/include/lcq/pit/runtime/value/cell.h new file mode 100644 index 0000000..01c503e --- /dev/null +++ b/pit/include/lcq/pit/runtime/value/cell.h @@ -0,0 +1,14 @@ +#ifndef LCOLONQ_PIT_RUNTIME_VALUE_CELL_H +#define LCOLONQ_PIT_RUNTIME_VALUE_CELL_H + +#include <lcq/pit/runtime.h> +#include <lcq/pit/runtime/value.h> + +/* heavy value - cell */ + +bool pit_value_is_cell(pit_runtime *rt, pit_value a); +pit_value pit_value_cell_new(pit_runtime *rt, pit_value v); +pit_value pit_value_cell_get(pit_runtime *rt, pit_value cell, pit_value sym); +void pit_value_cell_set(pit_runtime *rt, pit_value cell, pit_value v, pit_value sym); + +#endif diff --git a/pit/include/lcq/pit/runtime/value/cons.h b/pit/include/lcq/pit/runtime/value/cons.h new file mode 100644 index 0000000..e7f030a --- /dev/null +++ b/pit/include/lcq/pit/runtime/value/cons.h @@ -0,0 +1,23 @@ +#ifndef LCOLONQ_PIT_RUNTIME_VALUE_CONS_H +#define LCOLONQ_PIT_RUNTIME_VALUE_CONS_H + +#include <lcq/pit/runtime.h> +#include <lcq/pit/runtime/value.h> + +/* heavy value - cons/list */ +bool pit_value_is_cons(pit_runtime *rt, pit_value a); +pit_value pit_value_cons(pit_runtime *rt, pit_value car, pit_value cdr); +pit_value pit_value_cons_car(pit_runtime *rt, pit_value v); +pit_value pit_value_cons_cdr(pit_runtime *rt, pit_value v); +void pit_value_cons_setcar(pit_runtime *rt, pit_value v, pit_value x); +void pit_value_cons_setcdr(pit_runtime *rt, pit_value v, pit_value x); + +pit_value pit_value_list(pit_runtime *rt, i64 num, ...); +i64 pit_value_list_len(pit_runtime *rt, pit_value xs); +pit_value pit_value_list_append(pit_runtime *rt, pit_value xs, pit_value ys); +pit_value pit_value_list_reverse(pit_runtime *rt, pit_value xs); +pit_value pit_value_list_contains_eq(pit_runtime *rt, pit_value needle, pit_value haystack); +pit_value pit_value_list_contains_equal(pit_runtime *rt, pit_value needle, pit_value haystack); +pit_value pit_value_list_plist_get(pit_runtime *rt, pit_value k, pit_value vs); + +#endif diff --git a/pit/include/lcq/pit/runtime/value/func.h b/pit/include/lcq/pit/runtime/value/func.h new file mode 100644 index 0000000..852c90d --- /dev/null +++ b/pit/include/lcq/pit/runtime/value/func.h @@ -0,0 +1,15 @@ +#ifndef LCOLONQ_PIT_RUNTIME_VALUE_FUNC_H +#define LCOLONQ_PIT_RUNTIME_VALUE_FUNC_H + +#include <lcq/pit/runtime.h> +#include <lcq/pit/runtime/value.h> + +/* heavy value - func / nativefunc */ +bool pit_value_is_func(pit_runtime *rt, pit_value a); +bool pit_value_is_nativefunc(pit_runtime *rt, pit_value a); +pit_value pit_value_func_lambda(pit_runtime *rt, pit_value args, pit_value body); +pit_value pit_value_nativefunc_new_with_data(pit_runtime *rt, pit_nativefunc f, void *data); +pit_value pit_value_nativefunc_new(pit_runtime *rt, pit_nativefunc f); +pit_value pit_value_apply(pit_runtime *rt, pit_value f, pit_value args); + +#endif diff --git a/pit/include/lcq/pit/runtime/value/nativedata.h b/pit/include/lcq/pit/runtime/value/nativedata.h new file mode 100644 index 0000000..f8ffa4e --- /dev/null +++ b/pit/include/lcq/pit/runtime/value/nativedata.h @@ -0,0 +1,12 @@ +#ifndef LCOLONQ_PIT_RUNTIME_VALUE_NATIVEDATA_H +#define LCOLONQ_PIT_RUNTIME_VALUE_NATIVEDATA_H + +#include <lcq/pit/runtime.h> +#include <lcq/pit/runtime/value.h> + +/* heavy value - nativedata */ +bool pit_value_is_nativedata(pit_runtime *rt, pit_value a); +pit_value pit_value_nativedata_new(pit_runtime *rt, pit_value tag, void *d); +void *pit_value_nativedata_get(pit_runtime *rt, pit_value tag, pit_value v); + +#endif diff --git a/pit/include/lcq/pit/runtime/value/small.h b/pit/include/lcq/pit/runtime/value/small.h new file mode 100644 index 0000000..957a670 --- /dev/null +++ b/pit/include/lcq/pit/runtime/value/small.h @@ -0,0 +1,31 @@ +#ifndef LCOLONQ_PIT_RUNTIME_VALUE_SMALL_H +#define LCOLONQ_PIT_RUNTIME_VALUE_SMALL_H + +#include <lcq/pit/runtime.h> +#include <lcq/pit/runtime/value.h> + +/* the small values that can be NaN-boxed: doubles, integers, symbols */ + +#ifndef PIT_NO_DOUBLE +double pit_value_as_double(pit_runtime *rt, pit_value v); +bool pit_value_is_double(pit_runtime *rt, pit_value a); +pit_value pit_value_double_new(pit_runtime *rt, double d); +#endif + +i64 pit_value_as_integer(pit_runtime *rt, pit_value v); +bool pit_value_is_integer(pit_runtime *rt, pit_value a); +pit_value pit_value_integer_new(pit_runtime *rt, i64 i); +pit_value pit_value_bool_new(pit_runtime *rt, bool i); + +pit_symbol pit_value_as_symbol(pit_runtime *rt, pit_value v); +bool pit_value_is_symbol(pit_runtime *rt, pit_value a); +pit_value pit_value_symbol_new(pit_runtime *rt, pit_symbol s); + +pit_ref pit_value_as_ref(struct pit_runtime *rt, pit_value v); +bool pit_value_is_ref(pit_runtime *rt, pit_value a); +pit_value pit_value_ref_new(struct pit_runtime *rt, pit_ref r); +pit_value pit_value_ref_heavy_new(struct pit_runtime *rt); +pit_value_heavy *pit_value_ref_deref(struct pit_runtime *rt, pit_ref p); +bool pit_value_is_ref_heavy_sort(struct pit_runtime *rt, pit_value a, enum pit_value_heavy_sort e); + +#endif diff --git a/pit/include/lcq/pit/utils.h b/pit/include/lcq/pit/utils.h new file mode 100644 index 0000000..4bea479 --- /dev/null +++ b/pit/include/lcq/pit/utils.h @@ -0,0 +1,39 @@ +#ifndef LCOLONQ_PIT_UTILS_H +#define LCOLONQ_PIT_UTILS_H + +#include <stdarg.h> +#include <stddef.h> +#include <lcq/prelude.h> + +/* macro helpers */ +#define PIT_CONCAT(a, b) a ## b +#define PIT_STRSTR(x) #x +#define PIT_STR(x) PIT_STRSTR(x) + +/* implementations of needed libc functions */ +/* ctype */ +static inline bool pit_libc_ctype_isdigit(int a) { return a >= '0' && a <= '9'; } +static inline bool pit_libc_ctype_islower(int a) { return a >= 'a' && a <= 'z'; } +static inline bool pit_libc_ctype_isupper(int a) { return a >= 'A' && a <= 'Z'; } +static inline bool pit_libc_ctype_isalpha(int a) { return pit_libc_ctype_islower(a) || pit_libc_ctype_isupper(a); } +static inline bool pit_libc_ctype_isprint(int a) { return a >= 0x20 && a <= 0x7f; } +static inline bool pit_libc_ctype_isspace(int a) { return a == ' ' || a == '\r' || a == '\n' || a == '\t'; } + +/* string */ +static inline size_t pit_libc_string_strlen(char *s) { + size_t idx = 0; + while (s[idx] != 0) ++idx; + return idx; +} +static inline u8 *pit_libc_string_memcpy(u8 *dest, u8 *src, size_t n) { + size_t i = 0; + for (; i < n; ++i) dest[i] = src[i]; + return dest; +} +int pit_libc_string_vsnprintf(char *str, size_t size, char *format, va_list ap); +int pit_libc_string_snprintf(char *buf, size_t len, char *format, ...); + +/* assorted utilities and debugging tools */ +#define pit_mul(result, a, b) *result = (i64) (a) * (i64) (b) + +#endif diff --git a/pit/include/lcq/pit/vec.h b/pit/include/lcq/pit/vec.h new file mode 100644 index 0000000..82276f1 --- /dev/null +++ b/pit/include/lcq/pit/vec.h @@ -0,0 +1,52 @@ +#ifndef LCOLONQ_PIT_VEC_H +#define LCOLONQ_PIT_VEC_H + +#include <lcq/prelude.h> +#include <lcq/pit/utils.h> + +#define pit_vec(ty) pit_vec__ ## ty ## __type +#define pit_vec_new(ty) pit_vec__ ## ty ## __new +#define pit_vec_reset(ty) pit_vec__ ## ty ## __reset +#define pit_vec_get(ty) pit_vec__ ## ty ## __get +#define pit_vec_push(ty) pit_vec__ ## ty ## __push +#define pit_vec_pop(ty) pit_vec__ ## ty ## __pop + +#define PIT_DECLARE_VEC(ty) \ + typedef struct { \ + i64 capacity, next; \ + u8 data[]; \ + } pit_vec(ty); \ + static __attribute__ ((unused)) pit_vec(ty) *pit_vec_new(ty)(u8 *buf, i64 buf_len) { \ + uintptr_t base = (uintptr_t) buf; \ + uintptr_t aligned = pit_align_up(base, sizeof(void *)); \ + pit_vec(ty) *ret = (pit_vec(ty) *) aligned; \ + uintptr_t data = aligned + (i64) sizeof(pit_vec(ty)); \ + i64 offset = (i64) data - (i64) base; \ + i64 remaining = (i64) (buf_len - offset); \ + ret->next = 0; \ + ret->capacity = remaining; \ + if ((ret->next + 1) * (i64) sizeof(ty) > ret->capacity) return NULL; \ + return ret; \ + } \ + static __attribute__ ((unused)) void pit_vec_reset(ty)(pit_vec(ty) *s) { \ + s->next = 0; \ + } \ + static __attribute__ ((unused)) ty *pit_vec_get(ty)(pit_vec(ty) *s, i64 i) { \ + i64 idx = i * (i64) sizeof(ty); \ + if (idx + (i64) sizeof(ty) > s->capacity) return NULL; \ + return (ty *) &s->data[idx]; \ + } \ + static __attribute__ ((unused)) i64 pit_vec_push(ty)(pit_vec(ty) *s, ty x) { \ + i64 idx = s->next++ * (i64) sizeof(ty); \ + if (idx + (i64) sizeof(ty) > s->capacity) { return -1; } \ + *((ty *) &s->data[idx]) = x; \ + return s->next - 1; \ + } \ + static __attribute__ ((unused)) i64 pit_vec_pop(ty)(pit_vec(ty) *s, ty *v) { \ + i64 idx = (s->next - 1) * (i64) sizeof(ty); \ + if (s->next == 0 || idx + (i64) sizeof(ty) > s->capacity) return -1; \ + *v = *((ty *) &s->data[idx]); \ + return --s->next; \ + } + +#endif diff --git a/pit/packages.nix b/pit/packages.nix new file mode 100644 index 0000000..7f256b1 --- /dev/null +++ b/pit/packages.nix @@ -0,0 +1,66 @@ +pkgs: lcq: { + native = pkgs.pkgsMusl.stdenv.mkDerivation { + pname = "libcolonq-pit"; + version = "git"; + src = ./.; + hardeningDisable = ["all"]; + buildInputs = [ + lcq.prelude.native + ]; + installPhase = '' + make prefix=$out install + ''; + }; + wasm = let + wasm32-clang = pkgs.writeShellScriptBin "wasm32-clang" '' + ${pkgs.llvmPackages.clang-unwrapped}/bin/clang \ + -I${pkgs.llvmPackages.clang}/resource-root/include \ + -I${lcq.prelude.native}/include \ + --target=wasm32-unknown-unknown "$@" + ''; + in pkgs.stdenv.mkDerivation { + pname = "libcolonq-pit"; + version = "git"; + src = ./.; + hardeningDisable = ["all"]; + nativeBuildInputs = [ + wasm32-clang + ]; + buildPhase = '' + make CC=wasm32-clang libcolonq-pit.a + ''; + installPhase = '' + make CC=wasm32-clang prefix=$out install-core install-headers + ''; + }; + arm-embedded = pkgs.pkgsCross.arm-embedded.stdenv.mkDerivation { + pname = "libcolonq-pit"; + version = "git"; + src = ./.; + hardeningDisable = ["all"]; + buildInputs = [ + lcq.prelude.native + ]; + buildPhase = '' + make CPPFLAGS=-DPIT_NO_DOUBLE CC=arm-none-eabi-gcc AR=arm-none-eabi-ar libcolonq-pit.a + ''; + installPhase = '' + make CC=arm-none-eabi-gcc AR=arm-none-eabi-ar prefix=$out install-core install-headers + ''; + }; + windows = pkgs.pkgsCross.mingwW64.stdenv.mkDerivation { + pname = "libcolonq-pit"; + version = "git"; + src = ./.; + hardeningDisable = ["all"]; + buildInputs = [ + lcq.prelude.native + ]; + buildPhase = '' + make CC=x86_64-w64-mingw32-cc AR=x86_64-w64-mingw32-ar EXE=pit.exe + ''; + installPhase = '' + make CC=x86_64-w64-mingw32-cc AR=x86_64-w64-mingw32-ar EXE=pit.exe prefix=$out install + ''; + }; +} diff --git a/pit/src/arena.c b/pit/src/arena.c new file mode 100644 index 0000000..aedf0fb --- /dev/null +++ b/pit/src/arena.c @@ -0,0 +1,60 @@ +#include <lcq/pit/arena.h> +#include <lcq/pit/utils.h> + +pit_arena *pit_arena_new(u8 *buf, i64 buf_len, i64 elem_size) { + uintptr_t base = (uintptr_t) buf; + uintptr_t aligned = pit_align_up(base, sizeof(void *)); + pit_arena *a = (pit_arena *) aligned; + uintptr_t data = aligned + sizeof(pit_arena); + i64 offset = (i64) data - (i64) base; + i64 remaining = (i64) pit_align_down((uintptr_t) (buf_len - offset), sizeof(void *)); + if (!a || remaining <= 0) return NULL; + a->elem_size = elem_size; + a->capacity = remaining; + a->next = 0; + a->back = remaining; + return a; +} +void pit_arena_reset(pit_arena *a) { + a->next = 0; + a->back = a->capacity; +} +static i64 pit_arena_byte_idx(pit_arena *a, pit_arena_index idx) { + i64 byte_idx = 0; pit_mul(&byte_idx, a->elem_size, idx); + return byte_idx; +} +pit_arena_index pit_arena_alloc_index(pit_arena *a) { + i64 ret = a->next; + i64 byte_idx = pit_arena_byte_idx(a, ret); + if (byte_idx + a->elem_size >= a->back) { return -1; } + a->next += 1; + return ret; +} +pit_arena_index pit_arena_alloc_array_index(pit_arena *a, i64 num) { + i64 ret = a->next; + i64 byte_idx = pit_arena_byte_idx(a, ret); + i64 byte_len = 0; pit_mul(&byte_len, a->elem_size, num); + if (byte_idx + byte_len > a->back) { return -1; } + a->next += num; + return ret; +} +void *pit_arena_alloc(pit_arena *a) { + return pit_arena_get(a, pit_arena_alloc_index(a)); +} +void *pit_arena_alloc_array(pit_arena *a, i64 num) { + return pit_arena_get(a, pit_arena_alloc_array_index(a, num)); +} + +void *pit_arena_get(pit_arena *a, pit_arena_index idx) { + i64 byte_idx = pit_arena_byte_idx(a, idx); + if (byte_idx < 0 || byte_idx + a->elem_size >= a->back) { return NULL; } + return &a->data[byte_idx]; +} + +void *pit_arena_alloc_back(pit_arena *a, i64 sz) { + i64 next_byte = pit_arena_byte_idx(a, a->next); + i64 back_byte = (i64) pit_align_down((uintptr_t) (a->back - sz), sizeof(void *)); + if (back_byte < next_byte) return NULL; + a->back = back_byte; + return &a->data[a->back]; +} diff --git a/pit/src/lexer.c b/pit/src/lexer.c new file mode 100644 index 0000000..a2b0c7d --- /dev/null +++ b/pit/src/lexer.c @@ -0,0 +1,139 @@ +#include <lcq/pit/utils.h> +#include <lcq/pit/lexer.h> + +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", + /* [PIT_LEX_TOKEN_STRING_LITERAL] = */ "string_literal", + /* [PIT_LEX_TOKEN_SYMBOL] = */ "symbol", +}; + +const char *pit_lex_token_name(pit_lex_token t) { + return PIT_LEX_TOKEN_NAMES[t]; +} + +static bool is_more_input(pit_lexer *st) { + return st && st->end < st->len; +} + +static int is_symchar(int c) { + return c != '(' && c != ')' && c != '[' && c != ']' && c != '.' && c != '\'' && c != '"' + && pit_libc_ctype_isprint(c) + && !pit_libc_ctype_isspace(c); +} + +static int is_hexdigit(int c) { + return pit_libc_ctype_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; +} + +static char advance(pit_lexer *st) { + if (is_more_input(st)) { + char ret = st->input[st->end++]; + if (ret == '\n') { + st->line += 1; + st->column = 0; + } else { + st->column += 1; + } + return ret; + } + else return 0; +} + +static bool match(pit_lexer *st, int (*f)(int)) { + if (f(peek(st))) { + advance(st); + return true; + } else return false; +} + +void pit_lex_bytes(pit_lexer *ret, char *buf, i64 len) { + ret->len = len; + ret->input = buf; + ret->start = 0; + ret->end = 0; + ret->line = ret->start_line = 1; + ret->column = ret->start_column = 0; + ret->error = NULL; +} + +pit_lex_token pit_lex_next(pit_lexer *st) { +restart: + st->start = st->end; + st->start_line = st->line; + st->start_column = st->column; + char c = advance(st); + switch (c) { + case 0: return PIT_LEX_TOKEN_EOF; + 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 '"': + while (peek(st) != '"') { + if (peek(st) == '\\') advance(st); /* skip escaped characters */ + if (!advance(st)) { + st->error = "unterminated string"; + return PIT_LEX_TOKEN_ERROR; + } + } + advance(st); + return PIT_LEX_TOKEN_STRING_LITERAL; + default: { + if (pit_libc_ctype_isspace(c)) goto restart; + pit_lex_token ret = PIT_LEX_TOKEN_INTEGER_LITERAL; + int num_idx = 0; + bool hex = false; + bool leading_dash = false; + bool zero_prefix = false; + if (!is_symchar(c)) { + st->error = "unknown character"; + return PIT_LEX_TOKEN_ERROR; + } else { + do { + leading_dash = false; + switch (num_idx) { + case 0: + if (c == '0') zero_prefix = true; + else if (c == '-') { leading_dash = true; continue; } + break; + case 1: + if (zero_prefix) { + if (c == 'x') { hex = true; continue; } + else if (c == 'o' || c == 'b') continue; + } + break; + } + if (!(pit_libc_ctype_isdigit(c) || (hex && is_hexdigit(c)))) ret = PIT_LEX_TOKEN_SYMBOL; + ++num_idx; + } while (c = peek(st), match(st, is_symchar)); + } + if (leading_dash) return PIT_LEX_TOKEN_SYMBOL; + return ret; + } + } +} + +void pit_lex_cstr(pit_lexer *ret, char *buf) { + ret->input = buf; + ret->len = (i64) pit_libc_string_strlen(buf); + ret->start = 0; + ret->end = 0; + ret->line = ret->start_line = 1; + ret->column = ret->start_column = 0; + ret->error = NULL; +} diff --git a/pit/src/library.c b/pit/src/library.c new file mode 100644 index 0000000..b6b8b42 --- /dev/null +++ b/pit/src/library.c @@ -0,0 +1,910 @@ +#include <lcq/pit/vec.h> +#include <lcq/pit/lexer.h> +#include <lcq/pit/parser.h> +#include <lcq/pit/runtime.h> +#include <lcq/pit/library.h> + +static pit_value impl_sf_quote(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_runtime_eval_program_push_literal(rt, rt->program, pit_value_cons_car(rt, args)); + return PIT_NIL; +} +static pit_value impl_sf_if(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value c = pit_value_cons_car(rt, args); + if (pit_eval(rt, c) != PIT_NIL) { + if (pit_vec_push(pit_value)(rt->expr_stack, pit_value_cons_car(rt, pit_value_cons_cdr(rt, args))) < 0) + pit_error(rt, "in special form \"if\": evaluation stack overflow"); + } else { + if (pit_vec_push(pit_value)(rt->expr_stack, pit_value_cons_car(rt, pit_value_cons_cdr(rt, pit_value_cons_cdr(rt, args)))) < 0) + pit_error(rt, "in special form \"if\": evaluation stack overflow"); + } + return PIT_NIL; +} +static pit_value impl_sf_cond(pit_runtime *rt, pit_value args, void *data) { + (void) data; + while (args != PIT_NIL) { + pit_value clause = pit_value_cons_car(rt, args); + pit_value cond = pit_value_cons_car(rt, clause); + if (pit_eval(rt, cond) != PIT_NIL) { + if (pit_vec_push(pit_value)(rt->expr_stack, pit_value_cons(rt, pit_symtab_intern_cstr(rt, "progn"), pit_value_cons_cdr(rt, clause))) < 0) + pit_error(rt, "in special form \"cond\": evaluation stack overflow"); + return PIT_NIL; + } + args = pit_value_cons_cdr(rt, args); + } + if (pit_vec_push(pit_value)(rt->expr_stack, PIT_NIL) < 0) + pit_error(rt, "in special form \"cond\": evaluation stack overflow"); + return PIT_NIL; +} +static pit_value impl_sf_progn(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value bodyforms = args; + pit_value final = PIT_NIL; + while (bodyforms != PIT_NIL) { + final = pit_eval(rt, pit_value_cons_car(rt, bodyforms)); + bodyforms = pit_value_cons_cdr(rt, bodyforms); + } + 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, void *data) { + (void) data; + pit_value bodyforms = args; + pit_value final = PIT_NIL; + while (bodyforms != PIT_NIL) { + final = pit_eval(rt, pit_value_cons_car(rt, bodyforms)); + if (final != PIT_NIL) break; + bodyforms = pit_value_cons_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, void *data) { + (void) data; + pit_value as = pit_value_cons_car(rt, args); + pit_value body = pit_value_cons_cdr(rt, args); + pit_runtime_eval_program_push_literal(rt, rt->program, pit_value_func_lambda(rt, as, body)); + return PIT_NIL; +} +static pit_value impl_m_defun(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value nm = pit_value_cons_car(rt, args); + pit_value as = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + pit_value body = pit_value_cons_cdr(rt, pit_value_cons_cdr(rt, args)); + return pit_value_list(rt, 3, + pit_symtab_intern_cstr(rt, "fset!"), + pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "quote"), nm), + pit_value_cons(rt, pit_symtab_intern_cstr(rt, "lambda"), pit_value_cons(rt, as, body)) + ); +} +static pit_value impl_m_defmacro(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value nm = pit_value_cons_car(rt, args); + return pit_value_list(rt, 3, + pit_symtab_intern_cstr(rt, "progn"), + pit_value_cons(rt, pit_symtab_intern_cstr(rt, "defun!"), args), + pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "set-symbol-macro!"), nm) + ); +} +static pit_value impl_m_defstruct(pit_runtime *rt, pit_value args, void *data) { + (void) data; + 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_value_cons_car(rt, args); + pit_value fields = pit_value_cons_cdr(rt, args); + i64 field_idx = 0; + i64 nm_len = pit_value_bytes_copy(rt, pit_symtab_symbol_name(rt, nm), (u8 *) nm_str, sizeof(nm_str) - 1); + if (nm_len < 0) return PIT_NIL; + nm_str[nm_len] = 0; + /* constructor */ + pit_libc_string_snprintf(buf, sizeof(buf), ":%s", nm_str); + aargs = pit_value_cons(rt, pit_symtab_intern_cstr(rt, buf), pit_value_cons(rt, pit_symtab_intern_cstr(rt, "array"), PIT_NIL)); + fields = pit_value_cons_cdr(rt, args); + while (fields != PIT_NIL) { + i64 field_len = pit_value_bytes_copy(rt, + pit_symtab_symbol_name(rt, pit_value_cons_car(rt, fields)), + (u8 *) field_str, sizeof(field_str) - 1 + ); + if (field_len < 0) return PIT_NIL; + field_str[field_len] = 0; + pit_libc_string_snprintf(buf, sizeof(buf), ":%s", field_str); + aargs = pit_value_cons(rt, + pit_value_list(rt, 3, pit_symtab_intern_cstr(rt, "plist/get"), pit_symtab_intern_cstr(rt, buf), pit_symtab_intern_cstr(rt, "kwargs")), + aargs + ); + fields = pit_value_cons_cdr(rt, fields); + } + pit_libc_string_snprintf(buf, sizeof(buf), "%s/new", nm_str); + df = pit_value_list(rt, 4, + pit_symtab_intern_cstr(rt, "defun!"), + pit_symtab_intern_cstr(rt, buf), + pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "&"), pit_symtab_intern_cstr(rt, "kwargs")), + pit_value_list_reverse(rt, aargs) + ); + ret = pit_value_cons(rt, df, ret); + /* getters and setters */ + fields = pit_value_cons_cdr(rt, args); + field_idx = 0; + while (fields != PIT_NIL) { + i64 field_len = pit_value_bytes_copy(rt, + pit_symtab_symbol_name(rt, pit_value_cons_car(rt, fields)), + (u8 *) field_str, sizeof(field_str) - 1 + ); + if (field_len < 0) return PIT_NIL; + field_str[field_len] = 0; + /* getter */ + pit_libc_string_snprintf(buf, sizeof(buf), "%s/get-%s", nm_str, field_str); + df = pit_value_list(rt, 4, + pit_symtab_intern_cstr(rt, "defun!"), + pit_symtab_intern_cstr(rt, buf), + pit_value_list(rt, 1, pit_symtab_intern_cstr(rt, "v")), + pit_value_list(rt, 3, + pit_symtab_intern_cstr(rt, "array/get"), + pit_value_integer_new(rt, field_idx + 1), + pit_symtab_intern_cstr(rt, "v") + ) + ); + ret = pit_value_cons(rt, df, ret); + /* setter */ + pit_libc_string_snprintf(buf, sizeof(buf), "%s/set-%s!", nm_str, field_str); + df = pit_value_list(rt, 4, + pit_symtab_intern_cstr(rt, "defun!"), + pit_symtab_intern_cstr(rt, buf), + pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "v"), pit_symtab_intern_cstr(rt, "x")), + pit_value_list(rt, 4, + pit_symtab_intern_cstr(rt, "array/set!"), + pit_value_integer_new(rt, field_idx + 1), + pit_symtab_intern_cstr(rt, "x"), + pit_symtab_intern_cstr(rt, "v") + ) + ); + ret = pit_value_cons(rt, df, ret); + fields = pit_value_cons_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_value_cons(rt, pit_symtab_intern_cstr(rt, "progn"), ret); +} +static pit_value impl_m_let(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value lparams = PIT_NIL; + pit_value largs = PIT_NIL; + pit_value binds = pit_value_cons_car(rt, args); + pit_value bodyforms = pit_value_cons_cdr(rt, args); + pit_value lambda, application; + while (binds != PIT_NIL) { + pit_value bind = pit_value_cons_car(rt, binds); + pit_value sym = pit_value_cons_car(rt, bind); + pit_value expr = pit_value_cons_car(rt, pit_value_cons_cdr(rt, bind)); + lparams = pit_value_cons(rt, sym, lparams); + largs = pit_value_cons(rt, expr, largs); + binds = pit_value_cons_cdr(rt, binds); + } + lambda = pit_value_cons(rt, pit_symtab_intern_cstr(rt, "lambda"), pit_value_cons(rt, lparams, bodyforms)); + application = pit_value_cons(rt, lambda, largs); + return application; +} +static pit_value impl_m_and(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value ret = PIT_NIL; + args = pit_value_list_reverse(rt, args); + if (args != PIT_NIL) { + ret = pit_value_cons_car(rt, args); + args = pit_value_cons_cdr(rt, args); + } + while (args != PIT_NIL) { + ret = pit_value_list(rt, 3, pit_symtab_intern_cstr(rt, "if"), pit_value_cons_car(rt, args), ret, PIT_NIL); + args = pit_value_cons_cdr(rt, args); + } + return ret; +} +static pit_value impl_m_setq(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value sym = pit_value_cons_car(rt, args); + pit_value v = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + return pit_value_list(rt, 3, + pit_symtab_intern_cstr(rt, "set!"), + pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "quote"), sym), + 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, void *data) { + (void) data; + pit_value x = pit_value_cons_car(rt, args); + pit_value cases = pit_value_cons_cdr(rt, args); + pit_value clauses = PIT_NIL; + pit_value xvar = pit_symtab_intern_cstr(rt, "(internal case)"); + while (cases != PIT_NIL) { + pit_value c = pit_value_cons_car(rt, cases); + clauses = pit_value_cons(rt, + pit_value_list(rt, 2, + pit_value_list(rt, 3, pit_symtab_intern_cstr(rt, "equal?"), + xvar, + pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "quote"), pit_value_cons_car(rt, c)) + ), + pit_value_cons_car(rt, pit_value_cons_cdr(rt, c)) + ), + clauses + ); + cases = pit_value_cons_cdr(rt, cases); + } + return pit_value_list(rt, 3, + pit_symtab_intern_cstr(rt, "let"), + pit_value_list(rt, 1, pit_value_list(rt, 2, xvar, x)), + pit_value_cons(rt, pit_symtab_intern_cstr(rt, "cond"), pit_value_list_reverse(rt, clauses)) + ); +} +static pit_value impl_set(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value sym = pit_value_cons_car(rt, args); + pit_value v = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + pit_symtab_set(rt, sym, v); + return v; +} +static pit_value impl_fset(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value sym = pit_value_cons_car(rt, args); + pit_value v = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + pit_symtab_fset(rt, sym, v); + return v; +} +static pit_value impl_symbol_mark_macro(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value sym = pit_value_cons_car(rt, args); + pit_symtab_symbol_mark_macro(rt, sym); + return PIT_NIL; +} +static pit_value impl_funcall(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value f = pit_value_cons_car(rt, args); + return pit_value_apply(rt, f, pit_value_cons_cdr(rt, args)); +} +static pit_value impl_apply(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value f = pit_value_cons_car(rt, args); + pit_value xs = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + return pit_value_apply(rt, f, xs); +} +static pit_value impl_error(pit_runtime *rt, pit_value args, void *data) { + (void) data; + rt->error = PIT_T; + rt->error = pit_value_cons_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, void *data) { + (void) data; + return pit_eval(rt, pit_value_cons_car(rt, args)); +} +static pit_value impl_eq_p(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value x = pit_value_cons_car(rt, args); + pit_value y = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + return pit_value_bool_new(rt, pit_value_eq(x, y)); +} +static pit_value impl_equal_p(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value x = pit_value_cons_car(rt, args); + pit_value y = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + return pit_value_bool_new(rt, pit_value_equal(rt, x, y)); +} +static pit_value impl_integer_p(pit_runtime *rt, pit_value args, void *data) { + (void) data; + return pit_value_bool_new(rt, pit_value_is_integer(rt, pit_value_cons_car(rt, args))); +} +static pit_value impl_double_p(pit_runtime *rt, pit_value args, void *data) { + (void) data; + return pit_value_bool_new(rt, pit_value_is_double(rt, pit_value_cons_car(rt, args))); +} +static pit_value impl_symbol_p(pit_runtime *rt, pit_value args, void *data) { + (void) data; + return pit_value_bool_new(rt, pit_value_is_symbol(rt, pit_value_cons_car(rt, args))); +} +static pit_value impl_cons_p(pit_runtime *rt, pit_value args, void *data) { + (void) data; + return pit_value_bool_new(rt, pit_value_is_cons(rt, pit_value_cons_car(rt, args))); +} +static pit_value impl_array_p(pit_runtime *rt, pit_value args, void *data) { + (void) data; + return pit_value_bool_new(rt, pit_value_is_array(rt, pit_value_cons_car(rt, args))); +} +static pit_value impl_bytes_p(pit_runtime *rt, pit_value args, void *data) { + (void) data; + return pit_value_bool_new(rt, pit_value_is_bytes(rt, pit_value_cons_car(rt, args))); +} +static pit_value impl_function_p(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value a = pit_value_cons_car(rt, args); + bool b = (pit_value_is_symbol(rt, a) && pit_symtab_fget(rt, a) != PIT_NIL) + || pit_value_is_func(rt, a) + || pit_value_is_nativefunc(rt, a); + return pit_value_bool_new(rt, b); +} +static pit_value impl_cons(pit_runtime *rt, pit_value args, void *data) { + (void) data; + return pit_value_cons(rt, pit_value_cons_car(rt, args), pit_value_cons_car(rt, pit_value_cons_cdr(rt, args))); +} +static pit_value impl_car(pit_runtime *rt, pit_value args, void *data) { + (void) data; + return pit_value_cons_car(rt, pit_value_cons_car(rt, args)); +} +static pit_value impl_cdr(pit_runtime *rt, pit_value args, void *data) { + (void) data; + return pit_value_cons_cdr(rt, pit_value_cons_car(rt, args)); +} +static pit_value impl_setcar(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value v = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + pit_value_cons_setcar(rt, pit_value_cons_car(rt, args), v); + return v; +} +static pit_value impl_setcdr(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value v = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + pit_value_cons_setcdr(rt, pit_value_cons_car(rt, args), v); + return v; +} +static pit_value impl_list(pit_runtime *rt, pit_value args, void *data) { + (void) data; + (void) rt; + return args; +} +static pit_value impl_list_nth(pit_runtime *rt, pit_value args, void *data) { + (void) data; + i64 n = pit_value_as_integer(rt, pit_value_cons_car(rt, args)); + pit_value xs = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + while (xs != PIT_NIL && n-- > 0) { + xs = pit_value_cons_cdr(rt, xs); + } + return pit_value_cons_car(rt, xs); +} +static pit_value impl_list_iota(pit_runtime *rt, pit_value args, void *data) { + (void) data; + i64 n = pit_value_as_integer(rt, pit_value_cons_car(rt, args)); + pit_value ret = PIT_NIL; + while (n > 0) { + ret = pit_value_cons(rt, pit_value_integer_new(rt, --n), ret); + } + return ret; +} +static pit_value impl_list_len(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value arr = pit_value_cons_car(rt, args); + return pit_value_integer_new(rt, pit_value_list_len(rt, arr)); +} +static pit_value impl_list_reverse(pit_runtime *rt, pit_value args, void *data) { + (void) data; + return pit_value_list_reverse(rt, pit_value_cons_car(rt, args)); +} +static pit_value impl_list_uniq(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value xs = pit_value_cons_car(rt, args); + pit_value ret = PIT_NIL; + while (xs != PIT_NIL) { + pit_value x = pit_value_cons_car(rt, xs); + if (pit_value_list_contains_equal(rt, x, ret) == PIT_NIL) { + ret = pit_value_cons(rt, x, ret); + } + xs = pit_value_cons_cdr(rt, xs); + } + return pit_value_list_reverse(rt, ret); +} +static pit_value impl_list_append(pit_runtime *rt, pit_value args, void *data) { + (void) data; + args = pit_value_list_reverse(rt, args); + pit_value ret = pit_value_cons_car(rt, args); + pit_value ls = pit_value_cons_cdr(rt, args); + while (ls != PIT_NIL) { + pit_value xs = pit_value_list_reverse(rt, pit_value_cons_car(rt, ls)); + while (xs != PIT_NIL) { + ret = pit_value_cons(rt, pit_value_cons_car(rt, xs), ret); + xs = pit_value_cons_cdr(rt, xs); + } + ls = pit_value_cons_cdr(rt, ls); + } + return ret; +} +static pit_value impl_list_concat(pit_runtime *rt, pit_value args, void *data) { + (void) data; + return impl_list_append(rt, pit_value_cons_car(rt, args), NULL); +} +static pit_value impl_list_take(pit_runtime *rt, pit_value args, void *data) { + (void) data; + i64 num = pit_value_as_integer(rt, pit_value_cons_car(rt, args)); + pit_value arr = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + pit_value ret = PIT_NIL; + while (num > 0 && arr != PIT_NIL) { + ret = pit_value_cons(rt, pit_value_cons_car(rt, arr), ret); + arr = pit_value_cons_cdr(rt, arr); + num -= 1; + } + return pit_value_list_reverse(rt, ret); +} +static pit_value impl_list_drop(pit_runtime *rt, pit_value args, void *data) { + (void) data; + i64 num = pit_value_as_integer(rt, pit_value_cons_car(rt, args)); + pit_value arr = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + while (num > 0 && arr != PIT_NIL) { + arr = pit_value_cons_cdr(rt, arr); + num -= 1; + } + return arr; +} +static pit_value impl_list_map(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value func = pit_value_cons_car(rt, args); + pit_value xs = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + pit_value ret = PIT_NIL; + while (xs != PIT_NIL) { + pit_value y = pit_value_apply(rt, func, pit_value_cons(rt, pit_value_cons_car(rt, xs), PIT_NIL)); + ret = pit_value_cons(rt, y, ret); + xs = pit_value_cons_cdr(rt, xs); + } + return pit_value_list_reverse(rt, ret); +} +static pit_value impl_list_foldl(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value func = pit_value_cons_car(rt, args); + pit_value acc = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + pit_value xs = pit_value_cons_car(rt, pit_value_cons_cdr(rt, pit_value_cons_cdr(rt, args))); + while (xs != PIT_NIL) { + acc = pit_value_apply(rt, func, pit_value_list(rt, 2, pit_value_cons_car(rt, xs), acc)); + xs = pit_value_cons_cdr(rt, xs); + } + return acc; +} +static pit_value impl_list_filter(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value func = pit_value_cons_car(rt, args); + pit_value xs = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + pit_value ret = PIT_NIL; + while (xs != PIT_NIL) { + pit_value x = pit_value_cons_car(rt, xs); + pit_value y = pit_value_apply(rt, func, pit_value_cons(rt, x, PIT_NIL)); + if (y != PIT_NIL) { + ret = pit_value_cons(rt, x, ret); + } + xs = pit_value_cons_cdr(rt, xs); + } + return pit_value_list_reverse(rt, ret); +} +static pit_value impl_list_find(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value func = pit_value_cons_car(rt, args); + pit_value xs = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + while (xs != PIT_NIL) { + pit_value x = pit_value_cons_car(rt, xs); + pit_value y = pit_value_apply(rt, func, pit_value_cons(rt, x, PIT_NIL)); + if (y != PIT_NIL) { + return x; + } + xs = pit_value_cons_cdr(rt, xs); + } + return PIT_NIL; +} +static pit_value impl_list_contains_p(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value needle = pit_value_cons_car(rt, args); + pit_value haystack = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + while (haystack != PIT_NIL) { + if (pit_value_equal(rt, needle, pit_value_cons_car(rt, haystack))) return PIT_T; + haystack = pit_value_cons_cdr(rt, haystack); + } + return PIT_NIL; +} +static pit_value impl_list_all_p(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value f = pit_value_cons_car(rt, args); + pit_value xs = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + while (xs != PIT_NIL) { + pit_value x = pit_value_cons_car(rt, xs); + if (pit_value_apply(rt, f, pit_value_cons(rt, x, PIT_NIL)) == PIT_NIL) { + return PIT_NIL; + } + xs = pit_value_cons_cdr(rt, xs); + } + return PIT_T; +} +static pit_value impl_list_zip_with(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value f = pit_value_cons_car(rt, args); + pit_value xs = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + pit_value ys = pit_value_cons_car(rt, pit_value_cons_cdr(rt, pit_value_cons_cdr(rt, args))); + pit_value ret = PIT_NIL; + while (xs != PIT_NIL && ys != PIT_NIL) { + pit_value z = pit_value_apply(rt, f, pit_value_list(rt, 2, pit_value_cons_car(rt, xs), pit_value_cons_car(rt, ys))); + ret = pit_value_cons(rt, z, ret); + xs = pit_value_cons_cdr(rt, xs); ys = pit_value_cons_cdr(rt, ys); + } + return pit_value_list_reverse(rt, ret); +} +static pit_value impl_bytes_len(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value v = pit_value_cons_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_value_ref_deref(rt, pit_value_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_value_integer_new(rt, h->in.bytes.len); +} +static pit_value impl_bytes_range(pit_runtime *rt, pit_value args, void *data) { + (void) data; + i64 start = pit_value_as_integer(rt, pit_value_cons_car(rt, args)); + i64 end = pit_value_as_integer(rt, pit_value_cons_car(rt, pit_value_cons_cdr(rt, args))); + pit_value v = pit_value_cons_car(rt, pit_value_cons_cdr(rt, pit_value_cons_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_value_ref_deref(rt, pit_value_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_value_bytes_new(rt, h->in.bytes.data + start, end - start); +} +static pit_value impl_array(pit_runtime *rt, pit_value args, void *data) { + (void) data; + i64 len = pit_value_list_len(rt, args); + pit_value ret = pit_value_array_new(rt, len); + i64 idx = 0; + while (args != PIT_NIL) { + pit_value_array_set(rt, ret, idx++, pit_value_cons_car(rt, args)); + args = pit_value_cons_cdr(rt, args); + } + return ret; +} +static pit_value impl_array_to_list(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value arr = pit_value_cons_car(rt, args); + i64 ilen = pit_value_array_len(rt, arr); + pit_value ret = PIT_NIL; + i64 i = 0; + for (; i < ilen; ++i) { + ret = pit_value_cons(rt, pit_value_array_get(rt, arr, i), ret); + } + return pit_value_list_reverse(rt, ret); +} +static pit_value impl_array_from_list(pit_runtime *rt, pit_value args, void *data) { + (void) data; + i64 i = 0; + pit_value xs = pit_value_cons_car(rt, args); + i64 ilen = pit_value_list_len(rt, xs); + pit_value ret = pit_value_array_new(rt, ilen); + pit_value_heavy *h = pit_value_ref_deref(rt, pit_value_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_value_cons_car(rt, xs); + xs = pit_value_cons_cdr(rt, xs); + i += 1; + } + return ret; +} +static pit_value impl_array_repeat(pit_runtime *rt, pit_value args, void *data) { + (void) data; + i64 i = 0; + pit_value v = pit_value_cons_car(rt, args); + pit_value len = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + i64 ilen = pit_value_as_integer(rt, len); + pit_value ret = pit_value_array_new(rt, ilen); + pit_value_heavy *h = pit_value_ref_deref(rt, pit_value_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, void *data) { + (void) data; + pit_value arr = pit_value_cons_car(rt, args); + return pit_value_integer_new(rt, pit_value_array_len(rt, arr)); +} +static pit_value impl_array_get(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value idx = pit_value_cons_car(rt, args); + pit_value arr = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + return pit_value_array_get(rt, arr, pit_value_as_integer(rt, idx)); +} +static pit_value impl_array_set(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value idx = pit_value_cons_car(rt, args); + pit_value v = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + pit_value arr = pit_value_cons_car(rt, pit_value_cons_cdr(rt, pit_value_cons_cdr(rt, args))); + return pit_value_array_set(rt, arr, pit_value_as_integer(rt, idx), v); +} +static pit_value impl_array_map(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value func = pit_value_cons_car(rt, args); + pit_value arr = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + i64 len = pit_value_array_len(rt, arr); + pit_value ret = pit_value_array_new(rt, len); + i64 i = 0; + for (i = 0; i < len; ++i) { + pit_value y = pit_value_apply(rt, func, pit_value_cons(rt, pit_value_array_get(rt, arr, i), PIT_NIL)); + pit_value_array_set(rt, ret, i, y); + } + return ret; +} +static pit_value impl_array_map_mut(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value func = pit_value_cons_car(rt, args); + pit_value arr = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + i64 len = pit_value_array_len(rt, arr); + i64 i = 0; + for (i = 0; i < len; ++i) { + pit_value y = pit_value_apply(rt, func, pit_value_cons(rt, pit_value_array_get(rt, arr, i), PIT_NIL)); + pit_value_array_set(rt, arr, i, y); + } + return arr; +} +static pit_value impl_abs(pit_runtime *rt, pit_value args, void *data) { + (void) data; + i64 x = pit_value_as_integer(rt, pit_value_cons_car(rt, args)); + if (x < 0) return pit_value_integer_new(rt, -x); + return pit_value_integer_new(rt, x); +} +static pit_value impl_add(pit_runtime *rt, pit_value args, void *data) { + (void) data; + i64 total = 0; + while (args != PIT_NIL) { + total += pit_value_as_integer(rt, pit_value_cons_car(rt, args)); + args = pit_value_cons_cdr(rt, args); + } + return pit_value_integer_new(rt, total); +} +static pit_value impl_sub(pit_runtime *rt, pit_value args, void *data) { + (void) data; + i64 total = 0; + while (args != PIT_NIL) { + total -= pit_value_as_integer(rt, pit_value_cons_car(rt, args)); + args = pit_value_cons_cdr(rt, args); + } + return pit_value_integer_new(rt, total); +} +static pit_value impl_mul(pit_runtime *rt, pit_value args, void *data) { + (void) data; + i64 total = 1; + while (args != PIT_NIL) { + total *= pit_value_as_integer(rt, pit_value_cons_car(rt, args)); + args = pit_value_cons_cdr(rt, args); + } + return pit_value_integer_new(rt, total); +} +static pit_value impl_div(pit_runtime *rt, pit_value args, void *data) { + (void) data; + i64 total = pit_value_as_integer(rt, pit_value_cons_car(rt, args)); + args = pit_value_cons_cdr(rt, args); + while (args != PIT_NIL) { + i64 denom = pit_value_as_integer(rt, pit_value_cons_car(rt, args)); + if (denom == 0) { + pit_error(rt, "divide by zero"); + return PIT_NIL; + } + total /= denom; + args = pit_value_cons_cdr(rt, args); + } + return pit_value_integer_new(rt, total); +} +static pit_value impl_not(pit_runtime *rt, pit_value args, void *data) { + (void) data; + if (pit_value_cons_car(rt, args) == PIT_NIL) { + return PIT_T; + } else { + return PIT_NIL; + } +} +static pit_value impl_lt(pit_runtime *rt, pit_value args, void *data) { + (void) data; + i64 x = pit_value_as_integer(rt, pit_value_cons_car(rt, args)); + i64 y = pit_value_as_integer(rt, pit_value_cons_car(rt, pit_value_cons_cdr(rt, args))); + return pit_value_bool_new(rt, x < y); +} +static pit_value impl_gt(pit_runtime *rt, pit_value args, void *data) { + (void) data; + i64 x = pit_value_as_integer(rt, pit_value_cons_car(rt, args)); + i64 y = pit_value_as_integer(rt, pit_value_cons_car(rt, pit_value_cons_cdr(rt, args))); + return pit_value_bool_new(rt, x > y); +} +static pit_value impl_le(pit_runtime *rt, pit_value args, void *data) { + (void) data; + i64 x = pit_value_as_integer(rt, pit_value_cons_car(rt, args)); + i64 y = pit_value_as_integer(rt, pit_value_cons_car(rt, pit_value_cons_cdr(rt, args))); + return pit_value_bool_new(rt, x <= y); +} +static pit_value impl_ge(pit_runtime *rt, pit_value args, void *data) { + (void) data; + i64 x = pit_value_as_integer(rt, pit_value_cons_car(rt, args)); + i64 y = pit_value_as_integer(rt, pit_value_cons_car(rt, pit_value_cons_cdr(rt, args))); + return pit_value_bool_new(rt, x >= y); +} +static pit_value impl_bitwise_and(pit_runtime *rt, pit_value args, void *data) { + (void) data; + i64 total = -1; + while (args != PIT_NIL) { + total &= pit_value_as_integer(rt, pit_value_cons_car(rt, args)); + args = pit_value_cons_cdr(rt, args); + } + return pit_value_integer_new(rt, total); +} +static pit_value impl_bitwise_or(pit_runtime *rt, pit_value args, void *data) { + (void) data; + i64 total = 0; + while (args != PIT_NIL) { + total |= pit_value_as_integer(rt, pit_value_cons_car(rt, args)); + args = pit_value_cons_cdr(rt, args); + } + return pit_value_integer_new(rt, total); +} +static pit_value impl_bitwise_xor(pit_runtime *rt, pit_value args, void *data) { + (void) data; + i64 total = 0; + while (args != PIT_NIL) { + total ^= pit_value_as_integer(rt, pit_value_cons_car(rt, args)); + args = pit_value_cons_cdr(rt, args); + } + return pit_value_integer_new(rt, total); +} +static pit_value impl_bitwise_not(pit_runtime *rt, pit_value args, void *data) { + (void) data; + i64 x = pit_value_as_integer(rt, pit_value_cons_car(rt, args)); + return pit_value_integer_new(rt, ~x); +} +static pit_value impl_bitwise_lshift(pit_runtime *rt, pit_value args, void *data) { + (void) data; + i64 val = pit_value_as_integer(rt, pit_value_cons_car(rt, args)); + i64 shift = pit_value_as_integer(rt, pit_value_cons_car(rt, pit_value_cons_cdr(rt, args))); + return pit_value_integer_new(rt, val << shift); +} +static pit_value impl_bitwise_rshift(pit_runtime *rt, pit_value args, void *data) { + (void) data; + i64 val = pit_value_as_integer(rt, pit_value_cons_car(rt, args)); + i64 shift = pit_value_as_integer(rt, pit_value_cons_car(rt, pit_value_cons_cdr(rt, args))); + if (shift >= 64) val = 0; + else val >>= shift; + return pit_value_integer_new(rt, val); +} +void pit_install_library_essential(pit_runtime *rt) { + /* special forms */ + pit_symtab_sfset(rt, pit_symtab_intern_cstr(rt, "quote"), pit_value_nativefunc_new(rt, impl_sf_quote)); + pit_symtab_sfset(rt, pit_symtab_intern_cstr(rt, "if"), pit_value_nativefunc_new(rt, impl_sf_if)); + pit_symtab_sfset(rt, pit_symtab_intern_cstr(rt, "cond"), pit_value_nativefunc_new(rt, impl_sf_cond)); + pit_symtab_sfset(rt, pit_symtab_intern_cstr(rt, "progn"), pit_value_nativefunc_new(rt, impl_sf_progn)); + pit_symtab_sfset(rt, pit_symtab_intern_cstr(rt, "or"), pit_value_nativefunc_new(rt, impl_sf_or)); + pit_symtab_sfset(rt, pit_symtab_intern_cstr(rt, "lambda"), pit_value_nativefunc_new(rt, impl_sf_lambda)); + /* macros */ + pit_symtab_mset(rt, pit_symtab_intern_cstr(rt, "defun!"), pit_value_nativefunc_new(rt, impl_m_defun)); + pit_symtab_mset(rt, pit_symtab_intern_cstr(rt, "defmacro!"), pit_value_nativefunc_new(rt, impl_m_defmacro)); + pit_symtab_mset(rt, pit_symtab_intern_cstr(rt, "defstruct!"), pit_value_nativefunc_new(rt, impl_m_defstruct)); + pit_symtab_mset(rt, pit_symtab_intern_cstr(rt, "let"), pit_value_nativefunc_new(rt, impl_m_let)); + pit_symtab_mset(rt, pit_symtab_intern_cstr(rt, "and"), pit_value_nativefunc_new(rt, impl_m_and)); + pit_symtab_mset(rt, pit_symtab_intern_cstr(rt, "setq!"), pit_value_nativefunc_new(rt, impl_m_setq)); + pit_symtab_mset(rt, pit_symtab_intern_cstr(rt, "case"), pit_value_nativefunc_new(rt, impl_m_case)); + /* error */ + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "error!"), pit_value_nativefunc_new(rt, impl_error)); + /* eval */ + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "eval!"), pit_value_nativefunc_new(rt, impl_eval)); + /* predicates */ + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "eq?"), pit_value_nativefunc_new(rt, impl_eq_p)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "equal?"), pit_value_nativefunc_new(rt, impl_equal_p)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "integer?"), pit_value_nativefunc_new(rt, impl_integer_p)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "double?"), pit_value_nativefunc_new(rt, impl_double_p)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "symbol?"), pit_value_nativefunc_new(rt, impl_symbol_p)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "cons?"), pit_value_nativefunc_new(rt, impl_cons_p)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "array?"), pit_value_nativefunc_new(rt, impl_array_p)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "bytes?"), pit_value_nativefunc_new(rt, impl_bytes_p)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "function?"), pit_value_nativefunc_new(rt, impl_function_p)); + /* symbols */ + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "set!"), pit_value_nativefunc_new(rt, impl_set)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "fset!"), pit_value_nativefunc_new(rt, impl_fset)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "symbol-is-macro!"), pit_value_nativefunc_new(rt, impl_symbol_mark_macro)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "funcall"), pit_value_nativefunc_new(rt, impl_funcall)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "apply"), pit_value_nativefunc_new(rt, impl_apply)); + /* cons cells */ + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "cons"), pit_value_nativefunc_new(rt, impl_cons)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "car"), pit_value_nativefunc_new(rt, impl_car)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "cdr"), pit_value_nativefunc_new(rt, impl_cdr)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "setcar!"), pit_value_nativefunc_new(rt, impl_setcar)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "setcdr!"), pit_value_nativefunc_new(rt, impl_setcdr)); + /* cons lists*/ + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "list"), pit_value_nativefunc_new(rt, impl_list)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "list/nth"), pit_value_nativefunc_new(rt, impl_list_nth)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "list/iota"), pit_value_nativefunc_new(rt, impl_list_iota)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "list/len"), pit_value_nativefunc_new(rt, impl_list_len)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "list/reverse"), pit_value_nativefunc_new(rt, impl_list_reverse)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "list/uniq"), pit_value_nativefunc_new(rt, impl_list_uniq)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "list/append"), pit_value_nativefunc_new(rt, impl_list_append)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "list/concat"), pit_value_nativefunc_new(rt, impl_list_concat)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "list/take"), pit_value_nativefunc_new(rt, impl_list_take)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "list/drop"), pit_value_nativefunc_new(rt, impl_list_drop)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "list/map"), pit_value_nativefunc_new(rt, impl_list_map)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "list/foldl"), pit_value_nativefunc_new(rt, impl_list_foldl)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "list/filter"), pit_value_nativefunc_new(rt, impl_list_filter)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "list/find"), pit_value_nativefunc_new(rt, impl_list_find)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "list/contains?"), pit_value_nativefunc_new(rt, impl_list_contains_p)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "list/all?"), pit_value_nativefunc_new(rt, impl_list_all_p)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "list/zip-with"), pit_value_nativefunc_new(rt, impl_list_zip_with)); + /* bytestrings */ + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "bytes/len"), pit_value_nativefunc_new(rt, impl_bytes_len)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "bytes/range"), pit_value_nativefunc_new(rt, impl_bytes_range)); + /* array */ + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "array"), pit_value_nativefunc_new(rt, impl_array)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "array/to-list"), pit_value_nativefunc_new(rt, impl_array_to_list)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "array/from-list"), pit_value_nativefunc_new(rt, impl_array_from_list)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "array/repeat"), pit_value_nativefunc_new(rt, impl_array_repeat)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "array/len"), pit_value_nativefunc_new(rt, impl_array_len)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "array/get"), pit_value_nativefunc_new(rt, impl_array_get)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "array/set!"), pit_value_nativefunc_new(rt, impl_array_set)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "array/map"), pit_value_nativefunc_new(rt, impl_array_map)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "array/map!"), pit_value_nativefunc_new(rt, impl_array_map_mut)); + /* arithmetic */ + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "abs"), pit_value_nativefunc_new(rt, impl_abs)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "+"), pit_value_nativefunc_new(rt, impl_add)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "-"), pit_value_nativefunc_new(rt, impl_sub)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "*"), pit_value_nativefunc_new(rt, impl_mul)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "/"), pit_value_nativefunc_new(rt, impl_div)); + /* booleans */ + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "not"), pit_value_nativefunc_new(rt, impl_not)); + /* comparisons */ + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "<"), pit_value_nativefunc_new(rt, impl_lt)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, ">"), pit_value_nativefunc_new(rt, impl_gt)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "<="), pit_value_nativefunc_new(rt, impl_le)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, ">="), pit_value_nativefunc_new(rt, impl_ge)); + /* bitwise arithmetic */ + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "bitwise/and"), pit_value_nativefunc_new(rt, impl_bitwise_and)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "bitwise/or"), pit_value_nativefunc_new(rt, impl_bitwise_or)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "bitwise/xor"), pit_value_nativefunc_new(rt, impl_bitwise_xor)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "bitwise/not"), pit_value_nativefunc_new(rt, impl_bitwise_not)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "bitwise/lshift"), pit_value_nativefunc_new(rt, impl_bitwise_lshift)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "bitwise/rshift"), pit_value_nativefunc_new(rt, impl_bitwise_rshift)); +} + +static pit_value impl_plist_get(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value k = pit_value_cons_car(rt, args); + pit_value vs = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + return pit_value_list_plist_get(rt, k, vs); +} +void pit_install_library_plist(pit_runtime *rt) { + /* property lists / keyword arguments */ + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "plist/get"), pit_value_nativefunc_new(rt, impl_plist_get)); +} + +static pit_value impl_alist_get(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value k = pit_value_cons_car(rt, args); + pit_value vs = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + while (vs != PIT_NIL) { + pit_value v = pit_value_cons_car(rt, vs); + if (pit_value_equal(rt, k, pit_value_cons_car(rt, v))) { + return pit_value_cons_cdr(rt, v); + } + vs = pit_value_cons_cdr(rt, vs); + } + return PIT_NIL; +} +void pit_install_library_alist(pit_runtime *rt) { + /* association lists */ + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "alist/get"), pit_value_nativefunc_new(rt, impl_alist_get)); +} diff --git a/pit/src/main.c b/pit/src/main.c new file mode 100644 index 0000000..157ad87 --- /dev/null +++ b/pit/src/main.c @@ -0,0 +1,24 @@ +#include <stdlib.h> +#include <stdio.h> + +#include <lcq/pit/utils.h> +#include <lcq/pit/lexer.h> +#include <lcq/pit/parser.h> +#include <lcq/pit/runtime.h> +#include <lcq/pit/library.h> + +int main(int argc, char **argv) { + i64 sz = 256 * 1024 * 1024; + u8 *buf = malloc((size_t) sz); + pit_runtime *rt = pit_runtime_new(buf, sz); + 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) { + pit_repl(rt); + } else { + pit_load_file(rt, argv[1]); + } +} diff --git a/pit/src/native.c b/pit/src/native.c new file mode 100644 index 0000000..fbf8efc --- /dev/null +++ b/pit/src/native.c @@ -0,0 +1,307 @@ +#include <stdlib.h> +#include <stdio.h> +#include <string.h> + +#include <lcq/pit/lexer.h> +#include <lcq/pit/parser.h> +#include <lcq/pit/runtime.h> +#include <lcq/pit/library.h> + +i64 pit_lex_file(pit_lexer *ret, char *path) { + FILE *f = fopen(path, "r"); + if (f == NULL) { return -1; } + fseek(f, 0, SEEK_END); + i64 len = ftell(f); + fseek(f, 0, SEEK_SET); + char *buf = calloc((size_t) len, sizeof(char)); + if ((size_t) len != fread(buf, sizeof(char), (size_t) len, f)) { + fclose(f); + return -1; + } + fclose(f); + pit_lex_bytes(ret, buf, len); + return 0; +} + +bool pit_runtime_print_error(pit_runtime *rt) { + if (!pit_value_eq(rt->error, PIT_NIL)) { + char buf[1024] = {0}; + for (i64 i = 0; i < rt->backtrace->next; ++i) { + pit_annotated_ref *a = pit_vec_get(pit_annotated_ref)(rt->backtrace, i); + if (a == NULL) continue; + fprintf(stderr, "on line %ld, column %ld\n", a->annotation.line, a->annotation.column); + } + 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; +} + +void pit_debug_trace_(pit_runtime *rt, char *format, pit_value v) { + char buf[1024] = {0}; + i64 end = pit_dump(rt, buf, sizeof(buf) - 1, v, true); + buf[end] = 0; + fprintf(stderr, format, buf); +} + +pit_value pit_value_bytes_new_file(pit_runtime *rt, char *path) { + if (rt->error != PIT_NIL) return PIT_NIL; + FILE *f = fopen(path, "r"); + if (f == NULL) { + pit_error(rt, "failed to open file: %s", path); + return PIT_NIL; + } + fseek(f, 0, SEEK_END); + i64 len = ftell(f); + fseek(f, 0, SEEK_SET); + u8 *dest = pit_arena_alloc_array(rt->heap, len); + if (!dest) { pit_error(rt, "failed to allocate bytes"); fclose(f); return PIT_NIL; } + if ((size_t) len != fread(dest, sizeof(char), (size_t) len, f)) { + fclose(f); + pit_error(rt, "failed to read file: %s", path); + return PIT_NIL; + } + fclose(f); + pit_value ret = pit_value_ref_heavy_new(rt); + pit_value_heavy *h = pit_value_ref_deref(rt, pit_value_as_ref(rt, ret)); + if (!h) { pit_error(rt, "failed to create new heavy value for bytes"); return PIT_NIL; } + h->hsort = PIT_VALUE_HEAVY_SORT_BYTES; + h->in.bytes.data = dest; + h->in.bytes.len = len; + return ret; +} + +static void check_invariants(pit_runtime *rt) { + if (rt->expr_stack->next != 0) { + pit_error(rt, "leaked expr_stack memory! %ld", rt->expr_stack->next); + } + if (rt->result_stack->next != 0) { + pit_error(rt, "leaked result_stack memory! %ld", rt->result_stack->next); + } + if (rt->program->next != 0) { + pit_error(rt, "leaked program memory! %ld", rt->program->next); + } +} +pit_value pit_load_file(pit_runtime *rt, char *path) { + pit_lexer lex; + pit_parser parse; + bool eof = false; + pit_value p = PIT_NIL; + pit_value ret = PIT_NIL; + if (pit_lex_file(&lex, path) < 0) { + pit_error(rt, "failed to lex file: %s", path); + return PIT_NIL; + } + pit_parser_from_lexer(&parse, &lex); + while (p = pit_parse(rt, &parse, &eof), !eof) { + check_invariants(rt); if (pit_runtime_print_error(rt)) return PIT_NIL; + ret = pit_eval(rt, p); + check_invariants(rt); if (pit_runtime_print_error(rt)) return PIT_NIL; + pit_gc(rt); + check_invariants(rt); if (pit_runtime_print_error(rt)) return PIT_NIL; + } + check_invariants(rt); if (pit_runtime_print_error(rt)) return PIT_NIL; + return ret; +} + +void pit_repl(pit_runtime *rt) { + size_t bufcap = 8; + char *buf = malloc(bufcap); + i64 len = 0; + pit_runtime_freeze(rt); + check_invariants(rt); if (pit_runtime_print_error(rt)) exit(1); + setbuf(stdout, NULL); + printf("> "); + while ((buf[len++] = (char) getchar()) != EOF) { + if (len >= (i64) bufcap) { + bufcap *= 2; + buf = realloc(buf, bufcap); + } + pit_value res = PIT_NIL; + pit_lexer lex; + pit_parser parse; + bool eof = false; + pit_value p = PIT_NIL; + i64 depth = 0; + bool lex_error = false; + pit_lex_token tok = PIT_LEX_TOKEN_EOF; + if (buf[len - 1] != '\n') continue; + pit_lex_bytes(&lex, buf, len); + while (!lex_error && (tok = pit_lex_next(&lex)) != PIT_LEX_TOKEN_EOF) { + switch (tok) { + case PIT_LEX_TOKEN_ERROR: lex_error = true; break; + case PIT_LEX_TOKEN_LPAREN: depth += 1; break; + case PIT_LEX_TOKEN_RPAREN: depth -= 1; break; + default: break; + } + } + if (lex_error || depth > 0) continue; + buf[len - 1] = 0; + pit_lex_bytes(&lex, buf, len); + pit_parser_from_lexer(&parse, &lex); + while (p = pit_parse(rt, &parse, &eof), !eof) { + check_invariants(rt); + res = pit_eval(rt, p); + check_invariants(rt); + } + if (pit_runtime_print_error(rt)) { + rt->error = PIT_NIL; + printf("> "); + } else { + char dumpbuf[1024] = {0}; + pit_dump(rt, dumpbuf, sizeof(dumpbuf) - 1, res, true); + pit_gc(rt); + printf("%s\n> ", dumpbuf); + } + len = 0; + } + if (len >= (i64) sizeof(buf)) { + fprintf(stderr, "expression exceeded REPL buffer size\n"); + } else { + printf("bye!\n"); + } + free(buf); +} + +static pit_value impl_diagnostics(pit_runtime *rt, pit_value args, void *data) { + (void) data; + (void) args; + fprintf(stderr, "value allocs: %ld\n", rt->heap->next); + return PIT_NIL; +} +static pit_value impl_print(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value x = pit_value_cons_car(rt, args); + char buf[1024] = {0}; + pit_dump(rt, buf, sizeof(buf), x, true); + buf[1023] = 0; + puts(buf); + return x; +} +static pit_value impl_princ(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value x = pit_value_cons_car(rt, args); + char buf[1024] = {0}; + pit_dump(rt, buf, sizeof(buf), x, false); + buf[1023] = 0; + puts(buf); + return x; +} +static pit_value impl_load(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value path = pit_value_cons_car(rt, args); + char pathbuf[1024] = {0}; + i64 len = pit_value_bytes_copy(rt, path, (u8 *) pathbuf, sizeof(pathbuf) - 1); + if (len < 0) { pit_error(rt, "path was not a string"); return PIT_NIL; } + pathbuf[len] = 0; + return pit_load_file(rt, pathbuf); +} +void pit_install_library_io(pit_runtime *rt) { + /* diagnostics */ + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "diagnostics!"), pit_value_nativefunc_new(rt, impl_diagnostics)); + /* stream IO */ + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "print!"), pit_value_nativefunc_new(rt, impl_print)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "princ!"), pit_value_nativefunc_new(rt, impl_princ)); + /* disk IO */ + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "load!"), pit_value_nativefunc_new(rt, impl_load)); +} + +struct bytestring { + i64 len, cap; + u8 *data; +}; +static pit_value impl_bs_new(pit_runtime *rt, pit_value args, void *data) { + (void) data; + (void) args; + i64 cap = 256; + struct bytestring *bs = malloc(sizeof(struct bytestring)); + bs->len = 0; + bs->cap = cap; + bs->data = calloc((size_t) cap, 1); + return pit_value_nativedata_new(rt, pit_symtab_intern_cstr(rt, "bs"), (void *) bs); +} +static pit_value impl_bs_delete(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value v = pit_value_cons_car(rt, args); + pit_value_heavy *h = pit_value_ref_deref(rt, pit_value_as_ref(rt, v)); + if (!h) { pit_error(rt, "bad ref"); return PIT_NIL; } + if (h->hsort != PIT_VALUE_HEAVY_SORT_NATIVEDATA) { + pit_error(rt, "invalid use of value as bytestring nativedata"); + return PIT_NIL; + } + if (!pit_value_eq(h->in.nativedata.tag, pit_symtab_intern_cstr(rt, "bs"))) { + pit_error(rt, "native value is not a bytestring"); + return PIT_NIL; + } + if (!h->in.nativedata.data) { + pit_error(rt, "bytestring was already freed"); + return PIT_NIL; + } + struct bytestring *bs = h->in.nativedata.data; + if (bs->data) free(bs->data); + bs->data = NULL; + free(bs); + h->in.nativedata.data = NULL; + return PIT_T; +} +static pit_value impl_bs_grow(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value vsz = pit_value_cons_car(rt, args); + pit_value v = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + struct bytestring *bs = pit_value_nativedata_get(rt, pit_symtab_intern_cstr(rt, "bs"), v); + if (!bs) return PIT_NIL; + i64 sz = pit_value_as_integer(rt, vsz); + if (sz > bs->len) { + if (sz > bs->cap) { + while (bs->cap < sz) bs->cap <<= 1; + bs->data = realloc(bs->data, (size_t) bs->cap); + } + bs->len = sz; + } + return v; +} +static pit_value impl_bs_spit(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value path = pit_value_cons_car(rt, args); + char pathbuf[1024] = {0}; + i64 len = pit_value_bytes_copy(rt, path, (u8 *) pathbuf, sizeof(pathbuf) - 1); + if (len < 0) { pit_error(rt, "path was not a string"); return PIT_NIL; } + pathbuf[len] = 0; + pit_value v = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + struct bytestring *bs = pit_value_nativedata_get(rt, pit_symtab_intern_cstr(rt, "bs"), v); + if (!bs) return PIT_NIL; + FILE *f = fopen(pathbuf, "w+"); + if (!f) { pit_error(rt, "failed to open file: %s", pathbuf); return PIT_NIL; } + size_t written = fwrite(bs->data, 1, (size_t) bs->len, f); + fclose(f); + if (written != (size_t) bs->len) { + pit_error(rt, "failed to write bytestring to file: %s", pathbuf); + return PIT_NIL; + } + return v; +} +static pit_value impl_bs_write8(pit_runtime *rt, pit_value args, void *data) { + (void) data; + pit_value v = pit_value_cons_car(rt, args); + pit_value vidx = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + pit_value vx = pit_value_cons_car(rt, pit_value_cons_cdr(rt, pit_value_cons_cdr(rt, args))); + struct bytestring *bs = pit_value_nativedata_get(rt, pit_symtab_intern_cstr(rt, "bs"), v); + if (!bs) return PIT_NIL; + i64 idx = pit_value_as_integer(rt, vidx); + u8 x = (u8) pit_value_as_integer(rt, vx); + if (idx >= bs->len) { + pit_error(rt, "index %d out of bounds in bytestring (length %d)", idx, bs->len); + return PIT_NIL; + } + bs->data[idx] = x; + return v; +} +void pit_install_library_bytestring(pit_runtime *rt) { + /* bytestrings */ + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "bs/new!"), pit_value_nativefunc_new(rt, impl_bs_new)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "bs/delete!"), pit_value_nativefunc_new(rt, impl_bs_delete)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "bs/grow!"), pit_value_nativefunc_new(rt, impl_bs_grow)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "bs/spit!"), pit_value_nativefunc_new(rt, impl_bs_spit)); + pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "bs/write8!"), pit_value_nativefunc_new(rt, impl_bs_write8)); +} diff --git a/pit/src/parser.c b/pit/src/parser.c new file mode 100644 index 0000000..9c575cb --- /dev/null +++ b/pit/src/parser.c @@ -0,0 +1,177 @@ +#include <lcq/pit/utils.h> +#include <lcq/pit/lexer.h> +#include <lcq/pit/parser.h> +#include <lcq/pit/runtime.h> + +static pit_lex_token peek(pit_parser *st) { + if (!st) return PIT_LEX_TOKEN_ERROR; + return st->next.token; +} + +static pit_lex_token advance(pit_parser *st) { + if (!st) return PIT_LEX_TOKEN_ERROR; + st->cur = st->next; + st->next.token = pit_lex_next(st->lexer); + st->next.start = st->lexer->start; + st->next.end = st->lexer->end; + st->next.line = st->lexer->start_line; + st->next.column = st->lexer->start_column; + return st->cur.token; +} + +static bool match(pit_parser *st, pit_lex_token t) { + if (peek(st) == t) { + advance(st); + return true; + } else return false; +} + +static void get_token_string(pit_parser *st, char *buf, i64 len) { + i64 diff = st->cur.end - st->cur.start; + i64 tlen = diff >= len ? len - 1 : diff; + pit_libc_string_memcpy((u8 *) buf, (u8 *) st->lexer->input + st->cur.start, (size_t) tlen); + 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; + ret->cur.start = ret->next.start = 0; + ret->cur.end = ret->next.end = 0; + ret->cur.line = ret->next.line = -1; + ret->cur.column = ret->next.column = -1; + advance(ret); +} + +/* parse a single expression */ +pit_value pit_parse(pit_runtime *rt, pit_parser *st, bool *eof) { + if (rt == NULL || st == NULL) return PIT_NIL; + pit_lex_token t = advance(st); + rt->source_line = st->cur.line; + rt->source_column = st->cur.column; + switch (t) { + case PIT_LEX_TOKEN_ERROR: + pit_error(rt, "encountered an error while lexing: %s", st->lexer->error); + return PIT_NIL; + case PIT_LEX_TOKEN_EOF: + if (eof != NULL) { + *eof = true; + } else { + pit_error(rt, "end-of-file while parsing"); + } + return PIT_NIL; + case PIT_LEX_TOKEN_LPAREN: { + pit_value ret = PIT_NIL; + while (!match(st, PIT_LEX_TOKEN_RPAREN)) { + if (match(st, PIT_LEX_TOKEN_DOT)) { + ret = pit_parse(rt, st, eof); + if (match(st, PIT_LEX_TOKEN_RPAREN)) { + break; + } else { + pit_error(rt, "unterminated dotted list"); + return PIT_NIL; + } + } else { + ret = pit_value_cons(rt, pit_parse(rt, st, eof), ret); + } + if (rt->error != PIT_NIL || (eof != NULL && *eof)) { + pit_error(rt, "unterminated list"); + return PIT_NIL; /* if we hit an error, stop!*/ + } + } + ret = pit_value_list_reverse(rt, ret); + if (pit_value_sort(ret) == PIT_VALUE_SORT_REF) { + pit_annotation a = {0}; + a.line = rt->source_line; + a.column = rt->source_column; + pit_annotation_set(rt, pit_value_as_ref(rt, ret), a); + } + return ret; + } + case PIT_LEX_TOKEN_LSQUARE: { + pit_value ret = PIT_NIL; + pit_value xs = PIT_NIL; + i64 len = 0; + while (!match(st, PIT_LEX_TOKEN_RSQUARE)) { + pit_value x = pit_parse(rt, st, eof); + xs = pit_value_cons(rt, x, xs); + len += 1; + if (rt->error != PIT_NIL || (eof != NULL && *eof)) { + pit_error(rt, "unterminated array literal"); + return PIT_NIL; + } + } + ret = pit_value_array_new(rt, len); + while (xs != PIT_NIL) { + pit_value_array_set(rt, ret, --len, pit_value_cons_car(rt, xs)); + xs = pit_value_cons_cdr(rt, xs); + } + return ret; + } + case PIT_LEX_TOKEN_QUOTE: + return pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "quote"), pit_parse(rt, st, eof)); + case PIT_LEX_TOKEN_INTEGER_LITERAL: { + i64 idx = st->cur.start; + i64 base = 10; + i64 total = 0; + bool neg = false; + char c = st->lexer->input[idx++]; + if (c == '-') { + neg = true; + if (idx < st->cur.end) { + c = st->lexer->input[idx++]; + } else { + pit_error(rt, "malformed negative integer literal"); return PIT_NIL; + } + } + 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_value_integer_new(rt, neg ? -total : total); + } + case PIT_LEX_TOKEN_STRING_LITERAL: { + char buf[256] = {0}; + get_token_string(st, buf, sizeof(buf)); + i64 len = (i64) pit_libc_string_strlen(buf); + i64 cur = 0; + for (i64 i = 1; i < len; ++i) { + if (buf[i] == '\\' && i + 1 < len) buf[cur++] = buf[++i]; + else if (buf[i] != '"') buf[cur++] = buf[i]; + else break; + } + return pit_value_bytes_new(rt, (u8 *) buf, cur); + } + case PIT_LEX_TOKEN_SYMBOL: { + char buf[256] = {0}; + get_token_string(st, buf, sizeof(buf)); + return pit_symtab_intern_cstr(rt, buf); + } + default: + pit_error(rt, "unexpected token: %s", pit_lex_token_name(t)); + return PIT_NIL; + } +} diff --git a/pit/src/runtime.c b/pit/src/runtime.c new file mode 100644 index 0000000..a8428c7 --- /dev/null +++ b/pit/src/runtime.c @@ -0,0 +1,116 @@ +#include <lcq/pit/utils.h> +#include <lcq/pit/lexer.h> +#include <lcq/pit/parser.h> +#include <lcq/pit/runtime.h> +#include <lcq/pit/library.h> + +enum pit_value_sort pit_value_sort(pit_value v) { + /* if this isn't a NaN, or it's a quiet NaN, this is a real double */ + /* if (((v >> 52) & 0b011111111111) != 0b011111111111 || ((v >> 51) & 0b1) == 1) return PIT_VALUE_SORT_DOUBLE; */ + if (((v >> 52) & 0x7ff) != 0x7ff || ((v >> 51) & 1) == 1) return PIT_VALUE_SORT_DOUBLE; + /* otherwise, we've packed something else in the significand + 0 for signaling NaN -+ + sign --+ +- 1 (NaN)| +- our sort tag + our data + | | | | | + s111111111110ttddddddddddddddddddddddddddddddddddddddddddddddddd */ + /* return (v & 0b0000000000000110000000000000000000000000000000000000000000000000) >> 49; */ + return (v & 0x6000000000000) >> 49; /* equivalent hex literal */ +} + +u64 pit_value_data(pit_value v) { + /* return v & 0b0000000000000001111111111111111111111111111111111111111111111111; */ + return v & 0x1ffffffffffff; +} + +pit_runtime *pit_runtime_new(u8 *buf, i64 len) { + pit_arena *a = pit_arena_new(buf, len, sizeof(u8)); + pit_runtime *ret = pit_arena_alloc_back(a, sizeof(*ret)); + i64 heap_size = len / 4; + i64 annotations_size = len / 32; + i64 symtab_size = len / 16; + i64 stack_size = len / 32; + ret->heap = pit_arena_new(pit_arena_alloc_back(a, heap_size), heap_size, sizeof(pit_value_heavy)); + ret->backbuffer = pit_arena_new(pit_arena_alloc_back(a, heap_size), heap_size, sizeof(pit_value_heavy)); + ret->annotations = pit_vec_new(pit_annotated_ref)(pit_arena_alloc_back(a, annotations_size), annotations_size); + ret->backtrace = pit_vec_new(pit_annotated_ref)(pit_arena_alloc_back(a, annotations_size), annotations_size); + ret->symtab = pit_vec_new(pit_symtab_entry)(pit_arena_alloc_back(a, symtab_size), symtab_size); + ret->expr_stack = pit_vec_new(pit_value)(pit_arena_alloc_back(a, stack_size), stack_size); + ret->result_stack = pit_vec_new(pit_value)(pit_arena_alloc_back(a, stack_size), stack_size); + ret->program = pit_vec_new(pit_runtime_eval_ins)(pit_arena_alloc_back(a, stack_size), stack_size); + ret->saved_bindings = pit_vec_new(pit_value)(pit_arena_alloc_back(a, stack_size), stack_size); + ret->frozen_values = 0; + ret->frozen_symtab = 0; + ret->error = PIT_NIL; + ret->source_line = ret->source_column = -1; + ret->error_line = ret->error_column = -1; + pit_value nil = pit_symtab_intern_cstr(ret, "nil"); /* nil must be the 0th symbol for PIT_NIL to work */ + pit_symtab_set(ret, nil, PIT_NIL); + pit_value truth = pit_symtab_intern_cstr(ret, "t"); + pit_symtab_set(ret, truth, truth); + pit_runtime_freeze(ret); + return ret; +} + +void pit_runtime_freeze(pit_runtime *rt) { + rt->frozen_values = rt->heap->next; + rt->frozen_symtab = rt->symtab->next; +} +void pit_runtime_reset(pit_runtime *rt) { + rt->heap->next = rt->frozen_values; + rt->symtab->next = rt->frozen_symtab; +} + +pit_value pit_error_get(pit_runtime *rt) { + pit_value ret = rt->error; + rt->error = PIT_NIL; + return ret; +} + +void pit_error(pit_runtime *rt, char *format, ...) { + if (rt->error == PIT_NIL) { /* only record the first error encountered */ + char buf[1024] = {0}; + va_list vargs; + va_start(vargs, format); + pit_libc_string_snprintf(buf, sizeof(buf), format, vargs); + va_end(vargs); + rt->error = PIT_T; /* we set the error now to prevent infinite recursion */ + rt->error = pit_value_bytes_new_cstr(rt, buf); /* in case this errs also */ + if (rt->error == PIT_NIL) rt->error = PIT_T; + rt->error_line = rt->source_line; + rt->error_column = rt->source_column; + } +} + +void pit_annotation_set(struct pit_runtime *rt, pit_ref ref, pit_annotation annotation) { + pit_annotated_ref a; + a.ref = ref; + a.annotation = annotation; + if (pit_vec_push(pit_annotated_ref)(rt->annotations, a) < 0) + pit_error(rt, "annotation overflow"); +} +pit_annotated_ref *pit_annotation_get(struct pit_runtime *rt, pit_ref ref) { + for (i64 i = 0; i < rt->annotations->next; ++i) { + pit_annotated_ref *a = pit_vec_get(pit_annotated_ref)(rt->annotations, i); + if (a == NULL) pit_error(rt, "failed to get annotation"); + else if (a->ref == ref) { + return a; + } + } + return NULL; +} + +void pit_runtime_eval_program_push_literal(pit_runtime *rt, pit_vec(pit_runtime_eval_ins) *s, pit_value x) { + pit_runtime_eval_ins ent; + ent.sort = PIT_RUNTIME_EVAL_INS_LITERAL; + ent.in.literal = x; + if (pit_vec_push(pit_runtime_eval_ins)(s, ent) < 0) + pit_error(rt, "evaluation program overflow"); +} +void pit_runtime_eval_program_push_apply(pit_runtime *rt, pit_vec(pit_runtime_eval_ins) *s, i64 arity, pit_annotated_ref *annotation) { + pit_runtime_eval_ins ent; + ent.sort = PIT_RUNTIME_EVAL_INS_APPLY; + ent.in.apply.arity = arity; + ent.in.apply.annotation = annotation; + if (pit_vec_push(pit_runtime_eval_ins)(s, ent) < 0) + pit_error(rt, "evaluation program overflow"); +} diff --git a/pit/src/runtime/dump.c b/pit/src/runtime/dump.c new file mode 100644 index 0000000..3d5ec9c --- /dev/null +++ b/pit/src/runtime/dump.c @@ -0,0 +1,100 @@ +#include <lcq/pit/runtime/dump.h> + +#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; + switch (pit_value_sort(v)) { + case PIT_VALUE_SORT_DOUBLE: + #ifndef PIT_NO_DOUBLE + return pit_libc_string_snprintf(buf, (size_t) len, "%lf", pit_value_as_double(rt, v)); + #else + return pit_string_snprintf(buf, (size_t) len, "<unsupported double>"); + #endif + case PIT_VALUE_SORT_INTEGER: + return pit_libc_string_snprintf(buf, (size_t) len, "%ld", pit_value_as_integer(rt, v)); + case PIT_VALUE_SORT_SYMBOL: { + pit_symtab_entry *ent = pit_symtab_lookup(rt, v); + if (ent + && pit_value_sort(ent->name) == PIT_VALUE_SORT_REF + && (h = pit_value_ref_deref(rt, pit_value_as_ref(rt, ent->name))) + ) { + i64 i = 0; + for (; i < h->in.bytes.len && i < len - 1; ++i) { + buf[i] = (char) h->in.bytes.data[i]; + } + return i; + } else { + return pit_libc_string_snprintf(buf, (size_t) len, "<broken symbol %ld>", pit_value_as_symbol(rt, v)); + } + } + case PIT_VALUE_SORT_REF: { + pit_ref r = pit_value_as_ref(rt, v); + char *end = buf + len; + char *start = buf; + h = pit_value_ref_deref(rt, r); + if (!h) pit_libc_string_snprintf(buf, (size_t) len, "<ref %ld>", r); + else { + switch (h->hsort) { + case PIT_VALUE_HEAVY_SORT_CELL: { + CHECK_BUF; *(buf++) = '{'; + CHECK_BUF; buf += pit_dump(rt, buf, end - buf, pit_value_cons_car(rt, h->in.cell), readable); + CHECK_BUF; *(buf++) = '}'; + return buf - start; + } + case PIT_VALUE_HEAVY_SORT_CONS: { + pit_value cur = v; + CHECK_BUF_LABEL(list_end); + do { + if (pit_value_is_cons(rt, cur)) { + CHECK_BUF_LABEL(list_end); *(buf++) = ' '; + CHECK_BUF_LABEL(list_end); buf += pit_dump(rt, buf, end - buf, pit_value_cons_car(rt, cur), readable); + } else { + CHECK_BUF_LABEL(list_end); buf += pit_libc_string_snprintf(buf, (size_t) (end - buf), " . "); + CHECK_BUF_LABEL(list_end); buf += pit_dump(rt, buf, end - buf, cur, readable); + } + } while (!pit_value_eq((cur = pit_value_cons_cdr(rt, cur)), PIT_NIL)); + CHECK_BUF_LABEL(list_end); *(buf++) = ')'; + list_end: + *start = '('; + 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) { 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] == '"')) { + CHECK_BUF; buf[i++] = '\\'; + } + else { + CHECK_BUF; buf[i++] = (char) h->in.bytes.data[j++]; + } + } + if (readable && i < len - 1) buf[i++] = '"'; + return i; + } + default: + return pit_libc_string_snprintf(buf, (size_t) len, "<ref %ld>", r); + } + } + break; + } + } + return 0; +} diff --git a/pit/src/runtime/eval.c b/pit/src/runtime/eval.c new file mode 100644 index 0000000..f5eba97 --- /dev/null +++ b/pit/src/runtime/eval.c @@ -0,0 +1,107 @@ +#include <lcq/pit/runtime/eval.h> + +pit_value pit_eval(pit_runtime *rt, pit_value top) { + i64 expr_stack_reset = rt->expr_stack->next; + i64 result_stack_reset = rt->result_stack->next; + i64 program_reset = rt->program->next; + // pit_vec_reset(pit_annotated_ref)(rt->backtrace); + if (pit_vec_push(pit_value)(rt->expr_stack, top) < 0) + pit_error(rt, "evaluation stack overflow"); + /* first, convert the expression tree into "polish notation" in program */ + while (rt->expr_stack->next > expr_stack_reset) { + pit_value cur = PIT_NIL; + if (rt->error != PIT_NIL) goto end; + if (pit_vec_pop(pit_value)(rt->expr_stack, &cur) < 0) + pit_error(rt, "evaluation stack underflow"); + if (pit_value_is_cons(rt, cur)) { /* compound expressions: function/macro application special forms */ + pit_value fsym = pit_value_cons_car(rt, cur); + bool is_symbol = pit_value_is_symbol(rt, fsym); + pit_annotated_ref *ann = pit_annotation_get(rt, pit_value_as_ref(rt, cur)); + if (is_symbol && pit_symtab_is_symbol_special_form(rt, fsym)) { /* special forms */ + pit_value f = pit_symtab_fget(rt, fsym); + pit_value args = pit_value_cons_cdr(rt, cur); + /* special forms are nativefuncs that directly manipulate the stacks + basically macros, but we don't need to evaluate the return value */ + pit_value_apply(rt, f, args); + } else if (is_symbol && pit_symtab_is_symbol_macro(rt, fsym)) { /* macros */ + pit_value f = pit_symtab_fget(rt, fsym); + pit_value args = pit_value_cons_cdr(rt, cur); + pit_value res = pit_value_apply(rt, f, args); + if (pit_vec_push(pit_value)(rt->expr_stack, res) < 0) + pit_error(rt, "evaluation stack overflow"); + } else { /* normal functions */ + pit_value args = pit_value_cons_cdr(rt, cur); + i64 argcount = 0; + while (args != PIT_NIL) { + if (pit_vec_push(pit_value)(rt->expr_stack, pit_value_cons_car(rt, args)) < 0) + pit_error(rt, "evaluation stack overflow"); + args = pit_value_cons_cdr(rt, args); + argcount += 1; + } + if (!is_symbol) { + if (pit_vec_push(pit_value)(rt->expr_stack, fsym) < 0) + pit_error(rt, "evaluation stack overflow"); + } + pit_runtime_eval_program_push_apply(rt, rt->program, argcount, ann); + if (is_symbol) { + pit_value f = pit_symtab_fget(rt, fsym); + pit_runtime_eval_program_push_literal(rt, rt->program, f); + } + } + } else if (pit_value_is_symbol(rt, cur)) { /* unquoted symbols: variable lookup */ + pit_symtab_entry *ent = pit_symtab_lookup(rt, cur); + if (ent->is_keyword) { + pit_runtime_eval_program_push_literal(rt, rt->program, cur); + } else { + pit_runtime_eval_program_push_literal(rt, rt->program, pit_symtab_get(rt, cur)); + } + } else { /* other expressions evaluate to themselves! */ + pit_runtime_eval_program_push_literal(rt, rt->program, cur); + } + } + /* then, execute the polish notation program from right to left + this has the nice consequence of putting the arguments in the right order */ + for (i64 idx = rt->program->next - 1; idx >= program_reset; --idx) { + pit_runtime_eval_ins *ent = pit_vec_get(pit_runtime_eval_ins)(rt->program, idx); + if (ent == NULL) pit_error(rt, "evaluation program invalid"); + if (rt->error != PIT_NIL) goto end; + switch (ent->sort) { + case PIT_RUNTIME_EVAL_INS_LITERAL: + if (pit_vec_push(pit_value)(rt->result_stack, ent->in.literal) < 0) + pit_error(rt, "evaluation result stack overflow"); + break; + case PIT_RUNTIME_EVAL_INS_APPLY: { + pit_value f = PIT_NIL; + pit_value args = PIT_NIL; + if (pit_vec_pop(pit_value)(rt->result_stack, &f) < 0) + pit_error(rt, "evaluation result stack underflow"); + for (i64 i = 0; i < ent->in.apply.arity; ++i) { + pit_value a = PIT_NIL; + if (pit_vec_pop(pit_value)(rt->result_stack, &a) < 0) + pit_error(rt, "evaluation result stack underflow"); + args = pit_value_cons(rt, a, args); + } + if (ent->in.apply.annotation != NULL) { + rt->source_line = ent->in.apply.annotation->annotation.line; + rt->source_column = ent->in.apply.annotation->annotation.column; + pit_vec_push(pit_annotated_ref)(rt->backtrace, *ent->in.apply.annotation); + } + if (pit_vec_push(pit_value)(rt->result_stack, pit_value_apply(rt, f, args)) < 0) + pit_error(rt, "evaluation result stack underflow"); + break; + } + default: + pit_error(rt, "unknown program entry"); + goto end; + } + } +end: { + pit_value ret = PIT_NIL; + if (pit_vec_pop(pit_value)(rt->result_stack, &ret) < 0) + pit_error(rt, "evaluation result stack underflow"); + rt->expr_stack->next = expr_stack_reset; + rt->result_stack->next = result_stack_reset; + rt->program->next = program_reset; + return ret; + } +} diff --git a/pit/src/runtime/gc.c b/pit/src/runtime/gc.c new file mode 100644 index 0000000..fcb5f89 --- /dev/null +++ b/pit/src/runtime/gc.c @@ -0,0 +1,100 @@ +#include <lcq/pit/runtime/gc.h> + +static i64 gc_copy(pit_runtime *rt, pit_value_heavy *h) { + if (h->hsort == PIT_VALUE_HEAVY_SORT_FORWARDING_POINTER) { + return h->in.forwarding_pointer; + } else { + i64 ret = rt->backbuffer->next; + pit_value_heavy *g = pit_arena_alloc(rt->backbuffer); + *g = *h; + h->hsort = PIT_VALUE_HEAVY_SORT_FORWARDING_POINTER; + h->in.forwarding_pointer = ret; + return ret; + } +} +static pit_value gc_copy_value(pit_runtime *rt, pit_value v) { + if (pit_value_sort(v) == PIT_VALUE_SORT_REF) { + pit_ref r = pit_value_as_ref(rt, v); + pit_value_heavy *h = pit_value_ref_deref(rt, r); + i64 new = gc_copy(rt, h); + pit_annotated_ref *ann = pit_annotation_get(rt, r); + if (ann != NULL) { + pit_annotated_ref newann = *ann; + newann.ref = new; + if (pit_vec_push(pit_annotated_ref)(rt->backtrace, newann) < 0) + pit_error(rt, "annotation overflow"); + } + return pit_value_ref_new(rt, new); + } else { + return v; + } +} +void pit_gc(pit_runtime *rt) { + rt->frozen_values = 0; + rt->frozen_symtab = 0; + pit_arena *fromspace = rt->heap; + pit_arena *tospace = rt->backbuffer; + pit_vec(pit_annotated_ref) *fromspace_ann = rt->annotations; + pit_vec(pit_annotated_ref) *tospace_ann = rt->backtrace; + pit_arena_reset(tospace); + pit_vec_reset(pit_annotated_ref)(tospace_ann); + /* populate tospace with immediately reachable values */ + for (i64 i = 0; i < rt->symtab->next; ++i) { + pit_symtab_entry *ent = pit_vec_get(pit_symtab_entry)(rt->symtab, i); + if (ent == NULL) continue; /* TODO warn on failure here? */ + ent->name = gc_copy_value(rt, ent->name); + ent->value = gc_copy_value(rt, ent->value); + ent->function = gc_copy_value(rt, ent->function); + } + for (i64 i = 0; i < rt->saved_bindings->next; ++i) { + pit_value *v = pit_vec_get(pit_value)(rt->saved_bindings, i); + if (v != NULL) *v = gc_copy_value(rt, *v); /* TODO warn on failure here? */ + } + for (i64 scan = 0; scan < tospace->next; ++scan) { + pit_value_heavy *h = pit_arena_get(tospace, scan); + switch (h->hsort) { + case PIT_VALUE_HEAVY_SORT_CELL: + h->in.cell = gc_copy_value(rt, h->in.cell); + break; + case PIT_VALUE_HEAVY_SORT_CONS: + h->in.cons.car = gc_copy_value(rt, h->in.cons.car); + h->in.cons.cdr = gc_copy_value(rt, h->in.cons.cdr); + break; + case PIT_VALUE_HEAVY_SORT_ARRAY: { + i64 byte_len = 0; pit_mul(&byte_len, sizeof(pit_value), h->in.array.len); + pit_value *data = pit_arena_alloc_back(tospace, byte_len); + for (i64 i = 0; i < h->in.array.len; ++i) { + data[i] = gc_copy_value(rt, h->in.array.data[i]); + } + h->in.array.data = data; + break; + } + case PIT_VALUE_HEAVY_SORT_BYTES: { + u8 *data = pit_arena_alloc_back(tospace, h->in.bytes.len); + for (i64 i = 0; i < h->in.bytes.len; ++i) { + data[i] = h->in.bytes.data[i]; + } + h->in.bytes.data = data; + break; + } + case PIT_VALUE_HEAVY_SORT_FUNC: + h->in.func.env = gc_copy_value(rt, h->in.func.env); + h->in.func.args = gc_copy_value(rt, h->in.func.args); + h->in.func.arg_rest_nm = gc_copy_value(rt, h->in.func.arg_rest_nm); + h->in.func.body = gc_copy_value(rt, h->in.func.body); + break; + case PIT_VALUE_HEAVY_SORT_NATIVEFUNC: break; + case PIT_VALUE_HEAVY_SORT_NATIVEDATA: + h->in.nativedata.tag = gc_copy_value(rt, h->in.nativedata.tag); + break; + case PIT_VALUE_HEAVY_SORT_FORWARDING_POINTER: + pit_error(rt, "garbage collection broken! encountered forwarding pointer in to-space"); + break; + } + } + rt->heap = tospace; + rt->backbuffer = fromspace; + rt->annotations = tospace_ann; + rt->backtrace = fromspace_ann; + pit_vec_reset(pit_annotated_ref)(rt->backtrace); +} diff --git a/pit/src/runtime/macroexpand.c b/pit/src/runtime/macroexpand.c new file mode 100644 index 0000000..13a4fdd --- /dev/null +++ b/pit/src/runtime/macroexpand.c @@ -0,0 +1,111 @@ +#include <lcq/pit/runtime/macroexpand.h> + +pit_value pit_macroexpand(pit_runtime *rt, pit_value top) { + i64 expr_stack_reset = rt->expr_stack->next; + i64 result_stack_reset = rt->result_stack->next; + i64 program_reset = rt->program->next; + if (pit_vec_push(pit_value)(rt->expr_stack, top) < 0) + pit_error(rt, "macro expansion stack overflow"); + while (rt->expr_stack->next > expr_stack_reset) { + pit_value cur; + if (rt->error != PIT_NIL) goto end; + if (pit_vec_pop(pit_value)(rt->expr_stack, &cur) < 0) + pit_error(rt, "macro expansion stack underflow"); + if (pit_value_is_cons(rt, cur)) { + pit_value fsym = pit_value_cons_car(rt, cur); + bool is_symbol = pit_value_is_symbol(rt, fsym); + pit_annotated_ref *ann = pit_annotation_get(rt, pit_value_as_ref(rt, cur)); + if (is_symbol && pit_symtab_is_symbol_macro(rt, fsym)) { + pit_value f = pit_symtab_fget(rt, fsym); + pit_value args = pit_value_cons_cdr(rt, cur); + pit_value res = pit_value_apply(rt, f, args); + if (pit_vec_push(pit_value)(rt->expr_stack, res) < 0) + pit_error(rt, "macro expansion stack overflow"); + } else if (is_symbol && pit_symtab_symbol_name_match_cstr(rt, fsym, "defer")) { + pit_value args = pit_value_cons_cdr(rt, cur); + pit_runtime_eval_program_push_literal(rt, rt->program, pit_value_cons_car(rt, args)); + } else if (is_symbol && pit_symtab_symbol_name_match_cstr(rt, fsym, "quote")) { + pit_runtime_eval_program_push_literal(rt, rt->program, cur); + } else if (is_symbol && pit_symtab_symbol_name_match_cstr(rt, fsym, "lambda")) { + pit_value args = pit_value_cons_cdr(rt, cur); + pit_value bindings = pit_value_cons_car(rt, args); + pit_value body = pit_value_cons_cdr(rt, args); + i64 argcount = 0; + if (pit_vec_push(pit_value)(rt->expr_stack, pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "defer"), bindings)) < 0) + pit_error(rt, "macro expansion stack overflow"); + while (body != PIT_NIL) { + pit_value a = pit_value_cons_car(rt, body); + if (pit_vec_push(pit_value)(rt->expr_stack, a) < 0) + pit_error(rt, "macro expansion stack overflow"); + body = pit_value_cons_cdr(rt, body); + argcount += 1; + } + pit_runtime_eval_program_push_apply(rt, rt->program, argcount + 1, ann); + pit_runtime_eval_program_push_literal(rt, rt->program, fsym); + } else { + pit_value args = pit_value_cons_cdr(rt, cur); + i64 argcount = 0; + while (args != PIT_NIL) { + pit_value a = pit_value_cons_car(rt, args); + if (pit_vec_push(pit_value)(rt->expr_stack, a) < 0) + pit_error(rt, "macro expansion stack overflow"); + args = pit_value_cons_cdr(rt, args); + argcount += 1; + } + if (!is_symbol) { + if (pit_vec_push(pit_value)(rt->expr_stack, fsym) < 0) + pit_error(rt, "macro expansion stack overflow"); + } + pit_runtime_eval_program_push_apply(rt, rt->program, argcount, ann); + if (is_symbol) { + pit_runtime_eval_program_push_literal(rt, rt->program, fsym); + } + } + } else { + pit_runtime_eval_program_push_literal(rt, rt->program, cur); + } + } + for (i64 idx = rt->program->next - 1; idx >= program_reset; --idx) { + pit_runtime_eval_ins *ent = pit_vec_get(pit_runtime_eval_ins)(rt->program, idx); + if (ent == NULL) pit_error(rt, "macro expansion program invalid"); + if (rt->error != PIT_NIL) goto end; + switch (ent->sort) { + case PIT_RUNTIME_EVAL_INS_LITERAL: + if (pit_vec_push(pit_value)(rt->result_stack, ent->in.literal) < 0) + pit_error(rt, "macro expansion stack overflow"); + break; + case PIT_RUNTIME_EVAL_INS_APPLY: { + pit_value f = PIT_NIL; + pit_value args = PIT_NIL; + pit_value app = PIT_NIL; + if (pit_vec_pop(pit_value)(rt->result_stack, &f) < 0) + pit_error(rt, "macro expansion stack underflow"); + for (i64 i = 0; i < ent->in.apply.arity; ++i) { + pit_value a; + if (pit_vec_pop(pit_value)(rt->result_stack, &a) < 0) + pit_error(rt, "macro expansion stack underflow"); + args = pit_value_cons(rt, a, args); + } + app = pit_value_cons(rt, f, args); + if (ent->in.apply.annotation != NULL) { + pit_annotation_set(rt, pit_value_as_ref(rt, app), ent->in.apply.annotation->annotation); + } + if (pit_vec_push(pit_value)(rt->result_stack, app) < 0) + pit_error(rt, "macro expansion stack overflow"); + break; + } + default: + pit_error(rt, "unknown program entry"); + goto end; + } + } +end: { + pit_value ret = PIT_NIL; + if (pit_vec_pop(pit_value)(rt->result_stack, &ret) < 0) + pit_error(rt, "macro expansion stack underflow"); + rt->expr_stack->next = expr_stack_reset; + rt->result_stack->next = result_stack_reset; + rt->program->next = program_reset; + return ret; + } +} diff --git a/pit/src/runtime/symtab.c b/pit/src/runtime/symtab.c new file mode 100644 index 0000000..d2bc51e --- /dev/null +++ b/pit/src/runtime/symtab.c @@ -0,0 +1,118 @@ +#include <lcq/pit/runtime/symtab.h> + +pit_symtab_entry *pit_symtab_lookup(pit_runtime *rt, pit_value sym) { + pit_symbol s = pit_value_as_symbol(rt, sym); + return pit_vec_get(pit_symtab_entry)(rt->symtab, s); +} +pit_value pit_symtab_intern(pit_runtime *rt, u8 *nm, i64 len) { + if (rt->error != PIT_NIL) return PIT_NIL; + for (i64 sidx = 0; sidx < rt->symtab->next; ++sidx) { + pit_symtab_entry *sent = pit_vec_get(pit_symtab_entry)(rt->symtab, sidx); + if (sent == NULL) { pit_error(rt, "corrupted symbol table"); return PIT_NIL; } + if (pit_value_bytes_match(rt, sent->name, nm, len)) return pit_value_symbol_new(rt, sidx); + } + pit_symtab_entry ent; + ent.name = pit_value_bytes_new(rt, nm, len); + ent.value = PIT_NIL; + ent.function = PIT_NIL; + ent.is_macro = false; + ent.is_special_form = false; + ent.is_keyword = len >= 1 && nm[0] == ':'; + i64 idx = pit_vec_push(pit_symtab_entry)(rt->symtab, ent); + if (idx < 0) { pit_error(rt, "failed to allocate symtab entry"); return PIT_NIL; } + return pit_value_symbol_new(rt, idx); +} +pit_value pit_symtab_intern_cstr(pit_runtime *rt, char *nm) { + return pit_symtab_intern(rt, (u8 *) nm, (i64) pit_libc_string_strlen(nm)); +} +pit_value pit_symtab_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_symtab_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; } + return pit_value_bytes_match(rt, ent->name, buf, len); +} +bool pit_symtab_symbol_name_match_cstr(pit_runtime *rt, pit_value sym, char *s) { + return pit_symtab_symbol_name_match(rt, sym, (u8 *) s, (i64) pit_libc_string_strlen(s)); +} +pit_value pit_symtab_get_value_cell(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->value; +} +pit_value pit_symtab_get_function_cell(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->function; +} +pit_value pit_symtab_get(pit_runtime *rt, pit_value sym) { + return pit_value_cell_get(rt, pit_symtab_get_value_cell(rt, sym), sym); +} +void pit_symtab_set(pit_runtime *rt, pit_value sym, pit_value v) { + pit_symbol idx = pit_value_as_symbol(rt, sym); + if (idx < rt->frozen_symtab) { pit_error(rt, "attempted to modify frozen symbol"); return; } + pit_symtab_entry *ent = pit_symtab_lookup(rt, sym); + if (!ent) { pit_error(rt, "bad symbol"); return; } + if (pit_value_sort(ent->value) != PIT_VALUE_SORT_REF) { + ent->value = pit_value_cell_new(rt, PIT_NIL); + } + pit_value_cell_set(rt, ent->value, v, sym); +} +pit_value pit_symtab_fget(pit_runtime *rt, pit_value sym) { + return pit_value_cell_get(rt, pit_symtab_get_function_cell(rt, sym), sym); +} +void pit_symtab_fset(pit_runtime *rt, pit_value sym, pit_value v) { + pit_symbol idx = pit_value_as_symbol(rt, sym); + if (idx < rt->frozen_symtab) { pit_error(rt, "attempted to modify frozen symbol"); return; } + pit_symtab_entry *ent = pit_symtab_lookup(rt, sym); + if (!ent) { pit_error(rt, "bad symbol"); return; } + if (pit_value_sort(ent->function) != PIT_VALUE_SORT_REF) { + ent->function = pit_value_cell_new(rt, PIT_NIL); + } + pit_value_cell_set(rt, ent->function, v, sym); +} +bool pit_symtab_is_symbol_macro(pit_runtime *rt, pit_value sym) { + pit_symtab_entry *ent = pit_symtab_lookup(rt, sym); + if (!ent) { pit_error(rt, "bad symbol"); return false; } + return ent->is_macro; +} +void pit_symtab_symbol_mark_macro(pit_runtime *rt, pit_value sym) { + pit_symtab_entry *ent = pit_symtab_lookup(rt, sym); + if (!ent) { pit_error(rt, "bad symbol"); return; } + ent->is_macro = true; +} +void pit_symtab_mset(pit_runtime *rt, pit_value sym, pit_value v) { + pit_symtab_fset(rt, sym, v); + pit_symtab_symbol_mark_macro(rt, sym); +} +bool pit_symtab_is_symbol_special_form(pit_runtime *rt, pit_value sym) { + pit_symtab_entry *ent = pit_symtab_lookup(rt, sym); + if (!ent) { pit_error(rt, "bad symbol"); return false; } + return ent->is_special_form; +} +void pit_symtab_symbol_mark_special_form(pit_runtime *rt, pit_value sym) { + pit_symtab_entry *ent = pit_symtab_lookup(rt, sym); + if (!ent) { pit_error(rt, "bad symbol"); return; } + ent->is_special_form = true; +} +void pit_symtab_sfset(pit_runtime *rt, pit_value sym, pit_value v) { + pit_symtab_fset(rt, sym, v); + pit_symtab_symbol_mark_special_form(rt, sym); +} +void pit_symtab_bind(pit_runtime *rt, pit_value sym, pit_value cell) { + /* although we cannot set frozen symbols, we can still bind them temporarily - no need to check */ + pit_symtab_entry *ent = pit_symtab_lookup(rt, sym); + if (!ent) { pit_error(rt, "bad symbol"); return; } + if (pit_vec_push(pit_value)(rt->saved_bindings, ent->value) < 0) pit_error(rt, "binding stack overflow"); + ent->value = cell; +} +pit_value pit_symtab_unbind(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; } + pit_value old = ent->value; + if (pit_vec_pop(pit_value)(rt->saved_bindings, &ent->value) < 0) pit_error(rt, "binding stack underflow"); + return old; +} diff --git a/pit/src/runtime/value.c b/pit/src/runtime/value.c new file mode 100644 index 0000000..1e9d543 --- /dev/null +++ b/pit/src/runtime/value.c @@ -0,0 +1,76 @@ +#include <lcq/pit/runtime/value.h> + +pit_value pit_value_new(pit_runtime *rt, enum pit_value_sort s, u64 data) { + if (s == PIT_VALUE_SORT_DOUBLE) { + /* if (((data >> 52) & 0b011111111111) == 0b011111111111 && ((data >> 51) & 0b1) == 0) { */ + if (((data >> 52) & 0x7ff) == 0x7ff && ((data >> 51) & 1) == 0) { + pit_error(rt, "attempted to create a signalling NaN double"); + return PIT_NIL; + } + return data; + } + return + /* 0b1111111111110000000000000000000000000000000000000000000000000000 */ + 0xfff0000000000000 + /* | (((u64) (s & 0b11)) << 49) */ + | (((u64) (s & 3)) << 49) + /* | (data & 0b1111111111111111111111111111111111111111111111111); */ + | (data & 0x1ffffffffffff); +} + +bool pit_value_eq(pit_value a, pit_value b) { + return a == b; +} + +bool pit_value_equal(pit_runtime *rt, pit_value a, pit_value b) { + if (pit_value_sort(a) != pit_value_sort(b)) return false; + switch (pit_value_sort(a)) { + case PIT_VALUE_SORT_DOUBLE: + case PIT_VALUE_SORT_INTEGER: + case PIT_VALUE_SORT_SYMBOL: + return pit_value_data(a) == pit_value_data(b); + case PIT_VALUE_SORT_REF: { + pit_value_heavy *ha = pit_value_ref_deref(rt, pit_value_as_ref(rt, a)); + if (!ha) { pit_error(rt, "bad ref"); return false; } + pit_value_heavy *hb = pit_value_ref_deref(rt, pit_value_as_ref(rt, b)); + if (!hb) { pit_error(rt, "bad ref"); return false; } + if (ha->hsort != hb->hsort) return false; + switch (ha->hsort) { + case PIT_VALUE_HEAVY_SORT_CELL: + return pit_value_equal(rt, ha->in.cell, hb->in.cell); + case PIT_VALUE_HEAVY_SORT_CONS: + return pit_value_equal(rt, ha->in.cons.car, hb->in.cons.car) + && pit_value_equal(rt, ha->in.cons.cdr, hb->in.cons.cdr); + case PIT_VALUE_HEAVY_SORT_ARRAY: { + if (ha->in.array.len != hb->in.array.len) return false; + for (i64 i = 0; i < ha->in.array.len; ++i) { + if (!pit_value_equal(rt, ha->in.array.data[i], hb->in.array.data[i])) return false; + } + return true; + } + case PIT_VALUE_HEAVY_SORT_BYTES: { + if (ha->in.bytes.len != hb->in.bytes.len) return false; + for (i64 i = 0; i < ha->in.bytes.len; ++i) { + if (ha->in.bytes.data[i] != hb->in.bytes.data[i]) return false; + } + return true; + } + case PIT_VALUE_HEAVY_SORT_FUNC: + return + pit_value_equal(rt, ha->in.func.env, hb->in.func.env) + && pit_value_equal(rt, ha->in.func.args, hb->in.func.args) + && pit_value_equal(rt, ha->in.func.body, hb->in.func.body); + case PIT_VALUE_HEAVY_SORT_NATIVEFUNC: + return ha->in.nativefunc.f == hb->in.nativefunc.f + && ha->in.nativefunc.data == hb->in.nativefunc.data; + case PIT_VALUE_HEAVY_SORT_NATIVEDATA: + return + pit_value_eq(ha->in.nativedata.tag, hb->in.nativedata.tag) + && ha->in.nativedata.data == hb->in.nativedata.data; + case PIT_VALUE_HEAVY_SORT_FORWARDING_POINTER: + return ha->in.forwarding_pointer == hb->in.forwarding_pointer; + } + } + } + return false; +} diff --git a/pit/src/runtime/value/array.c b/pit/src/runtime/value/array.c new file mode 100644 index 0000000..1af84fd --- /dev/null +++ b/pit/src/runtime/value/array.c @@ -0,0 +1,57 @@ +#include <lcq/pit/runtime/value/array.h> + +bool pit_value_is_array(pit_runtime *rt, pit_value a) { + return pit_value_is_ref_heavy_sort(rt, a, PIT_VALUE_HEAVY_SORT_ARRAY); +} + +pit_value pit_value_array_new(pit_runtime *rt, i64 len) { + if (len < 0) { pit_error(rt, "failed to create array of negative size"); return PIT_NIL; } + i64 byte_len = 0; pit_mul(&byte_len, sizeof(pit_value), len); + pit_value *dest = pit_arena_alloc_array(rt->heap, byte_len); + if (!dest) { pit_error(rt, "failed to allocate array"); return PIT_NIL; } + for (i64 i = 0; i < len; ++i) dest[i] = PIT_NIL; + pit_value ret = pit_value_ref_heavy_new(rt); + pit_value_heavy *h = pit_value_ref_deref(rt, pit_value_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_value_array_from_buf(pit_runtime *rt, pit_value *xs, i64 len) { + pit_value ret = pit_value_array_new(rt, len); + pit_value_heavy *h = pit_value_ref_deref(rt, pit_value_as_ref(rt, ret)); + if (!h) { pit_error(rt, "failed to deref heavy value for array"); return PIT_NIL; } + pit_libc_string_memcpy((u8 *) h->in.array.data, (u8 *) xs, (size_t) len * (size_t) sizeof(pit_value)); + return ret; +} +i64 pit_value_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_value_ref_deref(rt, pit_value_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_value_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_value_ref_deref(rt, pit_value_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_value_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_value_ref_deref(rt, pit_value_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; +} diff --git a/pit/src/runtime/value/bytes.c b/pit/src/runtime/value/bytes.c new file mode 100644 index 0000000..6a6edb6 --- /dev/null +++ b/pit/src/runtime/value/bytes.c @@ -0,0 +1,47 @@ +#include <lcq/pit/runtime/value/bytes.h> + +bool pit_value_is_bytes(pit_runtime *rt, pit_value a) { + return pit_value_is_ref_heavy_sort(rt, a, PIT_VALUE_HEAVY_SORT_BYTES); +} +pit_value pit_value_bytes_new(pit_runtime *rt, u8 *buf, i64 len) { + u8 *dest = pit_arena_alloc_back(rt->heap, len); + if (!dest) { pit_error(rt, "failed to allocate bytes"); return PIT_NIL; } + pit_libc_string_memcpy(dest, buf, (size_t) len); + pit_value ret = pit_value_ref_heavy_new(rt); + pit_value_heavy *h = pit_value_ref_deref(rt, pit_value_as_ref(rt, ret)); + if (!h) { pit_error(rt, "failed to create new heavy value for bytes"); return PIT_NIL; } + h->hsort = PIT_VALUE_HEAVY_SORT_BYTES; + h->in.bytes.data = dest; + h->in.bytes.len = len; + return ret; +} +pit_value pit_value_bytes_new_cstr(pit_runtime *rt, char *s) { + return pit_value_bytes_new(rt, (u8 *) s, (i64) pit_libc_string_strlen(s)); +} +/* return true if v is a reference to bytes that are the same as those in buf */ +bool pit_value_bytes_match(pit_runtime *rt, pit_value v, u8 *buf, i64 len) { + if (pit_value_sort(v) != PIT_VALUE_SORT_REF) return false; + pit_value_heavy *h = pit_value_ref_deref(rt, pit_value_as_ref(rt, v)); + if (!h) { pit_error(rt, "bad ref"); return false; } + if (h->hsort != PIT_VALUE_HEAVY_SORT_BYTES) return false; + if (h->in.bytes.len != len) return false; + for (i64 i = 0; i < len; ++i) + if (h->in.bytes.data[i] != buf[i]) { + return false; + } + return true; +} +i64 pit_value_bytes_copy(pit_runtime *rt, pit_value v, u8 *buf, i64 maxlen) { + if (pit_value_sort(v) != PIT_VALUE_SORT_REF) { pit_error(rt, "not a ref"); return -1; } + pit_value_heavy *h = pit_value_ref_deref(rt, pit_value_as_ref(rt, v)); + if (!h) { pit_error(rt, "bad ref"); return -1; } + if (h->hsort != PIT_VALUE_HEAVY_SORT_BYTES) { + pit_error(rt, "invalid use of value as bytes"); + return -1; + } + i64 len = maxlen < h->in.bytes.len ? maxlen : h->in.bytes.len; + for (i64 i = 0; i < len; ++i) { + buf[i] = h->in.bytes.data[i]; + } + return len; +} diff --git a/pit/src/runtime/value/cell.c b/pit/src/runtime/value/cell.c new file mode 100644 index 0000000..34b9226 --- /dev/null +++ b/pit/src/runtime/value/cell.c @@ -0,0 +1,47 @@ +#include <lcq/pit/runtime/value/cell.h> + +bool pit_value_is_cell(pit_runtime *rt, pit_value a) { + return pit_value_is_ref_heavy_sort(rt, a, PIT_VALUE_HEAVY_SORT_CELL); +} +pit_value pit_value_cell_new(pit_runtime *rt, pit_value v) { + pit_value ret = pit_value_ref_heavy_new(rt); + pit_value_heavy *h = pit_value_ref_deref(rt, pit_value_as_ref(rt, ret)); + if (!h) { pit_error(rt, "failed to create new heavy value for cell"); return PIT_NIL; } + h->hsort = PIT_VALUE_HEAVY_SORT_CELL; + h->in.cell = v; + return ret; +} +pit_value pit_value_cell_get(pit_runtime *rt, pit_value cell, pit_value sym) { + if (pit_value_sort(cell) != PIT_VALUE_SORT_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_value_ref_deref(rt, pit_value_as_ref(rt, cell)); + if (!h) { pit_error(rt, "bad ref"); return PIT_NIL; } + if (h->hsort != PIT_VALUE_HEAVY_SORT_CELL) { + pit_error(rt, "cell value ref does not point to cell"); + return PIT_NIL; + } + return h->in.cell; +} +void pit_value_cell_set(pit_runtime *rt, pit_value cell, pit_value v, pit_value sym) { + if (pit_value_sort(cell) != PIT_VALUE_SORT_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_value_as_ref(rt, cell); + if (idx < rt->frozen_values) { pit_error(rt, "attempt to modify frozen cell"); return; } + pit_value_heavy *h = pit_value_ref_deref(rt, idx); + if (!h) { pit_error(rt, "bad ref"); return; } + if (h->hsort != PIT_VALUE_HEAVY_SORT_CELL) { + pit_error(rt, "cell value ref does not point to cell"); + return; + } + h->in.cell = v; +} diff --git a/pit/src/runtime/value/cons.c b/pit/src/runtime/value/cons.c new file mode 100644 index 0000000..0f35631 --- /dev/null +++ b/pit/src/runtime/value/cons.c @@ -0,0 +1,110 @@ +#include <lcq/pit/runtime/value/cons.h> + +bool pit_value_is_cons(pit_runtime *rt, pit_value a) { + return pit_value_is_ref_heavy_sort(rt, a, PIT_VALUE_HEAVY_SORT_CONS); +} +pit_value pit_value_cons(pit_runtime *rt, pit_value car, pit_value cdr) { + pit_value ret = pit_value_ref_heavy_new(rt); + pit_value_heavy *h = pit_value_ref_deref(rt, pit_value_as_ref(rt, ret)); + if (!h) { pit_error(rt, "failed to create new heavy value for cons"); return PIT_NIL; } + h->hsort = PIT_VALUE_HEAVY_SORT_CONS; + h->in.cons.car = car; + h->in.cons.cdr = cdr; + return ret; +} +pit_value pit_value_cons_car(pit_runtime *rt, pit_value v) { + if (pit_value_sort(v) != PIT_VALUE_SORT_REF) return PIT_NIL; + pit_value_heavy *h = pit_value_ref_deref(rt, pit_value_as_ref(rt, v)); + if (!h) { pit_error(rt, "bad ref"); return PIT_NIL; } + if (h->hsort != PIT_VALUE_HEAVY_SORT_CONS) return PIT_NIL; + return h->in.cons.car; +} +pit_value pit_value_cons_cdr(pit_runtime *rt, pit_value v) { + if (pit_value_sort(v) != PIT_VALUE_SORT_REF) return PIT_NIL; + pit_value_heavy *h = pit_value_ref_deref(rt, pit_value_as_ref(rt, v)); + if (!h) { pit_error(rt, "bad ref"); return PIT_NIL; } + if (h->hsort != PIT_VALUE_HEAVY_SORT_CONS) return PIT_NIL; + return h->in.cons.cdr; +} +void pit_value_cons_setcar(pit_runtime *rt, pit_value v, pit_value x) { + if (pit_value_sort(v) != PIT_VALUE_SORT_REF) { pit_error(rt, "not a ref"); return; } + pit_ref idx = pit_value_as_ref(rt, v); + if (idx < rt->frozen_values) { pit_error(rt, "attempted to modify frozen cons"); return; } + pit_value_heavy *h = pit_value_ref_deref(rt, idx); + if (!h) { pit_error(rt, "bad ref"); return; } + if (h->hsort != PIT_VALUE_HEAVY_SORT_CONS) { pit_error(rt, "not a cons"); return; } + h->in.cons.car = x; +} +void pit_value_cons_setcdr(pit_runtime *rt, pit_value v, pit_value x) { + if (pit_value_sort(v) != PIT_VALUE_SORT_REF) { pit_error(rt, "not a ref"); return; } + pit_ref idx = pit_value_as_ref(rt, v); + if (idx < rt->frozen_values) { pit_error(rt, "attempted to modify frozen cons"); return; } + pit_value_heavy *h = pit_value_ref_deref(rt, idx); + if (!h) { pit_error(rt, "bad ref"); return; } + if (h->hsort != PIT_VALUE_HEAVY_SORT_CONS) { pit_error(rt, "not a cons"); return; } + h->in.cons.cdr = x; +} + +pit_value pit_value_list(pit_runtime *rt, i64 num, ...) { + pit_value temp[64] = {0}; + pit_value ret = PIT_NIL; + if (num > 64) { pit_error(rt, "failed to create list of size %d\n", num); return PIT_NIL; } + va_list elems; + va_start(elems, num); + for (i64 i = 0; i < num; ++i) { + temp[i] = va_arg(elems, pit_value); + } + va_end(elems); + for (i64 i = 0; i < num; ++i) { + ret = pit_value_cons(rt, temp[num - i - 1], ret); + } + return ret; +} +i64 pit_value_list_len(pit_runtime *rt, pit_value xs) { + i64 ret = 0; + while (xs != PIT_NIL) { + ret += 1; + xs = pit_value_cons_cdr(rt, xs); + } + return ret; +} +pit_value pit_value_list_append(pit_runtime *rt, pit_value xs, pit_value ys) { + pit_value ret = ys; + xs = pit_value_list_reverse(rt, xs); + while (xs != PIT_NIL) { + ret = pit_value_cons(rt, pit_value_cons_car(rt, xs), ret); + xs = pit_value_cons_cdr(rt, xs); + } + return ret; +} +pit_value pit_value_list_reverse(pit_runtime *rt, pit_value xs) { + pit_value ret = PIT_NIL; + while (xs != PIT_NIL) { + ret = pit_value_cons(rt, pit_value_cons_car(rt, xs), ret); + xs = pit_value_cons_cdr(rt, xs); + } + return ret; +} +pit_value pit_value_list_contains_eq(pit_runtime *rt, pit_value needle, pit_value haystack) { + while (haystack != PIT_NIL) { + if (pit_value_eq(needle, pit_value_cons_car(rt, haystack))) return PIT_T; + haystack = pit_value_cons_cdr(rt, haystack); + } + return PIT_NIL; +} +pit_value pit_value_list_contains_equal(pit_runtime *rt, pit_value needle, pit_value haystack) { + while (haystack != PIT_NIL) { + if (pit_value_equal(rt, needle, pit_value_cons_car(rt, haystack))) return PIT_T; + haystack = pit_value_cons_cdr(rt, haystack); + } + return PIT_NIL; +} +pit_value pit_value_list_plist_get(pit_runtime *rt, pit_value k, pit_value vs) { + while (vs != PIT_NIL) { + if (pit_value_eq(k, pit_value_cons_car(rt, vs))) { + return pit_value_cons_car(rt, pit_value_cons_cdr(rt, vs)); + } + vs = pit_value_cons_cdr(rt, vs); + } + return PIT_NIL; +} diff --git a/pit/src/runtime/value/func.c b/pit/src/runtime/value/func.c new file mode 100644 index 0000000..af039eb --- /dev/null +++ b/pit/src/runtime/value/func.c @@ -0,0 +1,177 @@ +#include <lcq/pit/runtime/value/func.h> + +static pit_value free_vars(pit_runtime *rt, pit_value initial_bound, pit_value body) { + i64 expr_stack_reset = rt->expr_stack->next; + pit_value ret = PIT_NIL; + if (pit_vec_push(pit_value)(rt->expr_stack, pit_value_cons(rt, initial_bound, body)) < 0) { + pit_error(rt, "free variable search stack overflow"); + return PIT_NIL; + } + while (rt->expr_stack->next > expr_stack_reset) { + pit_value boundscur, bound, cur; + if (pit_vec_pop(pit_value)(rt->expr_stack, &boundscur) < 0) { + pit_error(rt, "free variable search stack underflow"); + return PIT_NIL; + } + bound = pit_value_cons_car(rt, boundscur); + cur = pit_value_cons_cdr(rt, boundscur); + if (pit_value_is_cons(rt, cur)) { + pit_value fsym = pit_value_cons_car(rt, cur); + bool is_symbol = pit_value_is_symbol(rt, fsym); + pit_value fargs = pit_value_cons_cdr(rt, cur); + if (is_symbol && pit_symtab_symbol_name_match_cstr(rt, fsym, "lambda")) { + pit_value new_bound = pit_value_list_append(rt, pit_value_cons_car(rt, fargs), bound); + fargs = pit_value_cons_cdr(rt, fargs); + while (fargs != PIT_NIL) { + if (pit_vec_push(pit_value)(rt->expr_stack, pit_value_cons(rt, new_bound, pit_value_cons_car(rt, fargs))) < 0) { + pit_error(rt, "free variable search stack overflow"); + return PIT_NIL; + } + fargs = pit_value_cons_cdr(rt, fargs); + } + } else if (is_symbol && pit_symtab_symbol_name_match_cstr(rt, fsym, "quote")) { + /* don't look inside quote! + if we add other special forms, make sure to consider them here if necessary! */ + } else { + while (fargs != PIT_NIL) { + if (pit_vec_push(pit_value)(rt->expr_stack, pit_value_cons(rt, bound, pit_value_cons_car(rt, fargs))) < 0) { + pit_error(rt, "free variable search stack overflow"); + return PIT_NIL; + } + fargs = pit_value_cons_cdr(rt, fargs); + } + if (!is_symbol) { + if (pit_vec_push(pit_value)(rt->expr_stack, pit_value_cons(rt, bound, fsym)) < 0) { + pit_error(rt, "free variable search stack overflow"); + return PIT_NIL; + } + } + } + } else if (pit_value_is_symbol(rt, cur)) { + if (pit_value_list_contains_eq(rt, cur, bound) == PIT_NIL) { + ret = pit_value_cons(rt, cur, ret); + } + } + } + rt->expr_stack->next = expr_stack_reset; + return ret; +} + +bool pit_value_is_func(pit_runtime *rt, pit_value a) { + return pit_value_is_ref_heavy_sort(rt, a, PIT_VALUE_HEAVY_SORT_FUNC); +} +bool pit_value_is_nativefunc(pit_runtime *rt, pit_value a) { + return pit_value_is_ref_heavy_sort(rt, a, PIT_VALUE_HEAVY_SORT_NATIVEFUNC); +} +pit_value pit_value_func_lambda(pit_runtime *rt, pit_value args, pit_value body) { + pit_value ret = pit_value_ref_heavy_new(rt); + pit_value_heavy *h = pit_value_ref_deref(rt, pit_value_as_ref(rt, ret)); + if (!h) { pit_error(rt, "failed to create new heavy value for lambda"); return PIT_NIL; } + pit_value expanded = pit_macroexpand(rt, pit_value_cons(rt, pit_symtab_intern_cstr(rt, "progn"), body)); + pit_value freevars = free_vars(rt, args, expanded); + pit_value env = PIT_NIL; + while (freevars != PIT_NIL) { + pit_value sym = pit_value_cons_car(rt, freevars); + pit_value cell = pit_symtab_get_value_cell(rt, sym); + env = pit_value_cons(rt, pit_value_cons(rt, sym, cell), env); + freevars = pit_value_cons_cdr(rt, freevars); + } + h->hsort = PIT_VALUE_HEAVY_SORT_FUNC; + pit_value arg_cells = PIT_NIL; + pit_value arg_rest_nm = PIT_NIL; + pit_value separator = pit_symtab_intern_cstr(rt, "&"); + while (args != PIT_NIL) { + pit_value nm = pit_value_cons_car(rt, args); + if (pit_value_eq(nm, separator)) { + pit_value next_nm = pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)); + if (next_nm == PIT_NIL) { pit_error(rt, "invalid & in lambda list"); return PIT_NIL; } + arg_rest_nm = next_nm; + arg_cells = pit_value_cons(rt, next_nm, arg_cells); + break; + } else { + arg_cells = pit_value_cons(rt, nm, arg_cells); + args = pit_value_cons_cdr(rt, args); + } + } + arg_cells = pit_value_list_reverse(rt, arg_cells); + h->in.func.args = arg_cells; + h->in.func.arg_rest_nm = arg_rest_nm; + h->in.func.env = env; + h->in.func.body = expanded; + return ret; +} +pit_value pit_value_nativefunc_new_with_data(pit_runtime *rt, pit_nativefunc f, void *data) { + pit_value ret = pit_value_ref_heavy_new(rt); + pit_value_heavy *h = pit_value_ref_deref(rt, pit_value_as_ref(rt, ret)); + if (!h) { pit_error(rt, "failed to create new heavy value for nativefunc"); return PIT_NIL; } + h->hsort = PIT_VALUE_HEAVY_SORT_NATIVEFUNC; + h->in.nativefunc.f = f; + h->in.nativefunc.data = data; + return ret; +} +pit_value pit_value_nativefunc_new(pit_runtime *rt, pit_nativefunc f) { + return pit_value_nativefunc_new_with_data(rt, f, NULL); +} +pit_value pit_value_apply(pit_runtime *rt, pit_value f, pit_value args) { + char buf[256] = {0}; + if (pit_value_is_symbol(rt, f)) { + f = pit_symtab_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_value_ref_deref(rt, pit_value_as_ref(rt, f)); + if (!h) { pit_error(rt, "bad ref"); return PIT_NIL; } + if (h->hsort == PIT_VALUE_HEAVY_SORT_FUNC) { + /* calling a Lisp function is simple! */ + pit_value bound = PIT_NIL; + pit_value env = h->in.func.env; + while (env != PIT_NIL) { /* first, bind all entries in the closure */ + pit_value b = pit_value_cons_car(rt, env); + pit_value nm = pit_value_cons_car(rt, b); + pit_symtab_bind(rt, nm, pit_value_cons_cdr(rt, b)); + bound = pit_value_cons(rt, nm, bound); + env = pit_value_cons_cdr(rt, env); + } + pit_value anames = h->in.func.args; + while (anames != PIT_NIL) { /* bind all argument names to their values */ + pit_value nm = pit_value_cons_car(rt, anames); + pit_value cell = pit_value_cell_new(rt, PIT_NIL); + if (h->in.func.arg_rest_nm != PIT_NIL && pit_value_eq(nm, h->in.func.arg_rest_nm)) { + pit_value_cell_set(rt, cell, args, nm); + pit_symtab_bind(rt, nm, cell); + break; + } else { + pit_value_cell_set(rt, cell, pit_value_cons_car(rt, args), nm); + pit_symtab_bind(rt, nm, cell); + } + bound = pit_value_cons(rt, nm, bound); + args = pit_value_cons_cdr(rt, args); + anames = pit_value_cons_cdr(rt, anames); + } + pit_value ret = pit_eval(rt, h->in.func.body); /* evaluate the body */ + while (bound != PIT_NIL) { /* unbind everything we bound earlier, in reverse */ + pit_symtab_unbind(rt, pit_value_cons_car(rt, bound)); + bound = pit_value_cons_cdr(rt, bound); + } + return ret; + } else if (h->hsort == PIT_VALUE_HEAVY_SORT_NATIVEFUNC) { + /* calling native functions is even simpler */ + return h->in.nativefunc.f(rt, args, h->in.nativefunc.data); + } else { + i64 end = pit_dump(rt, buf, sizeof(buf) - 1, f, true); + buf[end] = 0; + pit_error(rt, "attempted to apply non-function ref: %s", buf); + return PIT_NIL; + } + } + default: { + i64 end = pit_dump(rt, buf, sizeof(buf) - 1, f, true); + buf[end] = 0; + pit_error(rt, "attempted to apply non-function value: %s", buf); + return PIT_NIL; + } + } +} diff --git a/pit/src/runtime/value/nativedata.c b/pit/src/runtime/value/nativedata.c new file mode 100644 index 0000000..5c6fe2b --- /dev/null +++ b/pit/src/runtime/value/nativedata.c @@ -0,0 +1,36 @@ +#include <lcq/pit/runtime/value/nativedata.h> + +bool pit_value_is_nativedata(pit_runtime *rt, pit_value a) { + return pit_value_is_ref_heavy_sort(rt, a, PIT_VALUE_HEAVY_SORT_NATIVEDATA); +} +pit_value pit_value_nativedata_new(pit_runtime *rt, pit_value tag, void *d) { + pit_value ret = pit_value_ref_heavy_new(rt); + pit_value_heavy *h = pit_value_ref_deref(rt, pit_value_as_ref(rt, ret)); + if (!h) { pit_error(rt, "failed to create new heavy value for nativedata"); return PIT_NIL; } + h->hsort = PIT_VALUE_HEAVY_SORT_NATIVEDATA; + h->in.nativedata.tag = tag; + h->in.nativedata.data = d; + return ret; +} +void *pit_value_nativedata_get(pit_runtime *rt, pit_value tag, pit_value v) { + pit_value_heavy *h = NULL; + if (pit_value_sort(v) != PIT_VALUE_SORT_REF) { + pit_error(rt, "value was not a reference"); + return NULL; + } + h = pit_value_ref_deref(rt, pit_value_as_ref(rt, v)); + if (!h) { pit_error(rt, "bad ref"); return NULL; } + if (h->hsort != PIT_VALUE_HEAVY_SORT_NATIVEDATA) { + pit_error(rt, "invalid use of value as nativedata"); + return NULL; + } + if (!pit_value_eq(h->in.nativedata.tag, tag)) { + pit_error(rt, "native value does not match tag"); + return NULL; + } + if (!h->in.nativedata.data) { + pit_error(rt, "nativedata was already freed"); + return NULL; + } + return h->in.nativedata.data; +} diff --git a/pit/src/runtime/value/small.c b/pit/src/runtime/value/small.c new file mode 100644 index 0000000..f07e405 --- /dev/null +++ b/pit/src/runtime/value/small.c @@ -0,0 +1,96 @@ +#include <lcq/pit/runtime/value/small.h> + +#ifndef PIT_NO_DOUBLE +double pit_value_as_double(pit_runtime *rt, pit_value v) { + if (pit_value_sort(v) != PIT_VALUE_SORT_DOUBLE) { + pit_error(rt, "invalid use of value as double"); + return 0.0; + } + union { double dval; u64 ival; } x; + x.ival = v; + return x.dval; +} +bool pit_value_is_double(pit_runtime *rt, pit_value a) { + (void) rt; + return pit_value_sort(a) == PIT_VALUE_SORT_DOUBLE; +} +pit_value pit_value_double_new(pit_runtime *rt, double d) { + union { double dval; u64 ival; } x; + x.dval = d; + return pit_value_new(rt, PIT_VALUE_SORT_DOUBLE, x.ival); +} +#endif + +i64 pit_value_as_integer(pit_runtime *rt, pit_value v) { + if (pit_value_sort(v) != PIT_VALUE_SORT_INTEGER) { + pit_error(rt, "invalid use of value as integer"); + return -1; + } + u64 lo = pit_value_data(v); + return ((i64) (lo << 15)) >> 15; /* sign-extend low 49 bits */ + +} +bool pit_value_is_integer(pit_runtime *rt, pit_value a) { + (void) rt; + return pit_value_sort(a) == PIT_VALUE_SORT_INTEGER; +} +pit_value pit_value_integer_new(pit_runtime *rt, i64 i) { + return pit_value_new(rt, PIT_VALUE_SORT_INTEGER, 0x1ffffffffffff & (u64) i); +} +pit_value pit_value_bool_new(pit_runtime *rt, bool i) { + (void) rt; + return i ? PIT_T : PIT_NIL; +} + +pit_symbol pit_value_as_symbol(pit_runtime *rt, pit_value v) { + if (pit_value_sort(v) != PIT_VALUE_SORT_SYMBOL) { + pit_error(rt, "invalid use of value as symbol"); + return -1; + } + return (pit_symbol) (pit_value_data(v) & 0xffffffff); +} +bool pit_value_is_symbol(pit_runtime *rt, pit_value a) { + (void) rt; + return pit_value_sort(a) == PIT_VALUE_SORT_SYMBOL; +} +pit_value pit_value_symbol_new(pit_runtime *rt, pit_symbol s) { + return pit_value_new(rt, PIT_VALUE_SORT_SYMBOL, (u64) s); +} + +pit_ref pit_value_as_ref(pit_runtime *rt, pit_value v) { + if (pit_value_sort(v) != PIT_VALUE_SORT_REF) { + pit_error(rt, "invalid use of value as ref"); + return -1; + } + return (pit_ref) (pit_value_data(v) & 0xffffffff); +} +bool pit_value_is_ref(pit_runtime *rt, pit_value a) { + (void) rt; + return pit_value_sort(a) == PIT_VALUE_SORT_REF; +} +pit_value pit_value_ref_new(pit_runtime *rt, pit_ref r) { + return pit_value_new(rt, PIT_VALUE_SORT_REF, (u64) r); +} +pit_value pit_value_ref_heavy_new(pit_runtime *rt) { + pit_arena_index idx = pit_arena_alloc_index(rt->heap); + if (idx < 0) { + pit_error(rt, "failed to allocate space for heavy value"); + return PIT_NIL; + } + return pit_value_ref_new(rt, idx); +} +pit_value_heavy *pit_value_ref_deref(pit_runtime *rt, pit_ref p) { + return pit_arena_get(rt->heap, p); +} +bool pit_value_is_ref_heavy_sort(pit_runtime *rt, pit_value a, enum pit_value_heavy_sort e) { + switch (pit_value_sort(a)) { + case PIT_VALUE_SORT_REF: { + pit_value_heavy *ha = pit_value_ref_deref(rt, pit_value_as_ref(rt, a)); + if (!ha) { pit_error(rt, "bad ref"); return false; } + return ha->hsort == e; + } + default: + break; + } + return false; +} diff --git a/pit/src/utils.c b/pit/src/utils.c new file mode 100644 index 0000000..75d59a6 --- /dev/null +++ b/pit/src/utils.c @@ -0,0 +1,101 @@ +#include <lcq/pit/utils.h> + +enum vsnprintf_mode { + VSNPRINTF_MODE_NORMAL, + VSNPRINTF_MODE_FLAGS, + VSNPRINTF_MODE_WIDTH, + VSNPRINTF_MODE_PRECISION, + VSNPRINTF_MODE_LENGTH_MOD, + VSNPRINTF_MODE_CONVERSION_SPEC +}; +#define SCRATCH_LEN 256 +#define WRITE(c) { buf[idx++] = c; if (idx >= len - 1) goto done; } +#define WRITE_SCRATCH(c) { scratch[sidx++] = c; if (sidx >= SCRATCH_LEN) goto error; } +int pit_libc_string_vsnprintf(char *buf, size_t len, char *format, va_list ap) { + // vsnprintf + size_t idx = 0; + size_t flen = pit_libc_string_strlen(format); + size_t fidx = 0; + enum vsnprintf_mode mode = VSNPRINTF_MODE_NORMAL; + size_t sidx = 0; + char scratch[SCRATCH_LEN] = {0}; + char length_mod = 0; + for (; fidx < flen && idx < len - 1; ++fidx) { + char c = format[fidx]; + sidx = 0; + switch (mode) { + case VSNPRINTF_MODE_NORMAL: + if (c == '%') { + mode = VSNPRINTF_MODE_FLAGS; + } else WRITE(c); + break; + case VSNPRINTF_MODE_FLAGS: + case VSNPRINTF_MODE_WIDTH: + case VSNPRINTF_MODE_PRECISION: + case VSNPRINTF_MODE_LENGTH_MOD: + switch (c) { + case 'l': length_mod = 'l'; mode = VSNPRINTF_MODE_CONVERSION_SPEC; continue; + } + // fallthrough + case VSNPRINTF_MODE_CONVERSION_SPEC: + switch (c) { + case '%': WRITE('%'); mode = VSNPRINTF_MODE_NORMAL; break; + case 'd': { + long arg = 0; + if (length_mod == 'l') arg = va_arg(ap, long); else arg = va_arg(ap, int); + if (arg == 0) { WRITE('0') } + else { + if (arg < 0) { WRITE('-'); arg = -arg; } + while (arg != 0) { WRITE_SCRATCH('0' + (char) (arg % 10)); arg /= 10; } + while (sidx > 0) { WRITE(scratch[sidx - 1]); sidx -= 1; } + } + mode = VSNPRINTF_MODE_NORMAL; + break; + } + case 'f': { + double arg = 0.0; + if (length_mod == 'l') + arg = va_arg(ap, double); + else + arg = va_arg(ap, double); + long wholepart = (long) arg; + double fracpart = arg - (double) wholepart; + if (wholepart == 0) { WRITE('0') } + else { + while (wholepart != 0) { WRITE_SCRATCH('0' + (char) (wholepart % 10)); wholepart /= 10; } + while (sidx > 0) { WRITE(scratch[sidx - 1]); sidx -= 1; } + } + WRITE('.'); + for (int i = 0; i < 6; ++i) { + fracpart *= 10.0; + wholepart = (long) fracpart; + fracpart -= (double) wholepart; + WRITE('0' + (char) wholepart); + } + mode = VSNPRINTF_MODE_NORMAL; + break; + } + case 's': { + char *arg = va_arg(ap, char *); + while (*arg != 0) { WRITE(*arg); arg += 1; } + mode = VSNPRINTF_MODE_NORMAL; + break; + } + default: goto error; + } + break; + } + } +done: + buf[idx] = 0; + return (int) idx; +error: + return -1; +} +int pit_libc_string_snprintf(char *buf, size_t len, char *format, ...) { + va_list ap; + va_start(ap, format); + int ret = pit_libc_string_vsnprintf(buf, len, format, ap); + va_end(ap); + return ret; +} diff --git a/pit/test/array.lisp b/pit/test/array.lisp new file mode 100644 index 0000000..976f70d --- /dev/null +++ b/pit/test/array.lisp @@ -0,0 +1,2 @@ +(print! (array/repeat 'foo 1000)) +(array/repeat 'foo 10000) diff --git a/pit/test/bif.pit b/pit/test/bif.pit new file mode 100644 index 0000000..81a1248 --- /dev/null +++ b/pit/test/bif.pit @@ -0,0 +1,12 @@ +(print! nil) +(print! nil) +(print! t) +(print! (eq? 1 1)) +(diagnostics!) +(defun! bif (x) + (cons x x)) +(diagnostics!) +(setq! foo (print! (bif (bif (bif 67))))) +(print! (eq? (car foo) (cdr foo))) +(diagnostics!) +(print! foo) diff --git a/pit/test/broken.lisp b/pit/test/broken.lisp new file mode 100644 index 0000000..09f4afc --- /dev/null +++ b/pit/test/broken.lisp @@ -0,0 +1,5 @@ +;; (let ((foo (+ 1 1))) +;; (print! foo)) +((lambda (foo) + (print! foo)) + (+ 1 1)) diff --git a/pit/test/error.pit b/pit/test/error.pit new file mode 100644 index 0000000..58b7d99 --- /dev/null +++ b/pit/test/error.pit @@ -0,0 +1 @@ +(print! "hello") diff --git a/pit/test/error2.pit b/pit/test/error2.pit new file mode 100644 index 0000000..63ab173 --- /dev/null +++ b/pit/test/error2.pit @@ -0,0 +1,4 @@ +(defun! foo () + (error! "yuck")) + +(foo) diff --git a/pit/test/fold.lisp b/pit/test/fold.lisp new file mode 100644 index 0000000..89031d0 --- /dev/null +++ b/pit/test/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/pit/test/gc.pit b/pit/test/gc.pit new file mode 100644 index 0000000..28eed50 --- /dev/null +++ b/pit/test/gc.pit @@ -0,0 +1,13 @@ +(diagnostics!) +(setq! foo (cons 1 2)) +(setq! bar (cons foo 3)) +(setq! baz (cons bar foo)) +(diagnostics!) +(print! foo) +(setcar! foo baz) +(print! (cdr (car (car foo)))) +(diagnostics!) +(setq! foo nil) +(setq! bar nil) +(setq! baz nil) +(diagnostics!) diff --git a/pit/test/int.pit b/pit/test/int.pit new file mode 100644 index 0000000..65646af --- /dev/null +++ b/pit/test/int.pit @@ -0,0 +1 @@ +(print! 0x10) diff --git a/pit/test/nonbroken.lisp b/pit/test/nonbroken.lisp new file mode 100644 index 0000000..350f64f --- /dev/null +++ b/pit/test/nonbroken.lisp @@ -0,0 +1,2 @@ +(+ 1 + (fwefwfwfwe 1 1)) diff --git a/pit/test/struct.lisp b/pit/test/struct.lisp new file mode 100644 index 0000000..9e35654 --- /dev/null +++ b/pit/test/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/pit/test/test.lisp b/pit/test/test.lisp new file mode 100644 index 0000000..ef13abb --- /dev/null +++ b/pit/test/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/pit/test/test2.lisp b/pit/test/test2.lisp new file mode 100644 index 0000000..79a9791 --- /dev/null +++ b/pit/test/test2.lisp @@ -0,0 +1 @@ +(print "hello from test2") diff --git a/pit/test/test3.lisp b/pit/test/test3.lisp new file mode 100644 index 0000000..2febb75 --- /dev/null +++ b/pit/test/test3.lisp @@ -0,0 +1,7 @@ +(let ((bs (bs/new!))) + (print! bs) + (bs/grow! 1 bs) + (bs/write8! bs 0 67) + (bs/spit! "test3.bin" bs) + ;; (bs/delete! bs) + ) diff --git a/pit/test/thebug.lisp b/pit/test/thebug.lisp new file mode 100644 index 0000000..ad87bd7 --- /dev/null +++ b/pit/test/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/pit/test/thebug2.lisp b/pit/test/thebug2.lisp new file mode 100644 index 0000000..2376ff8 --- /dev/null +++ b/pit/test/thebug2.lisp @@ -0,0 +1,13 @@ + +(setq! z 40) +(setq! f + (lambda (x) + (lambda (y) + (lambda (w) + (+ + (funcall (lambda (z) (+ x y z)) 3) + w + z))))) +(let ((z 20)) + (print! (funcall (funcall (funcall f 1) 2) 3))) + diff --git a/pit/test/x86.pit b/pit/test/x86.pit new file mode 100644 index 0000000..2aa8d89 --- /dev/null +++ b/pit/test/x86.pit @@ -0,0 +1,451 @@ +(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 ((leftover (bitwise/rshift x bits))) + (eq? leftover 0)))) +(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 + ((eq? (car disp) 1) (list (cdr disp))) + ((eq? (car disp) 4) (x86/split32le (cdr disp))) + (t (error! "malformed displacement for instruction")))) + (if imm + (cond + ((eq? (car imm) 1) (list (cdr imm))) + ((eq? (car imm) 2) (x86/split16le (cdr imm))) + ((eq? (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 (if (>= esz 4) 4 esz))) + (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 (eq? 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-operand-base op)) + (off (x86/memory-operand-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." + (let ( (posthook (plist/get :posthook kwargs)) + (default-size (plist/get :default-size kwargs))) + (lambda (pats ops) + (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/instruction-handler-jcc (opcode immsz) + "Return an instruction handler for a Jcc instruction at OPCODE. +IMMSZ is the size of the displacement from RIP." + (lambda (_pats ops) + (let ((ret (x86/ins/new :opcode opcode))) + (x86/ins/set-disp! ret (cons immsz (car ops))) + ret))) + +(defun! x86/generate-handlers-arith (opbase group1reg) + "Return handlers for an arithmetic mnemonic starting at OPBASE. +The REG value in ModR/M is indicated by GROUP1REG." + (list + (cons '("Eb" "Gb") (x86/default-instruction-handler (+ opbase 0))) + (cons '("Ev" "Gv") (x86/default-instruction-handler (+ opbase 1))) + (cons '("Gb" "Eb") (x86/default-instruction-handler (+ opbase 2))) + (cons '("Gv" "Ev") (x86/default-instruction-handler (+ opbase 3))) + (cons '(al "Ib") (x86/default-instruction-handler (+ opbase 4))) + (cons '((ax eax rax) "Iz") (x86/default-instruction-handler (+ opbase 5))) + (cons '("Eb" "Ib") + (x86/default-instruction-handler 0x80 + :posthook (lambda (ins _) (x86/ins/set-modrm-reg! ins group1reg)))) + (cons '("Ev" "Iz") + (x86/default-instruction-handler 0x81 + :posthook (lambda (ins _) (x86/ins/set-modrm-reg! ins group1reg)))) + (cons '("Ev" "Ib") + (x86/default-instruction-handler 0x83 + :posthook (lambda (ins _) (setf (x86/ins-modrm-reg ins) group1reg)))))) + +(setq! x86/registers-+reg-base + '( (+rb . (al cl dl bl ah ch dh bh)) + (+rw . (ax cx dx bx sp bp si di)) + (+rd . (eax ecx edx ebx esp ebp esi edi)) + (+rq . (rax rcx rdx rbx rsp rbp rsi rdi)))) +(setq! x86/registers-+reg-extended + '( (+rw . (r8b r9b r10b r11b r12b r13b r14b r15b)) + (+rw . (r8w r9w r10w r11w r12w r13w r14w r15w)) + (+rd . (r8d r9d r10d r11d r12d r13d r14d r15d)) + (+rq . (r8 r9 r10 r11 r12 r13 r14 r15)))) +(defun! x86/generate-handlers-opcode-+reg (opbase extraops addends & args) + "Generate handlers for a family of opcodes that uses the +reg encoding. +OPBASE is the base opcode. +EXTRAOPS are additional operands after the register operand. +ADDENDS is a list of symbols like +rw, +rq etc. that denote allowed registers. +ARGS are passed verbatim to `u/x86/default-instruction-handler." + (list/map + (lambda (it) + (let ( (abase (list/map (lambda (a) (list/nth it (alist/get a x86/registers-+reg-base))) addends)) + (aext (list/map (lambda (a) (list/nth it (alist/get a x86/registers-+reg-extended))) addends))) + (cons + (cons (list/append abase aext) extraops) + (apply 'x86/default-instruction-handler (cons (+ opbase it) args))))) + (list/iota 8))) + +(setq! + x86/mnemonic-table + (list + (cons 'add (x86/generate-handlers-arith 0x00 0)) + (cons 'or (x86/generate-handlers-arith 0x08 1)) + (cons 'adc (x86/generate-handlers-arith 0x10 2)) + (cons 'sbb (x86/generate-handlers-arith 0x18 3)) + (cons 'and (x86/generate-handlers-arith 0x20 4)) + (cons 'sub (x86/generate-handlers-arith 0x28 5)) + (cons 'xor (x86/generate-handlers-arith 0x30 6)) + (cons 'cmp (x86/generate-handlers-arith 0x38 7)) + (cons 'push + (x86/generate-handlers-opcode-+reg 0x50 '() '(+rw +rq) + :default-size 8 + :posthook (lambda (ins ops) (x86/ins/set-rex-b! ins (x86/register-extended? (car ops)))))) + (cons 'pop + (x86/generate-handlers-opcode-+reg 0x58 '() '(+rw +rq) + :default-size 8 + :posthook (lambda (ins ops) (x86/ins/set-rex-b! ins (x86/register-extended? (car ops)))))) + (list 'jo + (cons '("Jb") (x86/instruction-handler-jcc 0x70 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x80) 4))) + (list 'jno + (cons '("Jb") (x86/instruction-handler-jcc 0x71 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x81) 4))) + (list 'jb + (cons '("Jb") (x86/instruction-handler-jcc 0x72 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x82) 4))) + (list 'jnb + (cons '("Jb") (x86/instruction-handler-jcc 0x73 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x83) 4))) + (list 'jz + (cons '("Jb") (x86/instruction-handler-jcc 0x74 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x84) 4))) + (list 'jnz + (cons '("Jb") (x86/instruction-handler-jcc 0x75 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x85) 4))) + (list 'jbe + (cons '("Jb") (x86/instruction-handler-jcc 0x76 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x86) 4))) + (list 'jnbe + (cons '("Jb") (x86/instruction-handler-jcc 0x77 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x87) 4))) + (list 'js + (cons '("Jb") (x86/instruction-handler-jcc 0x78 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x88) 4))) + (list 'jns + (cons '("Jb") (x86/instruction-handler-jcc 0x79 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x89) 4))) + (list 'jp + (cons '("Jb") (x86/instruction-handler-jcc 0x7a 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x8a) 4))) + (list 'jnp + (cons '("Jb") (x86/instruction-handler-jcc 0x7b 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x8b) 4))) + (list 'jl + (cons '("Jb") (x86/instruction-handler-jcc 0x7c 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x8c) 4))) + (list 'jnl + (cons '("Jb") (x86/instruction-handler-jcc 0x7d 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x8d) 4))) + (list 'jle + (cons '("Jb") (x86/instruction-handler-jcc 0x7e 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x8e) 4))) + (list 'jnle + (cons '("Jb") (x86/instruction-handler-jcc 0x7f 1)) + (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x8f) 4))) + (cons 'mov + (x86/generate-handlers-opcode-+reg 0xb0 '("Ib") '(+rb) + :posthook (lambda (ins ops) (x86/ins/set-rex-b! ins (x86/register-extended? (car ops)))))) + (cons 'mov + (x86/generate-handlers-opcode-+reg 0xb8 '("Iv") '(+rw +rd +rq) + :posthook (lambda (ins ops) (x86/ins/set-rex-b! ins (x86/register-extended? (car ops)))))) + (list 'jmp + (cons '("Ev") + (x86/default-instruction-handler 0xff + :default-size 8 + :posthook (lambda (ins _) (setf (u/x86/ins-modrm-reg ins) 4))))) + (list 'syscall + (cons '() (lambda (_ _) (x86/ins/new :opcode '(0x0f 0x05))))) + )) + +(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! test-ins (x86/asm '(syscall))) +(print! test-ins) +(print! (x86/ins-bytes test-ins)) diff --git a/pit/test/y.lisp b/pit/test/y.lisp new file mode 100644 index 0000000..5e9218b --- /dev/null +++ b/pit/test/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)))))) diff --git a/pit/whereweleftoff.org b/pit/whereweleftoff.org new file mode 100644 index 0000000..3b89918 --- /dev/null +++ b/pit/whereweleftoff.org @@ -0,0 +1,8 @@ +[2026-06-26] + +- annotations do not work properly because macroexpansion creates an entirely new body for lambdas +- we realized that we are handling macro application in two separate places: pit_expand_macros expands lambda bodies, and pit_eval expands macros encountered while evaling. we ought to unify this so that only one is used (probably pit_expand_macros, because we need to expand macros eagerly to identify free variables to capture) +- we probably can make pit_expand_macros and pit_eval much nicer +- we can probably make pit_expand_macros operate in place +- if we want to be really smart, cool, happy, rich: + let's just make stuff translate to a little VM before it evaluates, and let's store VM programs as functions instead of sexps |
