Merge branch 'master' of git.sr.ht:~swisschili/bluejay
diff --git a/.vscode/launch.json b/.vscode/launch.json
index 2fd02c2..b438376 100644
--- a/.vscode/launch.json
+++ b/.vscode/launch.json
@@ -9,7 +9,7 @@
"type": "cppdbg",
"request": "launch",
"program": "${workspaceFolder}/src/lisp/lisp",
- "args": ["test.lisp"],
+ "args": ["test-macros.lisp"],
"stopAtEntry": false,
"cwd": "${workspaceFolder}/src/lisp",
"environment": [],
diff --git a/.vscode/settings.json b/.vscode/settings.json
index 19972d2..54186f5 100644
--- a/.vscode/settings.json
+++ b/.vscode/settings.json
@@ -1,4 +1,10 @@
{
"restructuredtext.languageServer.disabled": true,
- "restructuredtext.confPath": "${workspaceFolder}/doc"
+ "restructuredtext.confPath": "${workspaceFolder}/doc",
+ "files.associations": {
+ "Jmk.options": "makefile",
+ "Jmk": "makefile",
+ "*.dasc": "c",
+ "typeinfo": "c"
+ }
}
\ No newline at end of file
diff --git a/README.md b/README.md
index 7f93e10..f80c12a 100644
--- a/README.md
+++ b/README.md
@@ -1,9 +1,9 @@
# Bluejay
-[](https://builds.sr.ht/~swisschili/bluejay/commits/.build.yml?)
-
<img src="share/branding/bluejay-unsplash.jpg" align="right" width="200">
+[](https://builds.sr.ht/~swisschili/bluejay/commits/.build.yml?)
+
Bluejay is a preemptive kernel for x86. It is inspired by modern day
UNIX-like systems and 80's Lisp machines. The goal is to create a
fully usable kernel and graphical Lisp environment.
@@ -24,19 +24,19 @@
- [x] Efficient kernel virtual allocator
- [ ] Preemptive multitasking
- [x] Multi-threading
- - [ ] Multi-process support
+ - [ ] Multi-process support (waiting on FS)
- [ ] Device drivers
- [x] PCI
- [ ] USB
- [ ] Mouse + keyboard drivers
+ - [ ] Storage device drivers
+ - [x] ATA PIO (broken)
+ - [ ] SATA
- [ ] Filesystem
- [x] Virtual file system
- [x] Initial ramdisk
- - [ ] Storage device drivers
- - [x] ATA PIO
- - [ ] SATA
- [ ] Filesystem drivers
- - [ ] EXT2
+ - [ ] EXT2 (in progress)
- [ ] FAT32
- [ ] System call API
- [ ] Filesystem API
@@ -45,9 +45,9 @@
- [ ] Lisp compiler
- [ ] JIT compiler using dynasm
- [x] Basic compilation
+ - [x] GC
- [ ] Lexical closures
- - [ ] GC
- - [ ] Standard library
+ - [ ] Standard library (in progress)
- [ ] Lisp integrated into kernel
- [ ] User-space driver API
- [ ] Lisp API
@@ -62,5 +62,5 @@
## Documentation
-Manual pages are available in `doc/`, and additional documentation is
-available [on the wiki](https://wiki.swisschili.sh/Bluejay).
+The [Bluejay manual](https://bluejay.readthedocs.io) contains up to date
+documentation.
diff --git a/doc/_static/custom.css b/doc/_static/custom.css
new file mode 100644
index 0000000..f474a3e
--- /dev/null
+++ b/doc/_static/custom.css
@@ -0,0 +1,3 @@
+.pre {
+ font-family:SFMono-Regular,Menlo,Monaco,Consolas,Liberation Mono,Courier New,Courier,monospace;
+}
diff --git a/doc/conf.py b/doc/conf.py
index dd82eb7..39e52ea 100644
--- a/doc/conf.py
+++ b/doc/conf.py
@@ -30,3 +30,6 @@
html_theme = 'sphinx_rtd_theme'
html_static_path = ['_static']
+
+def setup(app):
+ app.add_stylesheet('custom.css')
diff --git a/doc/lisp-std.rst b/doc/lisp-std.rst
index 261f388..9f9dbd6 100644
--- a/doc/lisp-std.rst
+++ b/doc/lisp-std.rst
@@ -8,20 +8,59 @@
In general every user-facing API in the standard library should be documented
here.
-Built-in "functions"
+- ``(x ...)`` represents a list ``x``.
+- ``& body`` means that the rest of the list is represented by ``body``.
+- ``[something]`` means that ``something`` is optional.
+
+Top-level primitives
--------------------
-.. function:: (defun function-name (arg1 ... argN) & body)
+These are "functions" that can only appear at the top-level of the program. This
+means they can't be nested in any other expressions.
- Define a function ``function-name`` that takes N arguments with names
- ``arg1`` ... ``argN``. ``body`` is evaluated in order, with the whole
- function evaluating to the last expression.
+.. function:: (defun function-name (args ...) & body)
+
+ Defines a function ``function-name`` that takes ``args`` and evaluates
+ ``body``. ``function-name`` is quoted, not evaluated.
.. code-block:: lisp
+
+ (defun say-hi (name)
+ (print "Hi, ")
+ (print name))
+
+ (say-hi "Joe")
+ ; "Hi,"
+ ; "Joe"
+
+.. function:: (defmacro macro-name (args ...) & body)
+
+ ``defmacro`` is to macros as ``defun`` is to functions. When ``macro-name``
+ is called, whatever it evaluates to will be compiled.
+
+ Note that internally this compiles a function the same way all other
+ functions are compiled, meaning you can call **any** lisp function from a
+ macro definition and it will work as expected.
+
+ .. code-block:: Lisp
+
+ (defun double (n)
+ (+ n n))
- (defun greet (name)
- (string-concat "Hello, " name))
- ; string-concat isn't even implemented yet, but you get the picture.
+ (defmacro call-with-4 (whatever)
+ (print "this was run at **compile time**")
+ (print whatever)
+ ;; ``whatever`` expands to the form passed to this macro, in this case
+ ;; ``double``.
+ (list whatever 4))
+
+ (print (call-with-4 double))
+ ; "this was run at **compile time**"
+ ; 'double
+ ; 8
+
+Functions
+---------
.. function:: (if condition true-condition [false-condition])
@@ -53,17 +92,22 @@
Force the garbage collector (GC) to run.
-Functions
----------
-
.. function:: (car pair)
Return the first item in ``pair``.
+ .. code-block:: lisp
+
+ (car (cons 'a 'b)) ;=> 'a
+
.. function:: (cdr pair)
Return the second (last) item in ``pair``.
+ .. code-block:: lisp
+
+ (cdr (cons 'a 'b)) ;=> 'b
+
.. function:: (cons a b)
Return a cons-pair containing ``a`` and ``b``.
@@ -73,3 +117,24 @@
Print out ``val`` to standard output. This will not be formatted as an
s-expression, but in a manner more similar to the internal representation.
+.. function:: (list & items)
+
+ Returns a cons-list of items.
+
+ .. code-block:: lisp
+
+ (list 1 2 3)
+ ; is the same as
+ (cons 1 (cons 2 (cons 3 nil)))
+
+.. function:: (quote form)
+
+ Returns form without evaluating it.
+
+ .. code-block:: lisp
+
+ '(cons a b)
+ ; or
+ (quote cons a b)
+ ; is the same as
+ (list 'cons 'a 'b)
diff --git a/include/kernel/dri/ata_pio/ata_pio.h b/include/kernel/dri/ata_pio/ata_pio.h
index 667ed3b..2fd8623 100644
--- a/include/kernel/dri/ata_pio/ata_pio.h
+++ b/include/kernel/dri/ata_pio/ata_pio.h
@@ -35,9 +35,12 @@
// Commands
enum
{
- ATA_CMD_READ = 0x20,
- ATA_CMD_WRITE = 0x30,
+ /// Do not retry
+ ATA_CMD_READ = 0x21,
+ /// Do not retry
+ ATA_CMD_WRITE = 0x31,
ATA_CMD_IDENTIFY = 0xec,
+ ATA_CMD_FLUSH_CACHE = 0xe7,
};
void ata_pio_wait_bsy();
@@ -48,4 +51,4 @@
void test_ata_pio();
-void init_ata_pio();
\ No newline at end of file
+void init_ata_pio();
diff --git a/share/jmk/jmk.m4 b/share/jmk/jmk.m4
index aacc7bf..0b2c96c 100644
--- a/share/jmk/jmk.m4
+++ b/share/jmk/jmk.m4
@@ -99,7 +99,7 @@
define(finish,
`clean: $(jmk_clean_libs)
- @rm -f *.o *.a *.so $(jmk_target)
+ @rm -f **/*.o **/*.a *.so $(jmk_target) $(OBJECTS)
Makefile: Jmk
status_log(JMK, jmk_build_dir)
diff --git a/src/kernel/dri/ata_pio/ata_pio.c b/src/kernel/dri/ata_pio/ata_pio.c
index cd426ef..54db487 100644
--- a/src/kernel/dri/ata_pio/ata_pio.c
+++ b/src/kernel/dri/ata_pio/ata_pio.c
@@ -39,17 +39,27 @@
void ata_pio_read_sectors(void *buffer, uint lba, uchar num_sectors)
{
- ata_pio_wait_bsy();
+ ushort *word_buffer = buffer;
+ ata_pio_wait_bsy();
ata_pio_send_init(lba, num_sectors);
outb(ATA_PORT_CMD, ATA_CMD_READ);
ata_pio_wait_bsy();
+
+ if (inb(ATA_PORT_CMD) & ATA_ERR)
+ {
+ kprintf(ERROR "ATA_ERR on read\n");
+ kpanic("Failed to read");
+ }
- asm volatile("rep insw" ::"c"(num_sectors * 256), "d"(ATA_PORT_DATA),
- "D"(buffer));
+ for (int i = 0; i < num_sectors * 256; i++)
+ {
+ word_buffer[i] = inw(ATA_PORT_DATA);
+ }
ata_pio_wait_bsy();
+ outw(ATA_PORT_CMD, ATA_CMD_FLUSH_CACHE);
}
void ata_pio_write_sectors(uint lba, uchar num_sectors, ushort *buffer)
@@ -65,6 +75,9 @@
{
outw(ATA_PORT_DATA, buffer[i]);
}
+
+ ata_pio_wait_bsy();
+ outw(ATA_PORT_CMD, ATA_CMD_FLUSH_CACHE);
}
static void print_buffer()
diff --git a/src/lisp/Jmk b/src/lisp/Jmk
index ec4e5da..394e077 100644
--- a/src/lisp/Jmk
+++ b/src/lisp/Jmk
@@ -4,14 +4,17 @@
option(PLAT, "`platform to build for: either linux or bluejay'", linux)
-preset(optimize)
+# preset(optimize)
preset(32)
preset(debug)
preset(warn)
+preset(nasm)
-archetype(c, asm)
+archetype(c)
+archetype(asm)
CFLAGS += -Ivendor/luajit/dynasm
+ASMFLAGS += -felf -Fdwarf
OBJECTS = main.o \
lisp.o \
@@ -19,7 +22,8 @@
lib/std.o \
plat/linux.o \
istream.o \
- gc.o
+ gc.o \
+ call_list.o
LUA = vendor/luajit/src/host/minilua
@@ -33,9 +37,11 @@
type(executable)
+F ?= test.lisp
+
run: lisp
- status_log(LISP, test.lisp)
- @./lisp ./test.lisp
+ status_log(LISP, $(F))
+ @./lisp $(F)
format:
status_log(FORMAT, *)
diff --git a/src/lisp/call_list.s b/src/lisp/call_list.s
new file mode 100644
index 0000000..da0c00c
--- /dev/null
+++ b/src/lisp/call_list.s
@@ -0,0 +1,57 @@
+;;; TODO: figure out if I need to do something special with the GC here.
+
+ [bits 32]
+ [global _call_list]
+ [extern length]
+ [extern elt]
+ ;;; This function should call it's first argument with the arguments from
+ ;;; the cons-list passed as its second argument.
+
+ ;;; _call_list(function pointer, cons list)
+_call_list:
+ push ebp
+ mov ebp, esp
+
+ mov edi, [ebp + 12] ; Cons list
+
+ push edi
+ call length ; Length of cons list in eax
+ add esp, 4
+
+ mov ecx, eax ; Store length in counter
+
+ ;; Reserve space for all the stack items
+ shl eax, 2
+ sub esp, eax
+
+ mov esi, esp ; Pointer to top of stack
+
+ ;; Skip all of this if there are no arguments
+ cmp ecx, 0
+ je .done
+
+.loop:
+ ;; Get the previous item. At the start ecx = the length so to get the last
+ ;; index we need to subtract 1
+ dec ecx
+
+ push ecx
+ push edi
+ call elt
+ add esp, 4
+ pop ecx ; This is a scratch register, remember
+
+ ;; We now have the ecx-th item in eax
+ ;; Remember esi is the top of the stack area reserved, so
+ mov [esi + 4 * ecx], eax
+
+ jcxz .done
+ jmp .loop
+
+.done:
+ mov ebx, [ebp + 8] ; Function pointer
+ call ebx
+
+ mov esp, ebp
+ pop ebp
+ ret
diff --git a/src/lisp/compiler.dasc b/src/lisp/compiler.dasc
index bc5aec8..ec14078 100644
--- a/src/lisp/compiler.dasc
+++ b/src/lisp/compiler.dasc
@@ -95,8 +95,13 @@
value_t form = car(val);
value_t args = cdr(val);
- if (symstreq(form, "defun"))
+ if (symstreq(form, "defun") || symstreq(form, "defmacro"))
{
+ enum namespace namespace = NS_FUNCTION;
+
+ if (symstreq(form, "defmacro"))
+ namespace = NS_MACRO;
+
dasm_State *d;
dasm_State **Dst = &d;
@@ -162,7 +167,7 @@
| cleanup;
add_function(env, (char *)(name ^ SYMBOL_TAG), link(Dst),
- length(arglist));
+ length(arglist), namespace);
dasm_free(&d);
free(local.stack_slots);
@@ -224,6 +229,23 @@
return n;
}
+void compile_backquote(struct environment *env, struct local *local,
+ value_t val, dasm_State **Dst)
+{
+ if (!listp(val))
+ {
+ | mov eax, (val);
+ }
+ else
+ {
+ value_t fsym = car(val),
+ args = cdr(val);
+ int nargs = length(args);
+
+ // TODO
+ }
+}
+
void compile_expression(struct environment *env, struct local *local,
value_t val, dasm_State **Dst)
{
@@ -311,6 +333,42 @@
| run_gc;
}
+ else if (symstreq(fsym, "quote"))
+ {
+ if (nargs != 1)
+ err("quote should take exactly 1 argument");
+
+ // Simple!
+ | mov eax, (car(args));
+ }
+ else if (symstreq(fsym, "backquote"))
+ {
+ if (nargs != 1)
+ err("backquote should take exactly 1 argument");
+
+ compile_backquote(env, local, car(args), Dst);
+ }
+ else if (symstreq(fsym, "list"))
+ {
+ | push (nil);
+
+ for (int i = nargs - 1; i >= 0; i--)
+ {
+ compile_expression(env, local, elt(args, i), Dst);
+
+ // push the ith item
+ | push eax;
+ // cons the top two stack items
+ | mov ebx, (cons);
+ | call ebx;
+ // remove the stack items from use
+ | add esp, (2 * value_size);
+ // put the new thing on the stack
+ | push eax;
+ }
+
+ | pop eax;
+ }
else
{
struct function *func =
@@ -322,16 +380,28 @@
if (nargs != func->nargs)
err("wrong number of args");
- for (int i = length(args) - 1; i >= 0; i--)
+ if (func->namespace == NS_FUNCTION)
{
- compile_expression(env, local, elt(args, i), Dst);
- | push eax;
- }
+ for (int i = length(args) - 1; i >= 0; i--)
+ {
+ compile_expression(env, local, elt(args, i), Dst);
+ | push eax;
+ }
- | mov ebx, (func->code_addr);
- | call ebx;
- | add esp, (nargs * value_size);
- // result in eax
+ | mov ebx, (func->code_addr);
+ | call ebx;
+ | add esp, (nargs * value_size);
+ // result in eax
+ }
+ else if (func->namespace == NS_MACRO)
+ {
+ value_t expanded_to = call_list(func, args);
+
+ printf("Macro expanded to:\n");
+ printval(expanded_to, 2);
+
+ compile_expression(env, local, expanded_to, Dst);
+ }
}
}
else if (symbolp(val))
@@ -369,7 +439,7 @@
| cleanup;
- add_function(env, name, link(Dst), 0);
+ add_function(env, name, link(Dst), 0, NS_FUNCTION);
}
struct variable *add_variable(struct local *local, enum var_type type,
@@ -405,3 +475,10 @@
return v;
}
+
+extern value_t _call_list(void *addr, value_t list);
+
+value_t call_list(struct function *func, value_t list)
+{
+ return _call_list(func->code_ptr, list);
+}
diff --git a/src/lisp/compiler.h b/src/lisp/compiler.h
index 465c9fb..ddf7ea0 100644
--- a/src/lisp/compiler.h
+++ b/src/lisp/compiler.h
@@ -5,12 +5,20 @@
#include <stdbool.h>
#include <stdint.h>
+enum namespace
+{
+ NS_FUNCTION,
+ NS_MACRO,
+};
+
struct function
{
char *name;
int nargs; // number of arguments
+ enum namespace namespace;
- union {
+ union
+ {
value_t (*def0)();
value_t (*def1)(value_t);
value_t (*def2)(value_t, value_t);
@@ -56,8 +64,16 @@
void compile_expression(struct environment *env, struct local *local,
value_t val, dasm_State **Dst);
+
+/**
+ * Compile a backquoted expression
+ */
+void compile_backquote(struct environment *env, struct local *local,
+ value_t val, dasm_State **Dst);
+
void compile_expr_to_func(struct environment *env, char *name, value_t val,
dasm_State **Dst);
+
int nextpc(struct local *local, dasm_State **Dst);
// Local utilities
@@ -74,3 +90,8 @@
// Might return null
struct variable *find_variable(struct local *local, char *name);
void destroy_local(struct local *local);
+
+/**
+ * Like `apply` in lisp, calls func with list args and returns the result.
+ */
+value_t call_list(struct function *func, value_t list);
diff --git a/src/lisp/gc.c b/src/lisp/gc.c
index b9e9574..16ec471 100644
--- a/src/lisp/gc.c
+++ b/src/lisp/gc.c
@@ -20,8 +20,6 @@
void *pointer = (void *)(value & ~HEAP_MASK);
struct alloc *alloc = pointer - sizeof(struct alloc);
- fprintf(stderr, "[ GC ] Marking 0x%p\n", pointer);
-
// Only recursively mark if this hasn't been marked yet. i.e. prevent
// marking circular references twice
if (alloc->mark != gc_mark)
@@ -54,17 +52,15 @@
void _sweep()
{
- for (struct alloc *a = first_a; a; a = a->next)
+ for (struct alloc *a = first_a; a;)
{
if (pool_alive(a->pool) || a->mark == gc_mark)
{
// Marked or in living pool
+ a = a->next;
}
else
{
- printf("Freeing:\n");
- printval(alloc_to_value(a), 2);
-
// Free and remove from allocation list
struct alloc *p = a->prev, *n = a->next;
free_aligned(a);
@@ -89,8 +85,6 @@
gc_mark++;
- fprintf(stderr, "[ GC ] %d (esp 0x%p, ebp 0x%p)\n", gc_mark, esp_p, ebp_p);
-
// For every stack frame until the base of the stack
while (esp_p < gc_base)
{
@@ -110,8 +104,6 @@
esp_p += 2;
}
- fprintf(stderr, "Marked %d\n", num_marked);
-
_sweep();
}
diff --git a/src/lisp/istream.c b/src/lisp/istream.c
index 9351adf..957b2b5 100644
--- a/src/lisp/istream.c
+++ b/src/lisp/istream.c
@@ -81,6 +81,14 @@
fprintf(out, "\033[31m^\033[0m\n");
}
+void stristream_getpos(struct istream *is, int *line, char **name)
+{
+ struct stristream_private *p = is->data;
+
+ *name = "<input literal>";
+ *line = p->line;
+}
+
struct istream *new_stristream(char *str, int length)
{
struct istream *is = malloc(sizeof(struct istream));
@@ -98,6 +106,7 @@
is->peek = stristream_peek;
is->read = stristream_read;
is->showpos = stristream_showpos;
+ is->getpos = stristream_getpos;
return is;
}
@@ -120,6 +129,7 @@
FILE *file;
int next;
bool has_next;
+ int line;
};
int fistream_peek(struct istream *is)
@@ -138,13 +148,20 @@
{
struct fistream_private *p = is->data;
+ char c;
+
if (p->has_next)
{
p->has_next = false;
- return p->next;
+ c = p->next;
}
+ else
+ c = fgetc(p->file);
- return fgetc(p->file);
+ if (c == '\n')
+ p->line++;
+
+ return c;
}
int fistream_read(struct istream *is, char *buffer, int size)
@@ -170,6 +187,14 @@
// TODO: implement
}
+void fistream_getpos(struct istream *is, int *line, char **name)
+{
+ struct fistream_private *p = is->data;
+
+ *line = p->line;
+ *name = "<FILE *>";
+}
+
struct istream *new_fistream(char *path, bool binary)
{
struct istream *is = malloc(sizeof(struct istream));
@@ -187,12 +212,14 @@
p->has_next = false;
p->file = fp;
+ p->line = 1;
is->data = p;
is->get = fistream_get;
is->peek = fistream_peek;
is->read = fistream_read;
is->showpos = fistream_showpos;
+ is->getpos = fistream_getpos;
return is;
}
diff --git a/src/lisp/istream.h b/src/lisp/istream.h
index aceada8..882a740 100644
--- a/src/lisp/istream.h
+++ b/src/lisp/istream.h
@@ -5,17 +5,22 @@
#define MIN(a, b) (a) > (b) ? (b) : (a)
+/// Virtual class representing an input stream. Subclasses must implement every
+/// function.
struct istream
{
void *data;
- // These two return -1 on error
+ /// Returns -1 on error
int (*peek)(struct istream *s);
+ /// Returns -1 on error
int (*get)(struct istream *s);
int (*read)(struct istream *s, char *buffer, int size);
void (*showpos)(struct istream *s, FILE *out);
+
+ void (*getpos)(struct istream *s, int *line, char **name);
};
struct istream *new_stristream(char *str, int length);
diff --git a/src/lisp/lib/std.c b/src/lisp/lib/std.c
index 03e17fc..485bf49 100644
--- a/src/lisp/lib/std.c
+++ b/src/lisp/lib/std.c
@@ -39,7 +39,7 @@
return nil;
}
-void add_function(struct environment *env, char *name, void *func, int nargs)
+void add_function(struct environment *env, char *name, void *func, int nargs, enum namespace ns)
{
struct function *last, *new = malloc(sizeof(struct function));
@@ -48,20 +48,21 @@
new->name = name;
new->nargs = nargs;
new->code_ptr = func;
+ new->namespace = ns;
env->first = new;
}
void load_std(struct environment *env)
{
- add_function(env, "+", l_plus, 2);
- add_function(env, "-", l_minus, 2);
- add_function(env, "*", l_times, 2);
- add_function(env, "/", l_divide, 2);
+ add_function(env, "+", l_plus, 2, NS_FUNCTION);
+ add_function(env, "-", l_minus, 2, NS_FUNCTION);
+ add_function(env, "*", l_times, 2, NS_FUNCTION);
+ add_function(env, "/", l_divide, 2, NS_FUNCTION);
- add_function(env, "car", car, 1);
- add_function(env, "cdr", cdr, 1);
- add_function(env, "cons", cons, 2);
+ add_function(env, "car", car, 1, NS_FUNCTION);
+ add_function(env, "cdr", cdr, 1, NS_FUNCTION);
+ add_function(env, "cons", cons, 2, NS_FUNCTION);
- add_function(env, "print", l_printval, 1);
+ add_function(env, "print", l_printval, 1, NS_FUNCTION);
}
diff --git a/src/lisp/lib/std.h b/src/lisp/lib/std.h
index 000129e..5162bab 100644
--- a/src/lisp/lib/std.h
+++ b/src/lisp/lib/std.h
@@ -5,5 +5,5 @@
value_t l_plus(value_t a, value_t b);
-void add_function(struct environment *env, char *name, void *func, int nargs);
+void add_function(struct environment *env, char *name, void *func, int nargs, enum namespace ns);
void load_std(struct environment *env);
diff --git a/src/lisp/lisp.c b/src/lisp/lisp.c
index 2d920ea..0d305f2 100644
--- a/src/lisp/lisp.c
+++ b/src/lisp/lisp.c
@@ -34,6 +34,8 @@
c->car = car;
c->cdr = cdr;
+ c->line = 0;
+ c->name = NULL;
item->alloc.type_tag = CONS_TAG;
item->alloc.pool = current_pool;
@@ -248,6 +250,8 @@
bool readint(struct istream *is, value_t *val)
{
+ skipws(is);
+
int number = 0;
if (!isdigit(is->peek(is)))
@@ -263,8 +267,70 @@
return true;
}
+bool readquote(struct istream *is, value_t *val)
+{
+ skipws(is);
+
+ char c = is->peek(is);
+
+ if (c == '\'' || c == '`' || c == ',')
+ {
+ is->get(is);
+
+ if (c == '`' && is->peek(is) == '@')
+ {
+ // This is actually a splice
+ is->get(is);
+ c = '@';
+ }
+
+ // Read the next form and wrap it in the appropriate function
+
+ value_t wrapped;
+ bool has_next = read1(is, &wrapped);
+
+ if (!has_next)
+ {
+ fprintf(stderr, "Expected a form after reader macro char %c\n", c);
+ is->showpos(is, stderr);
+ err("Invalid reader macro");
+ return false;
+ }
+
+ value_t symbol = nil;
+
+ switch (c)
+ {
+ case '\'':
+ symbol = symval("quote");
+ break;
+ case '`':
+ symbol = symval("backquote");
+ break;
+ case ',':
+ symbol = symval("unquote");
+ break;
+ case '@':
+ symbol = symval("unquote-splice");
+ break;
+ }
+
+ *val = cons(symbol, cons(wrapped, nil));
+
+ return true;
+ }
+ else
+ {
+ return false;
+ }
+}
+
bool read1(struct istream *is, value_t *val)
{
+ // This could all be one big short-circuiting || but that is ugly.
+ if (readquote(is, val))
+ return true;
+
if (readsym(is, val))
return true;
@@ -280,6 +346,17 @@
return false;
}
+void set_cons_info(value_t cons, int line, char *name)
+{
+ if (!consp(cons))
+ return;
+
+ struct cons *ca = (void *)(cons ^ CONS_TAG);
+
+ ca->line = line;
+ ca->name = name;
+}
+
value_t readn(struct istream *is)
{
value_t first = nil;
@@ -289,7 +366,13 @@
while (read1(is, &read_val))
{
+ int line;
+ char *file;
+
+ is->getpos(is, &line, &file);
*last = cons(read_val, nil);
+ set_cons_info(*last, line, file);
+
last = cdrref(*last);
}
@@ -312,12 +395,25 @@
value_t v;
char *a = malloc_aligned(strlen(str) + 1);
+ strcpy(a, str);
v = (value_t)a;
v |= STRING_TAG;
return v;
}
+value_t symval(char *str)
+{
+ value_t v;
+
+ char *a = malloc_aligned(strlen(str) + 1);
+ strcpy(a, str);
+ v = (value_t)a;
+ v |= SYMBOL_TAG;
+
+ return v;
+}
+
bool integerp(value_t v)
{
return (v & INT_MASK) == INT_TAG;
diff --git a/src/lisp/lisp.h b/src/lisp/lisp.h
index 9078b45..eb9e5f6 100644
--- a/src/lisp/lisp.h
+++ b/src/lisp/lisp.h
@@ -23,11 +23,20 @@
struct cons;
+/// Represents a Lisp value
typedef unsigned int value_t;
struct cons
{
value_t car, cdr;
+
+ /// Line of the input file from where this was parsed, 0 if it was created
+ /// in Lisp.
+ int line;
+
+ /// Description of where the cons was parsed from, or NULL if generated in
+ /// code.
+ char *name;
};
/// Default pool (no pool)
@@ -100,8 +109,15 @@
bool readlist(struct istream *is, value_t *val);
bool readint(struct istream *is, value_t *val);
+/**
+ * Read a quoted form, including `'` (quote) `\`` (backquote) and `,` (unquote)
+ * @returns true if read successfully, and sets `val`.
+ */
+bool readquote(struct istream *is, value_t *val);
+
value_t intval(int i);
value_t strval(char *str);
+value_t symval(char *str);
value_t cons(value_t car, value_t cdr);
bool read1(struct istream *is, value_t *val);
value_t read(struct istream *is);
diff --git a/src/lisp/plat/linux.c b/src/lisp/plat/linux.c
index 83cc39b..2777950 100644
--- a/src/lisp/plat/linux.c
+++ b/src/lisp/plat/linux.c
@@ -18,7 +18,7 @@
void **aligned_ptr = (void **)((uintptr_t)(mem + 8 + sizeof(void *)) & ~7);
aligned_ptr[-1] = mem;
- memcpy(aligned_ptr, addr, (uintptr_t)aligned_ptr[-2]);
+ memcpy(aligned_ptr, addr, ((uintptr_t *)addr)[-2]);
return aligned_ptr;
}
diff --git a/src/lisp/test-macros.lisp b/src/lisp/test-macros.lisp
new file mode 100644
index 0000000..a075a9b
--- /dev/null
+++ b/src/lisp/test-macros.lisp
@@ -0,0 +1,6 @@
+(defmacro weird-const (a b)
+ a)
+
+(defun main ()
+ (let1 (var "this is var")
+ (print (weird-const var 13))))
diff --git a/src/lisp/test.lisp b/src/lisp/test.lisp
index 9cfb8b7..45c8be4 100644
--- a/src/lisp/test.lisp
+++ b/src/lisp/test.lisp
@@ -5,15 +5,23 @@
(print whatever)
(gc))
+(defmacro weird-identity (a)
+ a)
+
+(defmacro weird-const (a b)
+ a)
+
(defun main ()
(let1 (a (add-two 3))
(print "a is")
- (print a))
+ (print (weird-identity a))
+ (print (weird-const a 4)))
; These allocations should be freed
- (cons 12 (cons 34 (cons 45 nil)))
+ (list 12 34 56)
+ (list "a" "b" "c" "d")
; But these should not
(let1 (unused-but-bound (cons 5 6))
- (let1 (val (cons 1 (cons 2 (cons 3 nil))))
+ (let1 (val '(a b c d e))
(calls-gc val))))