jonas/tli
2
1
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

some rework

Browse Source
This commit is contained in:
Jonas Maier 2022-12-18 19:45:08 +01:00
parent acff699d2c
commit 280c4bd02a
8 changed files with 176 additions and 150 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

82
builtins.c
View File

@ -31,7 +31,6 @@ static int c_eq(ptr a, ptr b)
static ptr eq(ptr i)
{
i = eval_elems(i);
ptr a = elem(0, i);
ptr b = elem(1, i);
return c_eq(a, b) ? new_true() : new_nil();
@ -40,7 +39,6 @@ static ptr eq(ptr i)
#define _ORD_(name, cmp) \
static ptr name(ptr a) \
{ \
a = eval_elems(a); \
if (kind(a) == T_NIL) \
{ \
return new_true(); \
@ -71,7 +69,6 @@ _ORD_(gte, >=)
#define _ARITH_(name, op, init) \
static ptr name(ptr a) \
{ \
a = eval_elems(a); \
i64 val = init; \
while (kind(a) == T_CON) \
{ \
@ -85,7 +82,6 @@ _ARITH_(prod, *, 1)
static ptr minus(ptr i)
{
i = eval_elems(i);
ptr arg0 = get_head(i);
if (kind(get_tail(i)) != T_NIL)
{
@ -100,20 +96,17 @@ static ptr minus(ptr i)
static ptr div(ptr i)
{
i = eval_elems(i);
return new_int(get_int(elem(0, i)) / get_int(elem(1, i)));
}
static ptr mod(ptr i)
{
i = eval_elems(i);
return new_int(get_int(elem(0, i)) % get_int(elem(1, i)));
}
#define _CMP_(name, _kind) \
static ptr name(ptr i) \
{ \
i = eval_elems(i); \
i = get_head(i); \
if (i < 0 || kind(i) != _kind) \
{ \
@ -131,7 +124,6 @@ _CMP_(is_pair, T_CON)
static ptr is_list(ptr i)
{
i = eval_elems(i);
i = get_head(i);
while (i >= 0 && kind(i) == T_CON)
{
@ -233,7 +225,6 @@ static ptr eval_cond(ptr i)
static ptr cons(ptr i)
{
i = eval_elems(i);
ptr hd = elem(0, i);
ptr tl = elem(1, i);
return new_cons(hd, tl);
@ -241,17 +232,16 @@ static ptr cons(ptr i)
static ptr head(ptr i)
{
return get_head(get_head(eval_elems(i)));
return get_head(get_head(i));
}
static ptr tail(ptr i)
{
return get_tail(get_head(eval_elems(i)));
return get_tail(get_head(i));
}
static ptr el(ptr i)
{
i = eval_elems(i);
ptr idx = elem(0, i);
ptr list = elem(1, i);
return elem(get_int(idx), list);
@ -259,13 +249,11 @@ static ptr el(ptr i)
static ptr list(ptr i)
{
i = eval_elems(i);
return i;
}
static ptr panic(ptr i)
{
i = eval_elems(i);
printf("error: ");
println(get_head(i));
failwith("explicit panic");
@ -274,7 +262,6 @@ static ptr panic(ptr i)
static ptr concat_sym(ptr i)
{
i = eval_elems(i);
int len = 0;
ptr cursor = i;
while (kind(cursor) == T_CON)
@ -298,7 +285,6 @@ static ptr concat_sym(ptr i)
static ptr progn(ptr i)
{
i = eval_elems(i);
ptr result = new_nil();
while (kind(i) == T_CON)
{
@ -310,7 +296,6 @@ static ptr progn(ptr i)
static ptr read(ptr i)
{
i = eval_elems(i);
i = get_head(i);
ptr cursor = i;
@ -321,7 +306,7 @@ static ptr read(ptr i)
cursor = get_tail(cursor);
}
printf("%d\n\n", size);
printf("%ld\n\n", size);
char buf[size+1];
cursor = i;
@ -341,38 +326,45 @@ static ptr read(ptr i)
void register_builtins(void)
{
new_builtin(&eq, "=");
new_builtin(&lt, "<");
new_builtin(&gt, ">");
new_builtin(&lte, "<=");
new_builtin(&gte, ">=");
#define new_builtin_mc(a, b) new_builtin(a, b, T_MAC)
#define new_builtin_fn(a, b) new_builtin(a, b, T_FUN)
new_builtin(&sum, "+");
new_builtin(&prod, "*");
new_builtin(&minus, "-");
new_builtin(&div, "/");
new_builtin(&mod, "%");
new_builtin_mc(&eval_cond, "cond");
new_builtin_mc(&eval_quasiquote, "quasiquote");
new_builtin_mc(&eval_quote, "quote");
new_builtin(&is_nil, "nil?");
new_builtin(&is_int, "int?");
new_builtin(&is_sym, "sym?");
new_builtin(&is_pair, "pair?");
new_builtin(&is_list, "list?");
new_builtin_fn(&eq, "=");
new_builtin(&read, "read");
new_builtin(&eval_quote, "quote");
new_builtin(&eval_quasiquote, "quasiquote");
new_builtin_fn(&lt, "<");
new_builtin_fn(&gt, ">");
new_builtin_fn(&lte, "<=");
new_builtin_fn(&gte, ">=");
new_builtin(&eval_cond, "cond");
new_builtin_fn(&sum, "+");
new_builtin_fn(&prod, "*");
new_builtin_fn(&minus, "-");
new_builtin_fn(&div, "/");
new_builtin_fn(&mod, "%");
new_builtin(&cons, "cons");
new_builtin(&list, "list");
new_builtin(&head, "hd");
new_builtin(&tail, "tl");
new_builtin(&el, "el");
new_builtin_fn(&is_nil, "nil?");
new_builtin_fn(&is_int, "int?");
new_builtin_fn(&is_sym, "sym?");
new_builtin_fn(&is_pair, "pair?");
new_builtin_fn(&is_list, "list?");
new_builtin(&panic, "panic");
new_builtin(&concat_sym, "symcat");
new_builtin(&progn, "progn");
new_builtin_fn(&read, "read");
new_builtin_fn(&cons, "cons");
new_builtin_fn(&list, "list");
new_builtin_fn(&head, "hd");
new_builtin_fn(&tail, "tl");
new_builtin_fn(&el, "el");
new_builtin_fn(&panic, "panic");
new_builtin_fn(&concat_sym, "symcat");
new_builtin_fn(&progn, "progn");
#undef new_builtin_mc
#undef new_builtin_fn
}

30
eval.c
View File

@ -1,19 +1,8 @@
#include "lisp.h"
#include "assert.h"
static ptr (*builtins[MAX_BUILTINS])(ptr) = {0};
static int builtins_len = 1;
static int debug = 0;
void new_builtin(ptr (*fun)(ptr), char *sym)
{
assert(builtins_len < MAX_BUILTINS);
int idx = -builtins_len;
builtins[builtins_len++] = fun;
ptr s = new_symbol(sym);
new_binding(s, idx);
}
static ptr beta_reduce(ptr code, ptr formal_arg, ptr arg, int inside_quote)
{
switch (kind(code))
@ -93,15 +82,18 @@ static ptr beta_reduce(ptr code, ptr formal_arg, ptr arg, int inside_quote)
}
}
ptr eval_elems(ptr is);
ptr eval(ptr i)
{
if (debug) {
if (debug)
{
printf("[DEBUG] ");
println(i);
}
switch (kind(i))
{
case T_NAT:
case T_FUN:
case T_MAC:
case T_NIL:
case T_INT:
return i;
@ -112,7 +104,7 @@ ptr eval(ptr i)
if (kind(bind) == T_POO)
{
printf("`%s` is unbound.\n", get_symbol_str(sym));
failwith("");
assert(false);
}
return bind;
}
@ -134,10 +126,14 @@ ptr eval(ptr i)
ptr fun = eval(head);
ptr args = get_tail(i);
if (kind(fun) == T_NAT)
if (kind(fun) == T_FUN)
{
// builtins behave like macros by default, evaluation must be done by the function itself
return builtins[-fun](args);
return get_fn_ptr(fun)(eval_elems(args));
}
if (kind(fun) == T_MAC)
{
return get_fn_ptr(fun)(args);
}
if (is_pragma(fun))

104
lisp
View File

@ -24,6 +24,20 @@
)
))
(def defmacro (m\ (name args body)
`(def #name (m\ #args #body))
))
(defmacro defun (name args body)
`(def #name (.\ #args #body))
)
(defun flatten(xss)
(cond
(xss (fold (hd xss) concat (tl xss)))
)
)
(def rev.aux (.\ (items revd)
(cond
((nil? items) revd)
@ -56,14 +70,6 @@
(def partial-add (.\ (a) (.\ (b) (+ a b))))
(partial-add 4)
(def defmacro (m\ (name args body)
`(def #name (m\ #args #body))
))
(defmacro defun (name args body)
`(def #name (.\ #args #body))
)
(defun /= (x y) (nil? (= x y)))
(defun square(x) (* x x))
@ -263,31 +269,55 @@
(defun any?(x) 1)
(defmacro defstruct(name fields)
(cons 'progn
(cons `(defun #(symcat name '?) (instance)
(flatten (list '(progn)
;; 'type checking' - checks if it is a struct instance of this type
`((defun #(symcat name '?) (instance)
(cond
((nil? (pair? instance)) nil)
((= (el 0 instance) '#name) 1)
((nil? (pair? instance)) false)
(else (= (el 0 instance) '#name))
)
)
(cons (list typedfun name fields `(list '#name #(cons 'list (map snd fields))))
(mapi
(.\ (idx field)
`(defun #(symcat name '. (snd field)) (instance)
(el #idx (el 1 instance))
)
))
;; constructor of the struct
`((typedfun #name #fields
#`(list '#name #(cons 'list (map snd fields)))
))
;; accessors of the struct
(mapi
(.\ (idx field)
`(defun #(symcat name '. (snd field)) (instance)
(el #idx (el 1 instance))
)
fields)
))))
)
fields)
;; editing fields of the struct
(mapi
(.\ (idx field)
`(defun #(symcat name '. (snd field) '!) (instance new_val)
#(cons name (mapi (.\ (val_idx field2)
(cond
((= idx val_idx) 'new_val)
(else `(#(symcat name '. (snd field2)) instance))
)
) fields))
)
)
fields)
)))
(defstruct Point(
(int? x)
(int? y)
))
'Point
Point.x
Point.y
Point.x!
Point.y!
Point
(def p (Point 111 222))
@ -406,10 +436,6 @@ Point
(filter id (cons (fst sol) (snd sol))))
)
(defun flatten(xss)
(fold (hd xss) concat (tl xss))
)
(defun half(xs)
(let half_len (/ (len xs) 2)
(list
@ -433,10 +459,6 @@ Point
(cond (a (cond (b true))))
)
(defun range(begin end)
(iter (- end begin) succ begin)
)
(def in
(map (.\ (l) (drop 6 l))
(filter id
@ -549,26 +571,4 @@ names
)
)
dist0
(fold
dist0
(.\ (dist edge)
(fold
dist
(.\ (d entry)
(let from (fst edge)
(let to (snd (key entry))
(let len (+ 1 (val entry))
(let e `(#from #to)
(map.update_or d e infty (smoler .. len))
)))))
(filter (.\ (entry) (= (snd edge) (fst (key entry)))) dist)
)
)
(repeat 30 edges)
)
(= edges (repeat 1 edges))
'(end of program)

13
lisp.h
View File

@ -16,7 +16,8 @@ typedef int64_t i64;
#define T_CON 3 // cons, i.e. a pair
#define T_SYM 4 // symbol
#define T_EMT 5 // empty
#define T_NAT 6 // natively implemented function
#define T_FUN 6 // builtin function
#define T_MAC 7 // builtin macro
typedef struct
{
@ -32,9 +33,13 @@ typedef struct
// tail of cons
ptr tail;
};
// pointer to the symbol
ptr symbol;
// if builtin function or macro, function pointer
ptr (*builtin)(ptr);
// if not in use, point to next free node
ptr next_free;
ptr _data[2];
@ -54,7 +59,6 @@ typedef struct
void init(void);
void new_builtin(ptr (*fun)(ptr), char *sym);
void new_binding(ptr symbol, ptr expression);
void register_builtins(void);
@ -65,6 +69,7 @@ ptr new_nil(void);
ptr new_list(int len, ...);
ptr new_true(void);
ptr new_symbol(char *symbol);
ptr new_builtin(ptr (*fun)(ptr), char *sym, int kind);
ptr quoted(ptr i);
// garbage collection
@ -82,14 +87,12 @@ ptr get_tail(ptr i);
ptr elem(int idx, ptr node);
char *get_symbol_str(ptr s);
ptr get_symbol_binding(ptr s);
ptr (*get_fn_ptr(ptr i))(ptr);
// eval an expression
// might have side effects
ptr eval(ptr i);
// eval list, element-wise
ptr eval_elems(ptr is);
int is_quote(ptr i);
int is_quasiquote(ptr i);
int is_unquote(ptr i);

77
mem.c
View File

@ -22,16 +22,18 @@ static ptr builtin_use;
{ \
return i == sym_##name; \
}
make(quote);
make(unquote);
make(quasiquote);
make(lambda);
make(macro);
make(definition);
make(partial_app);
make(pragma);
make(quote)
make(unquote)
make(quasiquote)
make(lambda)
make(macro)
make(definition)
make(partial_app)
make(pragma)
#undef make
#define UNBOUND 2
int is_functionlike(ptr i)
{
return i == sym_lambda || i == sym_macro;
@ -93,25 +95,30 @@ void read_input(void)
free(buf);
}
#define MEM_UNINIT 0
#define MEM_INITIALIZING 1
#define MEM_INITIALIZED 2
static int initialized = MEM_UNINIT;
/*
initializes the interpreter
do NOT call twice
*/
void init(void)
{
static int initialized = 0;
if (initialized)
{
failwith("already initialized");
failwith("already initialized or in the process of doing so");
}
initialized = 1;
initialized = MEM_INITIALIZING;
mem[0].kind = T_NIL;
mem[1].kind = T_INT;
mem[1].value = 1;
mem[2].kind = T_POO;
assert(UNBOUND == 2);
mem[UNBOUND].kind = T_POO;
empty = 3;
for (int i = 3; i < MEM_LEN; ++i)
@ -131,6 +138,7 @@ void init(void)
register_builtins();
builtin_use = empty;
read_input();
initialized = MEM_INITIALIZED;
}
/* GC run count */
@ -144,10 +152,7 @@ static void mark_globals(void)
if (symbols[s].name[0] != 0)
{
int binding = symbols[s].binding;
if (kind(binding) != T_NAT)
{
mem[binding].gc = gen;
}
mem[binding].gc = gen;
}
}
}
@ -160,8 +165,8 @@ if it finds any, it marks those values as 'in use'
*/
void stack_search_impl(void)
{
ptr dummy = 0;
walker = &dummy;
ptr stack_bottom = 0;
walker = &stack_bottom;
while (++walker != stack_top)
{
if (*walker<MEM_LEN && * walker> 0)
@ -358,6 +363,17 @@ ptr quoted(ptr i)
}
}
ptr new_builtin(ptr (*fun)(ptr), char *sym, int kind)
{
ptr i = alloc();
assert(kind == T_FUN || kind == T_MAC);
mem[i].kind = kind;
mem[i].builtin = fun;
ptr s = new_symbol(sym);
new_binding(s, i);
return i;
}
ptr new_symbol(char *symbol)
{
if (!strcmp(symbol, "nil") || !strcmp(symbol, "NIL"))
@ -382,7 +398,7 @@ ptr new_symbol(char *symbol)
strcpy(symbols[k].name, symbol);
symbols[k].binding = 2; // point to garbage
symbols[k].binding = UNBOUND; // point to garbage
symbols[k].node = i;
return i;
}
@ -397,15 +413,9 @@ ptr new_symbol(char *symbol)
i64 kind(ptr i)
{
assert(i >= 0);
assert(i < MEM_LEN);
if (i < 0)
{
return T_NAT;
}
else
{
return mem[i].kind;
}
return mem[i].kind;
}
i64 get_int(ptr i)
@ -415,6 +425,12 @@ i64 get_int(ptr i)
return mem[i].value;
}
ptr (*get_fn_ptr(ptr i))(ptr)
{
assert(kind(i) == T_FUN || kind(i) == T_MAC);
return mem[i].builtin;
}
ptr get_head(ptr i)
{
check(i);
@ -458,5 +474,10 @@ ptr get_nil(ptr i)
void new_binding(ptr symbol, ptr expression)
{
symbols[get_symbol(symbol)].binding = expression;
sym_t *sym = &symbols[get_symbol(symbol)];
if (sym->binding != UNBOUND) {
printf("Definitions cannot be shadowed.\nOffending symbol: %s.\n", &sym->name[0]);
assert(initialized == MEM_INITIALIZING);
}
sym->binding = expression;
}

9
parse.c
View File

@ -141,6 +141,15 @@ ptr parse(char **input)
++*input;
return new_list(2, new_symbol("quote"), parse_string(input, 0));
}
else if (**input == ';')
{
// begin comment
while (**input != '\n')
{
++*input;
}
return parse(input);
}
else
{
// symbol

7
print.c
View File

@ -27,8 +27,11 @@ void print(ptr i)
{
switch (kind(i))
{
case T_NAT:
printf("<builtin>");
case T_FUN:
printf("<builtin fun>");
return;
case T_MAC:
printf("<builtin macro>");
return;
case T_INT:
printf("%ld", get_int(i));

4
run.sh
View File

@ -1,9 +1,11 @@
#! /bin/sh
rm lisp.bin
gcc -g -Oz *.c *.s \
-o lisp.bin \
-std=c17 -pedantic -Wall -Wshadow -Wpointer-arith -Wcast-qual \
-Wstrict-prototypes -Wmissing-prototypes
-Wstrict-prototypes
./lisp.bin