Fix segfault in Lisp when calling variadic function.
Originally a segfault could occur due to an issue with how arguments
were cleaned up after a variadic function call. After the function
call the following assembly was generated:
add esp, nargs
Where nargs was the number of arguments passed to the function. This
did not take in to account that for variadic functions, the last
several arguments are CONS'd into one argument, meaning that calling a
variadic function with <>1 variadic argument would result in a broken
stack.
Specifically this issue came up in the implementation of REDUCE, which
relied on the variadic FUNCALL.
diff --git a/lib/lisp/std/list-functions.lisp b/lib/lisp/std/list-functions.lisp
index 7bb22a7..f25ceb5 100644
--- a/lib/lisp/std/list-functions.lisp
+++ b/lib/lisp/std/list-functions.lisp
@@ -29,7 +29,8 @@
arguments. The first argument will be the result so far and the second
will be the n-th item of the list. For the first item of the list, the
result so far will be `initial-value`, or `nil` by default."
- (if (not list)
- initial-value
- (reduce fun (cdr list)
- (funcall fun initial-value (car list)))))
+ (if (nilp list)
+ initial-value
+ (reduce fun (cdr list)
+ (funcall fun initial-value
+ (car list)))))
diff --git a/lib/lisp/std/std.lisp b/lib/lisp/std/std.lisp
index 56e8294..e7ed14c 100644
--- a/lib/lisp/std/std.lisp
+++ b/lib/lisp/std/std.lisp
@@ -51,8 +51,6 @@
(read-stdin)))
(defun funcall (fun & list)
- (print fun)
- (print list)
(apply fun list))
(load "list-functions.lisp")
diff --git a/src/lisp/Jmk b/src/lisp/Jmk
index 8647e85..5b00b6d 100644
--- a/src/lisp/Jmk
+++ b/src/lisp/Jmk
@@ -13,7 +13,7 @@
archetype(c)
archetype(asm)
-CFLAGS += -Ivendor/luajit/dynasm -Werror -lreadline
+CFLAGS += -Ivendor/luajit/dynasm -Werror -lreadline # -fsanitize=address
LDFLAGS += -lreadline
ASMFLAGS += -felf -Fdwarf
diff --git a/src/lisp/compiler.dasc b/src/lisp/compiler.dasc
index 3cb80d8..f74189d 100644
--- a/src/lisp/compiler.dasc
+++ b/src/lisp/compiler.dasc
@@ -19,7 +19,7 @@
|.arch x86;
|.macro setup, nvars;
-|->function_start:;
+|1:;
| push ebp;
| mov ebp, esp;
| sub esp, (value_size * nvars);
@@ -32,8 +32,7 @@
|.endmacro;
|.macro call_extern, address;
-| mov ebx, address;
-| call ebx;
+| call &address;
|.endmacro;
dasm_State *d;
@@ -318,8 +317,6 @@
if (!stringp(name))
return nil;
- fprintf(stderr, "Called load_relative\n");
-
char *new_path = (char *)(name ^ STRING_TAG);
char *relative_to = strdup(to);
char full_path[512];
@@ -554,8 +551,7 @@
// push the ith item
| push eax;
// cons the top two stack items
- | mov ebx, (cons);
- | call ebx;
+ | call_extern cons;
// remove the stack items from use
| add esp, (2 * value_size);
// put the new thing on the stack
@@ -581,8 +577,7 @@
| push (new_local.num_closure_slots);
| push (nargs_out);
| push (func_ptr);
- | mov ebx, (create_closure);
- | call ebx;
+ | call_extern create_closure;
| add esp, 12;
// Walk the generated local scope for V_FREE variables, since each
@@ -601,8 +596,7 @@
// The capture offset
| push (var->number);
- | mov ebx, (set_closure_capture_variable);
- | call ebx;
+ | call_extern set_closure_capture_variable;
// Skip the value and index
| add esp, 8;
// Pop the closure back in to eax
@@ -625,8 +619,7 @@
compile_expression(env, local, car(args), Dst);
| push eax;
| push (env);
- | mov ebx, (eval);
- | call ebx;
+ | call_extern eval;
}
else if (symstreq(fsym, "load"))
{
@@ -639,8 +632,7 @@
| push eax;
| push (local->current_file_path);
| push (env);
- | mov ebx, (load_relative);
- | call ebx;
+ | call_extern load_relative;
}
else
{
@@ -650,6 +642,10 @@
bool is_recursive = false;
struct args *nargs_needed = NULL;
+ // The number of arguments actually passed on the stack,
+ // i.e. all varargs are 1.
+ int real_nargs = nargs;
+
if (local->current_function_name &&
symstreq(fsym, local->current_function_name))
{
@@ -675,11 +671,21 @@
nargs_needed->num_required, nargs);
}
+ int total_taken = nargs_needed->num_optional +
+ nargs_needed->num_required;
+
+ if (nargs > total_taken)
+ {
+ real_nargs = total_taken + 1;
+ }
+ else
+ {
+ real_nargs = total_taken;
+ }
+
if (is_recursive || func->namespace == NS_FUNCTION)
{
int nargs = length(args);
- int total_taken = nargs_needed->num_optional +
- nargs_needed->num_required;
int line = cons_line(val);
char *file = cons_file(val);
@@ -697,8 +703,7 @@
{
compile_expression(env, local, elt(args, i), Dst);
| push eax;
- | mov ebx, (cons);
- | call ebx;
+ | call_extern cons;
| add esp, 8;
| push eax;
}
@@ -721,14 +726,14 @@
if (is_recursive)
{
- | call ->function_start;
+ | call <1;
}
else
{
// | mov ebx, (func->code_addr);
| call_extern func->code_addr;
}
- | add esp, (nargs * value_size);
+ | add esp, (real_nargs * value_size);
// result in eax
}
else if (func->namespace == NS_MACRO)
@@ -828,9 +833,6 @@
int nargs = length(list);
- printf("IN call_list_args\n");
- printval(list, 2);
-
value_t *val = &list;
for (value_t i = list; !nilp(i); i = cdr(i))
diff --git a/src/lisp/gc.c b/src/lisp/gc.c
index 8820ef5..9a9610d 100644
--- a/src/lisp/gc.c
+++ b/src/lisp/gc.c
@@ -124,5 +124,6 @@
struct alloc *next = a->next;
free_aligned(a);
a = next;
+// fprintf(stderr, "a = %p\n", a);
}
}
diff --git a/src/lisp/istream.c b/src/lisp/istream.c
index 8ac275a..423c231 100644
--- a/src/lisp/istream.c
+++ b/src/lisp/istream.c
@@ -170,6 +170,7 @@
struct fistream_private *p = is->data;
int offset = 0;
+ char *buffer_o = buffer;
if (p->has_next)
{
@@ -180,12 +181,22 @@
offset = 1;
}
- return (int)fread(buffer, 1, size, p->file) + offset;
+ int read = (int)fread(buffer, 1, size, p->file) + offset;
+
+ for (int i = 0; i < read; i++)
+ {
+ if (buffer_o[i] == '\n')
+ p->line++;
+ }
+
+ return read;
}
void fistream_showpos(struct istream *s, FILE *out)
{
- // TODO: implement
+ struct fistream_private *p = s->data;
+
+ fprintf(out, "At %s:%d\n", p->path, p->line);
}
void fistream_getpos(struct istream *is, int *line, char **name)
diff --git a/src/lisp/istream.h b/src/lisp/istream.h
index 882a740..bab5439 100644
--- a/src/lisp/istream.h
+++ b/src/lisp/istream.h
@@ -29,4 +29,4 @@
void del_stristream(struct istream *stristream);
struct istream *new_fistream(char *path, bool binary);
-void del_fistream(struct istream *fistream);
\ No newline at end of file
+void del_fistream(struct istream *fistream);
diff --git a/src/lisp/lib/std.c b/src/lisp/lib/std.c
index d4c4c25..85221ea 100644
--- a/src/lisp/lib/std.c
+++ b/src/lisp/lib/std.c
@@ -104,12 +104,23 @@
return val;
}
+value_t l_num_eq(value_t a, value_t b)
+{
+ if (!integerp(a) || !integerp(b))
+ {
+ return nil;
+ }
+
+ return (a >> 3) == (b >> 3) ? t : nil;
+}
+
void load_std(struct environment *env)
{
add_c_function(env, "+", l_plus, 2);
add_c_function(env, "-", l_minus, 2);
add_c_function(env, "*", l_times, 2);
add_c_function(env, "/", l_divide, 2);
+ add_c_function(env, "=", l_num_eq, 2);
add_c_function(env, "car", car, 1);
add_c_function(env, "cdr", cdr, 1);
diff --git a/src/lisp/lisp.c b/src/lisp/lisp.c
index e87b9d1..6ed3fb9 100644
--- a/src/lisp/lisp.c
+++ b/src/lisp/lisp.c
@@ -103,7 +103,7 @@
bool isallowedchar(char c)
{
return (c >= '#' && c <= '\'') || (c >= '*' && c <= '/') ||
- (c >= '>' && c <= '@');
+ (c >= '<' && c <= '@');
}
bool issymstart(char c)
@@ -125,7 +125,6 @@
int size = 8;
struct alloc *a = malloc_aligned(size + sizeof(struct alloc));
- add_this_alloc(a, SYMBOL_TAG);
char *s = (char *)(a + 1);
@@ -133,15 +132,15 @@
for (int i = 1;; i++)
{
+ if (i >= size)
+ {
+ size *= 2;
+ a = realloc_aligned(a, size + sizeof(struct alloc));
+ s = (char *)(a + 1);
+ }
+
if (issym(is->peek(is)))
{
- if (i >= size)
- {
- size *= 2;
- a = realloc_aligned(a, size + sizeof(struct alloc));
- s = (char *)(a + 1);
- }
-
s[i] = is->get(is);
}
else
@@ -150,6 +149,7 @@
*val = (value_t)s;
*val |= SYMBOL_TAG;
+ add_this_alloc(a, SYMBOL_TAG);
return true;
}
}
@@ -166,7 +166,6 @@
int size = 8;
struct alloc *a = malloc_aligned(size + sizeof(struct alloc));
- add_this_alloc(a, STRING_TAG);
char *s = (char *)(a + 1);
@@ -209,6 +208,7 @@
*val = (value_t)s;
*val |= STRING_TAG;
+ add_this_alloc(a, STRING_TAG);
return true;
}
}
@@ -276,6 +276,8 @@
*val = readn(is);
+ skipws(is);
+
if (is->peek(is) != ')')
{
is->showpos(is, stderr);
diff --git a/src/lisp/main.c b/src/lisp/main.c
index f9ad122..b0c014e 100644
--- a/src/lisp/main.c
+++ b/src/lisp/main.c
@@ -22,8 +22,15 @@
value_t (*lisp_main)() = find_function(env, "main")->def0;
- gc_set_base_here();
- lisp_main();
+ if (lisp_main)
+ {
+ gc_set_base_here();
+ lisp_main();
+ }
+ else
+ {
+ fprintf(stderr, "No MAIN function defined! nothing to do\n");
+ }
free_all();
del_env(env);
diff --git a/src/lisp/test-closures.lisp b/src/lisp/test-closures.lisp
index 39bb134..576834c 100644
--- a/src/lisp/test-closures.lisp
+++ b/src/lisp/test-closures.lisp
@@ -1,5 +1,4 @@
(defun main ()
- (print (reduce (lambda (a b)
- (+ a b))
- (list 1 2 3 4 5)
- 0)))
+ (print (reduce #'+
+ (list 1 2 3 4)
+ 0)))