From ad98504f4f46fe8a2cb52d57157c40770284d691 Mon Sep 17 00:00:00 2001 From: ~keith Date: Fri, 4 Feb 2022 15:54:34 +0000 Subject: [PATCH] (defun) and support for functions defined in Lisp --- doc/stdlib_forms.md | 18 +++++-- doc/stdlib_internals.md | 8 ++++ lisp_string.h | 2 +- main.c | 104 ++++++++++++++++++++++++++++++++++++++-- main.h | 6 +++ native_funs.c | 6 +++ native_funs.h | 1 + 7 files changed, 137 insertions(+), 8 deletions(-) diff --git a/doc/stdlib_forms.md b/doc/stdlib_forms.md index b493cd1..af0f622 100644 --- a/doc/stdlib_forms.md +++ b/doc/stdlib_forms.md @@ -4,13 +4,13 @@ other S-expressions. ## `quote` ``` -quote form +(quote form) ``` `quote` returns `form` as-is, without performing any evaluation on it. ## `cond` ``` -cond {(test {body-form}*)}* +(cond {(test {body-form}*)}*) ``` `cond` is Keithlisp's basic conditional operator. It consists of zero or more clauses (a `test`, followed by zero or more `body-form`s). @@ -23,7 +23,7 @@ or no clauses were given, `cond` returns nil. ## `let` ``` -let ({var | (var value)}*) {body-form}* +(let ({var | (var value)}*) {body-form}*) ``` `let` defines locally scoped variables in Keithlisp. It consists of a list of variable definitions, followed by zero or more `body-form`s. @@ -39,3 +39,15 @@ the last one. Before returning, it removes the topmost entry for each local variable from the syms-alist. **If a locally scoped entry was removed manually, the outer scope's corresponding entry will be removed if it exists.** + +## `defun` + +``` +(defun ({arg}*) {body-form}*) +``` +`defun` defines a new function in Keithlisp. It consists of a list of +argument definitions, followed by zero or more `body-form`s. + +An argument definition is simply the name of the locally scoped variable +which it should be bound to. `&optional`, `&rest`, and `&key` arguments +are not yet supported. diff --git a/doc/stdlib_internals.md b/doc/stdlib_internals.md index 9b1becf..5652cf9 100644 --- a/doc/stdlib_internals.md +++ b/doc/stdlib_internals.md @@ -27,3 +27,11 @@ currently defined function. original string of every atom that Keithlisp has parsed. It returns nil if the atoms-alist has been disabled. +## `fun-set!` +``` +(fun-set! name value) +``` +`fun-set!` directly modifies the funs-alist, creating a new association +defining `name` as `value`. It returns the entry it has created. This is +more or less the equivalent of `set` for function definitions. + diff --git a/lisp_string.h b/lisp_string.h index fb193f9..19fbd28 100644 --- a/lisp_string.h +++ b/lisp_string.h @@ -16,7 +16,7 @@ __attribute__((always_inline)) static inline char* lisp_string_data(lisp_string* char* lisp_string_create(char* str); char* lisp_string_create_raw(char* buf, int len); char* lisp_string_alloc(int len); -char* lisp_string_copy(lisp_string* lstr); +lisp_string* lisp_string_copy(lisp_string* lstr); int lisp_string_cmp(lisp_string* a_lstr, lisp_string* b_lstr); void lisp_string_print(lisp_string* lstr); diff --git a/main.c b/main.c index 7a5a925..bbab43f 100644 --- a/main.c +++ b/main.c @@ -212,6 +212,16 @@ lisp_atom lisp_defun_native(lisp_string* lstr, lisp_native_fun funptr) { return atom; } +lisp_cons* lisp_defun_lisp_fun(lisp_atom atom, lisp_cons* fun) { + lisp_cons* cons = dbg_malloc(sizeof(lisp_cons)); + cons->car.type = LISP_T_ATOM; + cons->car.value.atom = atom; + cons->cdr.type = LISP_T_CONS; + cons->cdr.value.cons = fun; + lisp_alist_put(&funs_alist, cons); + return cons; +} + void lisp_evaluate_value(lisp_value input, lisp_value* result) { if (input.type == LISP_T_ATOM) { if (input.value.atom == atom_t) { @@ -233,18 +243,22 @@ void lisp_evaluate_value(lisp_value input, lisp_value* result) { void lisp_evaluate(lisp_cons* cons, lisp_value* value) { value->type = LISP_T_CONS; value->value.cons = NULL; + + // can't use a switch here if (cons->car.value.atom == atom_quote) { *value = cons->cdr.value.cons->car; return; - } - if (cons->car.value.atom == atom_cond) { + } else if (cons->car.value.atom == atom_cond) { lisp_sform_cond(cons->cdr.value.cons, value); return; - } - if (cons->car.value.atom == atom_let) { + } else if (cons->car.value.atom == atom_let) { lisp_sform_let(cons->cdr.value.cons, value); return; + } else if (cons->car.value.atom == atom_defun) { + lisp_sform_defun(cons->cdr.value.cons, value); + return; } + lisp_cons* fun_cons = lisp_alist_get(funs_alist, cons->car); if (fun_cons == NULL) { fprintf(stderr, "EVAL ERROR! (no such fun)\n"); @@ -276,6 +290,9 @@ void lisp_evaluate(lisp_cons* cons, lisp_value* value) { dbg_free(args); args = args_tail; } + } else if (fun_cons->cdr.type == LISP_T_CONS) { + // lisp-fun + lisp_evaluate_lisp_fun(fun_cons->cdr.value.cons, args, value); } else { fprintf(stderr, "EVAL ERROR! (not a native-fun)\n"); return; @@ -344,6 +361,84 @@ void lisp_sform_let(lisp_cons* cons, lisp_value* value) { vars_head = vars_head->cdr.value.cons; } } +lisp_atom atom_defun; +void lisp_sform_defun(lisp_cons* cons, lisp_value* value) { + lisp_atom fun_name = cons->car.value.atom; + lisp_cons* fun_data = recursive_copy(cons->cdr.value.cons); + + lisp_defun_lisp_fun(fun_name, fun_data); + value->type = LISP_T_CONS; + value->value.cons = fun_data; +} + +lisp_cons* recursive_copy(lisp_cons* cons) { + lisp_cons* new_cons = dbg_malloc(sizeof(lisp_cons)); + lisp_cons* new_root = new_cons; + while (cons != NULL) { + new_cons->car = cons->car; + new_cons->cdr = cons->cdr; + + if (cons->car.type == LISP_T_STRING) + new_cons->car.value.string = lisp_string_copy(cons->car.value.string); + else if (cons->car.type == LISP_T_CONS) + new_cons->car.value.cons = recursive_copy(cons->car.value.cons); + + if (cons->cdr.type == LISP_T_STRING) + new_cons->cdr.value.string = lisp_string_copy(cons->cdr.value.string); + + if (cons->cdr.type == LISP_T_CONS && cons->cdr.value.cons != NULL) { + cons = cons->cdr.value.cons; + new_cons->cdr.value.cons = dbg_malloc(sizeof(lisp_cons)); + new_cons = new_cons->cdr.value.cons; + } else { + cons = NULL; + } + } + return new_root; +} + +void lisp_evaluate_lisp_fun(lisp_cons* fun, lisp_cons* args, lisp_value* value) { + // allocate local vars + lisp_cons* head = fun->car.value.cons; + while (head != NULL) { + // create cons pair for new var + lisp_cons* pair = dbg_malloc(sizeof(lisp_cons)); + pair->car.type = LISP_T_ATOM; + pair->car.value.atom = head->car.value.atom; + pair->cdr = args->car; + args = args->cdr.value.cons; + // add to alist + lisp_cons* new_alist = dbg_malloc(sizeof(lisp_cons)); + new_alist->car.type = LISP_T_CONS; + new_alist->car.value.cons = pair; + new_alist->cdr.type = LISP_T_CONS; + new_alist->cdr.value.cons = syms_alist; + syms_alist = new_alist; + + head = head->cdr.value.cons; + } + + // evaluate body + head = fun->cdr.value.cons; + while (head != NULL) { + lisp_evaluate_value(head->car, value); + head = head->cdr.value.cons; + } + + // delete local vars + head = fun->car.value.cons; + while (head != NULL) { + lisp_value key; + if (head->car.type == LISP_T_CONS) + key = head->car.value.cons->car; + else + key = head->car; + lisp_cons* pair = lisp_alist_del(&syms_alist, key); + dbg_free(pair); + + head = head->cdr.value.cons; + } +} lisp_atom atom_cons; lisp_atom atom_atom; @@ -362,6 +457,7 @@ int main() { atom_cond = lisp_atom_init(lisp_string_create("cond")); atom_let = lisp_atom_init(lisp_string_create("let")); + atom_defun = lisp_atom_init(lisp_string_create("defun")); atom_cons = lisp_atom_init(lisp_string_create("cons")); atom_atom = lisp_atom_init(lisp_string_create("atom")); diff --git a/main.h b/main.h index 6b286c9..2f802e8 100644 --- a/main.h +++ b/main.h @@ -54,6 +54,7 @@ void print_cons(lisp_cons* cons); void print_value(lisp_value value); lisp_atom lisp_defun_native(lisp_string* lstr, lisp_native_fun funptr); +lisp_cons* lisp_defun_lisp_fun(lisp_atom atom, lisp_cons* fun); void lisp_evaluate_value(lisp_value input, lisp_value* result); void lisp_evaluate(lisp_cons* cons, lisp_value* value); @@ -61,5 +62,10 @@ extern lisp_atom atom_cond; void lisp_sform_cond(lisp_cons* cons, lisp_value* value); extern lisp_atom atom_let; void lisp_sform_let(lisp_cons* cons, lisp_value* value); +extern lisp_atom atom_defun; +void lisp_sform_defun(lisp_cons* cons, lisp_value* value); +lisp_cons* recursive_copy(lisp_cons* cons); + +void lisp_evaluate_lisp_fun(lisp_cons* fun, lisp_cons* args, lisp_value* value); #endif diff --git a/native_funs.c b/native_funs.c index e9adab4..af8b4fa 100644 --- a/native_funs.c +++ b/native_funs.c @@ -641,6 +641,11 @@ void lispf_internals_atoms_alist(lisp_cons* cons, lisp_value* value) { value->value.cons = atoms_alist; } +void lispf_internals_fun_set(lisp_cons* cons, lisp_value* value) { + value->type = LISP_T_CONS; + value->value.cons = lisp_defun_lisp_fun(cons->car.value.atom, cons->cdr.value.cons->car.value.cons); +} + void init_native_funs() { // arithmetic lisp_defun_native(lisp_string_create("+"), &lispf_add); @@ -692,4 +697,5 @@ void init_native_funs() { lisp_defun_native(lisp_string_create("syms-alist!"), &lispf_internals_syms_alist); lisp_defun_native(lisp_string_create("funs-alist!"), &lispf_internals_funs_alist); lisp_defun_native(lisp_string_create("atoms-alist!"), &lispf_internals_atoms_alist); + lisp_defun_native(lisp_string_create("fun-set!"), &lispf_internals_fun_set); } diff --git a/native_funs.h b/native_funs.h index 151987e..97f2cdd 100644 --- a/native_funs.h +++ b/native_funs.h @@ -51,6 +51,7 @@ void lispf_print(lisp_cons* cons, lisp_value* value); void lispf_internals_syms_alist(lisp_cons* cons, lisp_value* value); void lispf_internals_funs_alist(lisp_cons* cons, lisp_value* value); void lispf_internals_atoms_alist(lisp_cons* cons, lisp_value* value); +void lispf_internals_fun_set(lisp_cons* cons, lisp_value* value); void init_native_funs(); #endif