Add basic lexenv support

src/base.c

@@ -3,6 +3,7 @@
 #include "gc.h"
 #include "hashtable.h"
 #include "lisp.h"
+#include "list.h"
 #include "stack.h"
 
 #include <stdio.h>
@@ -75,7 +76,7 @@ DEFUN(id, "id", (LispVal * obj), "(id)", "") {
 }
 
 DEFUN(eq, "eq", (LispVal * obj1, LispVal *obj2), "(obj1 obj2)", "") {
-    return obj1 == obj2 ? Qt : Qnil;
+    return EQ(obj1, obj2) ? Qt : Qnil;
 }
 
 DEFSPECIAL(quote, "quote", (LispVal * form), "(form)", "") {

src/base.h

@@ -282,6 +282,10 @@ static ALWAYS_INLINE bool NILP(LispVal *val) {
     return val == Qnil;
 }
 
+static ALWAYS_INLINE bool EQ(LispVal *val1, LispVal *val2) {
+    return val1 == val2;
+}
+
 // Some core functions
 DECLARE_FUNCTION(id, (LispVal * obj));
 DECLARE_FUNCTION(eq, (LispVal * obj1, LispVal *obj2));

src/function.c

@@ -106,7 +106,7 @@ void parse_lambda_list(LambdaListParseResult *result, LispVal *list) {
     out->kw = Qnil;
     out->rest = Qnil;
     size_t cur_idx = 0; // for keyword args
-    FOREACH_TAIL(list, tail) {
+    DOTAILS(tail, list) {
         if (!LISTP(tail)) {
             RETURN_ERROR(LLPS_DOTTED, list);
         } else if (out->allow_other_keys) {
@@ -178,7 +178,7 @@ void parse_lambda_list(LambdaListParseResult *result, LispVal *list) {
 }
 #undef RETURN_ERROR
 
-LispVal *make_builtin_function(LispVal *name, LispVal *(*cfunc)(),
+LispVal *make_builtin_function(LispVal *name, LispVal *(*cfunc)(void),
                                const char *lisp_args, size_t args_len,
                                LispVal *docstr) {
     LispFunction *obj = lisp_alloc_object(sizeof(LispFunction), TYPE_FUNCTION);
@@ -230,11 +230,11 @@ call_simple_native(LispVal *orig_func, LispFunction *fobj, LispVal *args) {
     }
     LispVal *arg_arr[MAX_NATIVE_FUNCTION_ARGS];
     size_t acount = 0;
-    FOREACH(args, arg) {
+    DOLIST(arg, args) {
         if (fobj->flags.no_eval_args) {
             arg_arr[acount] = arg;
         } else {
-            arg_arr[acount] = Feval(arg);
+            arg_arr[acount] = Feval(arg, PARENT_LEXENV());
         }
         add_local_reference(arg_arr[acount++]);
     }
@@ -361,7 +361,7 @@ call_complex_native(LispVal *orig_func, LispFunction *fobj, LispVal *args) {
         if (!arg_arr[i]) {
             arg_arr[i] = Qnil;
         } else if (!fobj->flags.no_eval_args) {
-            arg_arr[i] = Feval(arg_arr[i]);
+            arg_arr[i] = Feval(arg_arr[i], PARENT_LEXENV());
         }
         add_local_reference(arg_arr[i]);
     }

src/function.h

@@ -2,7 +2,6 @@
 #define INCLUDED_FUNCTION_H
 
 #include "base.h"
-#include "lisp_string.h"
 
 DECLARE_SYMBOL(and_optional);
 DECLARE_SYMBOL(and_rest);

src/hashtable.c

@@ -56,7 +56,7 @@ static uintptr_t hash_key_for_table(LispHashTable *ht, LispVal *key) {
 
 static bool compare_keys(LispHashTable *ht, LispVal *key1, LispVal *key2) {
     if (NILP(ht->eq_fn) || ht->eq_fn == Qeq) {
-        return key1 == key2;
+        return EQ(key1, key2);
     } else if (ht->eq_fn == Qstrings_equal) { // needed for initialization
         return !NILP(Fstrings_equal(key1, key2));
     }

src/lisp.c

@@ -57,7 +57,23 @@ void lisp_shutdown(void) {
     lisp_teardown_stack();
 }
 
-DEFUN(eval, "eval", (LispVal * form), "(form)", "") {
+static inline LispVal *lookup_variable(LispSymbol *name, LispVal *lexenv) {
+    LispVal *lexval = Fplist_get(lexenv, name, Qunbound);
+    if (lexval != Qunbound) {
+        return lexval;
+    }
+    if (name->value == Qunbound) {
+        // TODO better error
+        printf("Unbound symbol: ");
+        debug_print(stdout, name);
+        fputc('\n', stdout);
+        abort();
+    }
+    return name->value;
+}
+
+DEFUN(eval, "eval", (LispVal * form, LispVal *lexenv),
+      "(form &optional lexenv)", "") {
     if (!OBJECTP(form)) {
         // fixnum or float
         return form;
@@ -75,21 +91,12 @@ DEFUN(eval, "eval", (LispVal * form), "(form)", "") {
             out_data[i] = Qnil;
         }
         for (size_t i = 0; i < vec->length; ++i) {
-            out_data[i] = Feval(vec->data[i]);
+            out_data[i] = Feval(vec->data[i], lexenv);
         }
         return newvec;
     }
-    case TYPE_SYMBOL: {
-        // TODO local bindings
-        LispSymbol *sym = form;
-        if (sym->value == Qunbound) {
-            printf("Unbound symbol: ");
-            debug_print(stdout, form);
-            fputc('\n', stdout);
-            abort();
-        }
-        return sym->value;
-    }
+    case TYPE_SYMBOL:
+        return lookup_variable(form, lexenv);
     case TYPE_CONS: {
         return Ffuncall(XCAR(form), XCDR(form));
     }
@@ -131,7 +138,7 @@ void debug_print(FILE *file, LispVal *obj) {
     }
     case TYPE_CONS: {
         fputc('(', file);
-        FOREACH_TAIL(obj, tail) {
+        DOTAILS(tail, obj) {
             if (CONSP(tail)) {
                 debug_print(file, XCAR(tail));
                 if (!NILP(XCDR(tail))) {
@@ -162,6 +169,32 @@ void debug_print(FILE *file, LispVal *obj) {
     }
 }
 
+DEFSPECIAL(progn, "progn", (LispVal * forms), "(&rest forms)", "") {
+    LispVal *rval = Qnil;
+    DOLIST(form, forms) {
+        rval = Feval(form, TOP_LEXENV());
+    }
+    return rval;
+}
+
+DEFSPECIAL(let, "let", (LispVal * bindings, LispVal *body),
+           "(bindings &rest body)", "") {
+    CHECK_LISTP(bindings);
+    copy_parent_lexenv();
+    DOLIST(binding, bindings) {
+        if (SYMBOLP(binding)) {
+            new_lexical_variable(binding, Qnil);
+        } else if (CONSP(binding) && list_length_eq(binding, 2)) {
+            new_lexical_variable(FIRST(binding),
+                                 Feval(SECOND(binding), TOP_LEXENV()));
+        } else {
+            // TODO better error
+            abort();
+        }
+    }
+    return Fprogn(body);
+}
+
 void debug_obj_info(FILE *file, LispVal *obj) {
     fprintf(file, "%s -> ", LISP_TYPE_NAMES[TYPE_OF(obj)]);
     debug_print(file, obj);

src/lisp.h

@@ -16,7 +16,9 @@ void lisp_init(void);
 
 void lisp_shutdown(void);
 
-DECLARE_FUNCTION(eval, (LispVal * form));
+DECLARE_FUNCTION(eval, (LispVal * form, LispVal *lexenv));
+DECLARE_FUNCTION(progn, (LispVal * forms));
+DECLARE_FUNCTION(let, (LispVal * bindings, LispVal *body));
 
 __attribute__((no_sanitize("address"))) void debug_print(FILE *file,
                                                          LispVal *obj);

src/list.c

@@ -60,3 +60,26 @@ DEFUN(listp, "listp", (LispVal * obj), "(obj)", "") {
 DEFUN(list, "list", (LispVal * args), "(&rest args)", "") {
     return args;
 }
+
+DEFUN(plist_put, "plist-put", (LispVal * plist, LispVal *prop, LispVal *value),
+      "(plist prop value)", "") {
+    CHECK_LISTP(plist);
+    DOTAILS(rest, plist) {
+        if (EQ(XCAR(rest), prop)) {
+            RPLACA(XCDR(rest), value);
+            return plist;
+        }
+    }
+    return CONS(prop, CONS(value, plist));
+}
+
+DEFUN(plist_get, "plist-get", (LispVal * plist, LispVal *prop, LispVal *def),
+      "(plist prop &optional default)", "") {
+    CHECK_LISTP(plist);
+    DOTAILS(rest, plist) {
+        if (EQ(XCAR(rest), prop)) {
+            return SECOND(rest);
+        }
+    }
+    return def;
+}

src/list.h

@@ -99,11 +99,11 @@ static ALWAYS_INLINE LispVal *LIST_N(int count, ...) {
 #define FOURTH(x) XCAR(XCDR(XCDR(XCDR(x))))
 #define FIFTH(x)  XCAR(XCDR(XCDR(XCDR(XCDR(x)))))
 
-#define FOREACH(l, v)                                          \
+#define DOLIST(v, l)                                           \
     for (LispVal *_tail = (l), *v = XCAR(_tail); !NILP(_tail); \
          _tail = XCDR(_tail), v = XCAR(_tail))
 
-#define FOREACH_TAIL(l, v) for (LispVal *v = (l); !NILP(v); v = XCDR_SAFE(v))
+#define DOTAILS(v, l) for (LispVal *v = (l); !NILP(v); v = XCDR_SAFE(v))
 
 // return -1 list is circular
 intptr_t list_length(LispVal *list);
@@ -122,4 +122,7 @@ static ALWAYS_INLINE void CHECK_LISTP(LispVal *obj) {
     }
 }
 
+DECLARE_FUNCTION(plist_put, (LispVal * plist, LispVal *prop, LispVal *value));
+DECLARE_FUNCTION(plist_get, (LispVal * plist, LispVal *prop, LispVal *def));
+
 #endif

src/main.c

@@ -1,26 +1,20 @@
 #include "lisp.h"
 #include "read.h"
 
-#include <stdio.h>
-
-DEFUN(cool_func, "cool-func", (LispVal * a, LispVal *b), "(a &optional b)",
-      "") {
-    printf("A: ");
-    debug_obj_info(stdout, a);
-    printf("B: ");
-    debug_obj_info(stdout, b);
+DEFUN(print, "print", (LispVal * v), "(v)", "") {
+    debug_obj_info(stdout, v);
     return Qnil;
 }
 
 int main(int argc, const char **argv) {
     lisp_init();
-    REGISTER_GLOBAL_FUNCTION(cool_func);
+    REGISTER_GLOBAL_FUNCTION(print);
     push_stack_frame(Qnil, Qnil, Qnil);
     ReadStream s;
-    const char BUF[] = "(cool-func 1 (cons 1 2))";
+    const char BUF[] = "(let ((a 1)) (print a))";
     read_stream_init(&s, BUF, sizeof(BUF) - 1);
     LispVal *l = read(&s);
-    Feval(l);
+    Feval(l, Qnil);
     lisp_gc_now(NULL);
     pop_stack_frame();
     lisp_shutdown();

src/stack.c

@@ -161,7 +161,7 @@ static inline void add_local_refs_for_object_sub_vals(LispVal *seen_objs,
         break;
     }
     case TYPE_STRING:
-        // ho held refs
+        // no held refs
         break;
     case TYPE_FIXNUM:
     case TYPE_FLOAT:
@@ -190,3 +190,31 @@ void compact_stack_frame(struct StackFrame *restrict frame) {
     lisp_realloc(refs->blocks, sizeof(struct LocalReferencesBlock *));
     refs->num_blocks = 1;
 }
+
+bool set_lexical_variable(LispVal *name, LispVal *value,
+                          bool create_if_absent) {
+    assert(the_stack.depth != 0);
+    DOTAILS(rest, LISP_STACK_TOP()->lexenv) {
+        if (EQ(XCAR(rest), name)) {
+            RPLACA(XCDR(rest), value);
+            return true;
+        }
+    }
+    if (create_if_absent) {
+        new_lexical_variable(name, value);
+    }
+    return create_if_absent;
+}
+
+void new_lexical_variable(LispVal *name, LispVal *value) {
+    assert(the_stack.depth != 0);
+    LISP_STACK_TOP()->lexenv =
+        CONS(name, CONS(value, LISP_STACK_TOP()->lexenv));
+}
+
+void copy_parent_lexenv(void) {
+    assert(the_stack.depth != 0);
+    if (the_stack.depth > 1) {
+        LISP_STACK_TOP()->lexenv = the_stack.frames[the_stack.depth - 2].lexenv;
+    }
+}

src/stack.h

@@ -40,6 +40,15 @@ static ALWAYS_INLINE struct StackFrame *LISP_STACK_TOP(void) {
     return the_stack.depth ? &the_stack.frames[the_stack.depth - 1] : NULL;
 }
 
+static ALWAYS_INLINE LispVal *TOP_LEXENV(void) {
+    return the_stack.depth ? LISP_STACK_TOP()->lexenv : Qnil;
+}
+
+static ALWAYS_INLINE LispVal *PARENT_LEXENV(void) {
+    return the_stack.depth > 1 ? the_stack.frames[the_stack.depth - 2].lexenv
+                               : Qnil;
+}
+
 void lisp_init_stack(void);
 void lisp_teardown_stack(void);
 void push_stack_frame(LispVal *name, LispVal *fobj, LispVal *args);
@@ -47,6 +56,14 @@ void pop_stack_frame(void);
 void add_local_reference_no_recurse(LispVal *obj);
 void add_local_reference(LispVal *obj);
 
+// Return true if successful, false if not found and not created
+bool set_lexical_variable(LispVal *name, LispVal *value, bool create_if_absent);
+// Just add a new lexical variable without any checking
+void new_lexical_variable(LispVal *name, LispVal *value);
+
+// Copy the previous frame's lexenv to the top of the stack.
+void copy_parent_lexenv(void);
+
 // used by the GC
 void compact_stack_frame(struct StackFrame *restrict frame);