Some random work

src/kernel.sl

@@ -3,6 +3,11 @@
 (fset 'null 'not)
 (defun list (&rest r) r)
 
+(defun ensure-list (arg)
+  (if (pairp arg)
+      arg
+    (list arg)))
+
 (fset 'first 'head)
 (defun second (list)
   (head (tail list)))
@@ -23,6 +28,12 @@
 (defun tenth (list)
   (head (tail (tail (tail (tail (tail (tail (tail (tail (tail list)))))))))))
 
+(defmacro when (cond &rest body)
+  (list 'if cond (pair 'progn body)))
+
+(defmacro unless (cond &rest body)
+  (apply 'list 'if cond nil body))
+
 (defmacro dolist (vars &rest body)
   (funcall
    (lambda (tail-var)
@@ -77,6 +88,20 @@
      (apply 'list 'funcall (apply 'list 'lambda (reverse vars) body)
             (reverse vals)))))
 
+(defun plist-put (plist key value)
+  (let ((tail plist))
+    (while (and tail (tail tail))
+      (if (eq (head tail) key)
+          (sethead (tail tail) value))
+      (setq tail (tail (tail tail))))))
+
+(defun put (symbol key value)
+  (let ((cur (symbol-plist symbol)))
+    ()))
+
+(defun get (symbol key default)
+  ())
+
 (defun lasttail (list)
   "Return the last pair in LIST."
   (let (out)
@@ -104,22 +129,40 @@
           (setq last-if new-if))))
     out))
 
-(defun internal-expand-\` (form)
+(defmacro tcase (obj &rest conds)
-  (cond
+  (let ((obj-var (make-symbol "obj")))
-   ((and (listp form) (eq (head form) '\,))
+    (list 'let (list (list obj-var obj))
-    (list (eval (second form))))
+          (pair
-   ((and (listp form) (eq (head form) '\,@))
+           'cond
-    (eval (second form)))
+           (maphead
-   ((pairp form)
+            (lambda (cond)
-    (let (out end)
+              (let ((pred (pair 'or (maphead
-      (dolist (arg form)
+                                     (lambda (elt)
-        (if (not out)
+                                       (if (eq elt t)
-            (setq out (internal-expand-\` arg)
+                                           t
-                  end (lasttail out))
+                                         (list 'eq (list 'type-of obj-var)
-          (settail end (internal-expand-\` arg))
+                                               (list '\' elt))))
-          (setq end (lasttail end))))
+                                     (ensure-list (head cond))))))
-      (list out)))
+                (pair pred (tail cond))))
-   (t (list form))))
+            conds)))))
+
+(defun internal-expand-\` (form &opt (level 0))
+  (tcase
+   (())))
 
 (defmacro \` (form)
-  (list '\' (head (internal-expand-\` form))))
+  (internal-expand-\` form))
+
+;; (println (macroexpand-1 '`(,@a)))
+
+(defmacro a (form)
+  (list 'b (ensure-list form)))
+
+(defmacro b (form)
+  (list 'c (ensure-list form)))
+
+(defmacro c (form)
+  (list 'd form))
+
+;; (let ((a '(1 2 3)))
+;;   (println `(,a)))

src/lisp.c

@@ -680,7 +680,8 @@ size_t list_length(LispVal *obj) {
 
 StackFrame *the_stack = NULL;
 DEF_STATIC_SYMBOL(toplevel, "toplevel");
-DEF_STATIC_SYMBOL(parent_lexenv, "parent-lexenv");
+DEF_STATIC_SYMBOL(parent_lexenv, "parent-lexenv"); // DO NOT INTERN
+DEF_STATIC_SYMBOL(return_signal, "return-signal"); // DO NOT INTERN
 
 void stack_enter(LispVal *name, LispVal *detail, bool inherit) {
     StackFrame *frame = lisp_malloc(sizeof(StackFrame));
@@ -1045,6 +1046,10 @@ void lisp_init(void) {
         "Set each of a number of variables to their respective values.");
     REGISTER_FUNCTION(progn, "(&rest forms)", "Evaluate each of FORMS.");
     REGISTER_FUNCTION(symbol_function, "(sym &opt resolve)", "");
+    REGISTER_FUNCTION(symbol_value, "(sym)", "Return the global value of SYM.");
+    REGISTER_FUNCTION(symbol_plist, "(sym)", "Return the plist of SYM.");
+    REGISTER_FUNCTION(setplist, "(sym plist)",
+                      "Set the plist of SYM to PLIST.");
     REGISTER_FUNCTION(fset, "(sym new-func)", "");
     REGISTER_FUNCTION(defun, "(name args &rest body)",
                       "Define NAME to be a new function.");
@@ -1062,15 +1067,23 @@ void lisp_init(void) {
                       "Return a new un-interned symbol named NAME.");
     REGISTER_FUNCTION(macroexpand_1, "(form)",
                       "Return the form which FORM expands to.");
+    REGISTER_FUNCTION(macroexpand_toplevel, "(form)", "");
+    REGISTER_FUNCTION(macroexpand_all, "(form)", "");
     REGISTER_FUNCTION(stringp, "(val)", "Return non-nil if VAL is a string.");
     REGISTER_FUNCTION(symbolp, "(val)", "Return non-nil if VAL is a symbol.");
     REGISTER_FUNCTION(pairp, "(val)", "Return non-nil if VAL is a pair.");
     REGISTER_FUNCTION(integerp, "(val)", "Return non-nil if VAL is a integer.");
     REGISTER_FUNCTION(floatp, "(val)", "Return non-nil if VAL is a float.");
     REGISTER_FUNCTION(vectorp, "(val)", "Return non-nil if VAL is a vector.");
-    REGISTER_FUNCTION(functionp, "(val)",
+    REGISTER_FUNCTION(
-                      "Return non-nil if VAL is a function.");
+        functionp, "(val)",
-    REGISTER_FUNCTION(macrop, "(val)", "Return non-nil if VAL is a macro.");
+        "Return non-nil if VAL is a non-macro function (includes buitlins).");
+    REGISTER_FUNCTION(macrop, "(val)",
+                      "Return non-nil if VAL is a non-builtin macro.");
+    REGISTER_FUNCTION(builtinp, "(val)",
+                      "Return non-nil if VAL is a non-macro builtin.");
+    REGISTER_FUNCTION(special_form_p, "(val)",
+                      "Return non-nil if VAL is a macro-builtin.");
     REGISTER_FUNCTION(hashtablep, "(val)",
                       "Return non-nil if VAL is a hashtable.");
     REGISTER_FUNCTION(user_pointer_p, "(val)",
@@ -1080,6 +1093,9 @@ void lisp_init(void) {
     REGISTER_FUNCTION(keywordp, "(val)", "Return non-nil if VAL is a keyword.");
     REGISTER_FUNCTION(numberp, "(val)", "Return non-nil if VAL is a number.");
     REGISTER_FUNCTION(list_length, "(list)", "Return the length of LIST.");
+    REGISTER_FUNCTION(copy_list, "(list)", "Return a shallow copy of LIST.");
+    REGISTER_FUNCTION(copy_tree, "(tree)",
+                      "Return a deep copy of TREE and all sublists in it.");
     REGISTER_FUNCTION(num_eq, "(n1 n2)",
                       "Return non-nil if N1 and N2 are equal numerically.")
     REGISTER_FUNCTION(num_gt, "(n1 n2)",
@@ -1158,6 +1174,19 @@ DEFUN(symbol_value, "symbol-value", (LispVal * symbol)) {
     return refcount_ref(((LispSymbol *) symbol)->value);
 }
 
+DEFUN(symbol_plist, "symbol-plist", (LispVal * symbol)) {
+    CHECK_TYPE(TYPE_SYMBOL, symbol);
+    return refcount_ref(((LispSymbol *) symbol)->plist);
+}
+
+DEFUN(setplist, "setplist", (LispVal * symbol, LispVal *plist)) {
+    CHECK_TYPE(TYPE_SYMBOL, symbol);
+    LispSymbol *real = (LispSymbol *) symbol;
+    refcount_unref(real->plist);
+    real->plist = refcount_ref(plist);
+    return Qnil;
+}
+
 static inline LispVal *eval_function_args(LispVal *args, LispVal *lexenv) {
     LispVal *final_args = Qnil;
     WITH_PUSH_FRAME(Qnil, Qnil, true, {
@@ -1521,6 +1550,55 @@ DEFUN(funcall, "funcall", (LispVal * function, LispVal *rest)) {
     return call_function(function, rest, Qnil, false, false);
 }
 
+DEFUN(copy_tree, "copy-tree", (LispVal * tree)) {
+    if (NILP(tree)) {
+        return Qnil;
+    }
+    CHECK_TYPE(TYPE_PAIR, tree);
+    LispPair *tortise = (LispPair *) tree;
+    LispPair *hare = (LispPair *) tortise->tail;
+    LispVal *copy = Qnil;
+    LispVal *copy_end;
+    WITH_PUSH_FRAME(Qnil, Qnil, true, {
+        the_stack->hidden = true;
+        void *cl_handle = register_cleanup(&unref_double_ptr, &copy);
+        while (!NILP(tortise)) {
+            if (!LISTP(LISPVAL(tortise))) {
+                break;
+            } else if (tortise == hare) {
+                refcount_unref(copy);
+                Fthrow(Qcircular_error, Qnil);
+            }
+            LispVal *elt = tortise->head;
+            if (PAIRP(elt)) {
+                elt = Fcopy_tree(elt);
+            } else {
+                refcount_ref(elt);
+            }
+            if (NILP(copy)) {
+                copy = Fpair(elt, Qnil);
+                copy_end = copy;
+            } else {
+                LispVal *new_end = Fpair(elt, Qnil);
+                Fsettail(copy_end, new_end);
+                refcount_unref(new_end);
+                copy_end = new_end;
+            }
+            refcount_unref(elt);
+            tortise = (LispPair *) tortise->tail;
+            if (PAIRP(hare)) {
+                if (PAIRP(((LispPair *) hare)->tail)) {
+                    hare = (LispPair *) ((LispPair *) hare->tail)->tail;
+                } else if (NILP(((LispPair *) hare)->tail)) {
+                    hare = (LispPair *) Qnil;
+                }
+            }
+        }
+        cancel_cleanup(cl_handle);
+    });
+    return copy;
+}
+
 DEFUN(macroexpand_1, "macroexpand-1", (LispVal * form)) {
     if (PAIRP(form)) {
         LispFunction *fobj = (LispFunction *) Fsymbol_function(Fhead(form), Qt);
@@ -1543,6 +1621,45 @@ DEFUN(macroexpand_1, "macroexpand-1", (LispVal * form)) {
     }
 }
 
+DEFUN(macroexpand_toplevel, "macroexpand-toplevel", (LispVal * form)) {
+    if (PAIRP(form)) {
+        LispVal *out = refcount_ref(form);
+        void *cl_handler = register_cleanup(&unref_double_ptr, &out);
+        while (PAIRP(out) && !NILP(Fmacrop(HEAD(out)))) {
+            LispVal *new_out = Fmacroexpand_1(out);
+            refcount_unref(out);
+            out = new_out;
+        }
+        cancel_cleanup(cl_handler);
+        return out;
+    } else {
+        return refcount_ref(form);
+    }
+}
+
+DEFUN(macroexpand_all, "macroexpand-all", (LispVal * form)) {
+    if (PAIRP(form)) {
+        LispVal *toplevel_orig = Fmacroexpand_toplevel(form);
+        LispVal *toplevel;
+        WITH_CLEANUP(toplevel_orig, {
+            toplevel = Fcopy_list(toplevel_orig); //
+        });
+        WITH_PUSH_FRAME(Qnil, Qnil, true, {
+            void *cl_handler = register_cleanup(&unref_double_ptr, &toplevel);
+            if (PAIRP(toplevel) && NILP(Feq(Qquote, HEAD(toplevel)))) {
+                FOREACH_TAIL(tail, TAIL(toplevel)) {
+                    Fsethead(tail, Fmacroexpand_all(HEAD(tail)));
+                }
+            }
+            cancel_cleanup(cl_handler);
+        });
+        return toplevel;
+    } else {
+        return refcount_ref(form);
+    }
+    return Qnil;
+}
+
 DEFUN(apply, "apply", (LispVal * function, LispVal *rest)) {
     LispVal *args = Qnil;
     LispVal *end;
@@ -1788,7 +1905,13 @@ DEFMACRO(defmacro, "defmacro", (LispVal * name, LispVal *args, LispVal *body)) {
 }
 
 DEFMACRO(lambda, "lambda", (LispVal * args, LispVal *body)) {
-    return make_lisp_function(args, the_stack->lexenv, body, false);
+    LispVal *expanded_body = Fmacroexpand_all(body);
+    LispVal *retval = Qnil;
+    WITH_CLEANUP(expanded_body, {
+        retval =
+            make_lisp_function(args, the_stack->lexenv, expanded_body, false);
+    });
+    return retval;
 }
 
 DEFMACRO(while, "while", (LispVal * cond, LispVal *body)) {
@@ -1842,12 +1965,44 @@ DEFUN(functionp, "functionp", (LispVal * val)) {
 }
 
 DEFUN(macrop, "macrop", (LispVal * val)) {
-    if (FUNCTIONP(val) && ((LispFunction *) val)->is_macro) {
+    if (FUNCTIONP(val) && !((LispFunction *) val)->is_builtin
+        && ((LispFunction *) val)->is_macro) {
         return Qt;
     } else if (SYMBOLP(val)) {
         LispVal *res = Fsymbol_function(val, Qt);
         LispVal *retval =
-            LISP_BOOL(FUNCTIONP(res) && ((LispFunction *) res)->is_macro);
+            LISP_BOOL(FUNCTIONP(res) && !((LispFunction *) res)->is_builtin
+                      && ((LispFunction *) res)->is_macro);
+        refcount_unref(res);
+        return retval;
+    }
+    return Qnil;
+}
+
+DEFUN(builtinp, "builtinp", (LispVal * val)) {
+    if (FUNCTIONP(val) && ((LispFunction *) val)->is_builtin
+        && !((LispFunction *) val)->is_macro) {
+        return Qt;
+    } else if (SYMBOLP(val)) {
+        LispVal *res = Fsymbol_function(val, Qt);
+        LispVal *retval =
+            LISP_BOOL(FUNCTIONP(res) && ((LispFunction *) res)->is_builtin
+                      && !((LispFunction *) res)->is_macro);
+        refcount_unref(res);
+        return retval;
+    }
+    return Qnil;
+}
+
+DEFUN(special_form_p, "special-form-p", (LispVal * val)) {
+    if (FUNCTIONP(val) && ((LispFunction *) val)->is_builtin
+        && ((LispFunction *) val)->is_macro) {
+        return Qt;
+    } else if (SYMBOLP(val)) {
+        LispVal *res = Fsymbol_function(val, Qt);
+        LispVal *retval =
+            LISP_BOOL(FUNCTIONP(res) && ((LispFunction *) res)->is_builtin
+                      && ((LispFunction *) res)->is_macro);
         refcount_unref(res);
         return retval;
     }
@@ -1882,6 +2037,31 @@ DEFUN(list_length, "list-length", (LispVal * list)) {
     return make_lisp_integer(list_length(list));
 }
 
+DEFUN(copy_list, "copy-list", (LispVal * list)) {
+    if (NILP(list)) {
+        return Qnil;
+    }
+    CHECK_TYPE(TYPE_PAIR, list);
+    LispVal *copy = Qnil;
+    LispVal *copy_end;
+    WITH_PUSH_FRAME(Qnil, Qnil, true, {
+        void *cl_cleanup = register_cleanup(&unref_double_ptr, &copy);
+        FOREACH(elt, list) {
+            if (NILP(copy)) {
+                copy = Fpair(elt, Qnil);
+                copy_end = copy;
+            } else {
+                LispVal *new_end = Fpair(elt, Qnil);
+                Fsettail(copy_end, new_end);
+                refcount_unref(new_end);
+                copy_end = new_end;
+            }
+        }
+        cancel_cleanup(cl_cleanup);
+    });
+    return copy;
+}
+
 DEFMACRO(and, "and", (LispVal * rest)) {
     LispVal *retval = Qnil;
     FOREACH(cond, rest) {
@@ -1915,6 +2095,7 @@ DEFUN(type_of, "type-of", (LispVal * obj)) {
         make_lisp_string((char *) LISP_TYPE_NAMES[obj->type].name,
                          LISP_TYPE_NAMES[obj->type].len, true, true);
     LispVal *sym = Fintern(name);
+    refcount_unref(name);
     return sym;
 }
 
@@ -2033,3 +2214,33 @@ static bool debug_print_tree_callback(void *obj, const RefcountList *trail,
 void debug_print_tree(FILE *stream, void *obj) {
     refcount_debug_walk_tree(obj, debug_print_tree_callback, stream);
 }
+
+void debug_dump_lexenv(FILE *stream, LispVal *lexenv) {
+    if (!the_stack) {
+        fprintf(stream, "debug_dump_lexenv: No stack frames...\n");
+    }
+    if (!lexenv) {
+        lexenv = the_stack->lexenv;
+    }
+    bool first = true;
+    while (!NILP(lexenv)) {
+        if (first) {
+            fprintf(stream, "Lexical variables (most recent frame first):\n");
+        } else {
+            fprintf(stream, "\nNext parent:\n");
+        }
+        first = false;
+        LispVal *next_lexenv = Qnil;
+        HASHTABLE_FOREACH(var, val, lexenv, {
+            if (var == Qparent_lexenv) {
+                next_lexenv = val;
+            } else {
+                fprintf(stream, " - ");
+                debug_dump(stream, var, false);
+                fprintf(stream, " -> ");
+                debug_dump(stream, val, true);
+            }
+        });
+        lexenv = next_lexenv;
+    }
+}

src/lisp.h

@@ -232,8 +232,8 @@ inline static bool NUMBERP(LispVal *v) {
     LispVal *F##c_name args;           \
     extern LispVal *Q##c_name
 // The args and doc fields are filled when the function is registered
-#define _INTERNAL_DEFUN_EXTENDED(macrop, c_name, lisp_name, c_args) \
+#define _INTERNAL_DEFUN_EXTENDED(macrop, c_name, lisp_name, c_args, static_kw) \
-    LispVal *F##c_name c_args;                                      \
+    static_kw LispVal *F##c_name c_args;                                       \
     DEF_STATIC_STRING(_Q##c_name##_name, lisp_name);                           \
     static LispFunction _Q##c_name##_function = {                              \
         .type = TYPE_FUNCTION,                                                 \
@@ -257,11 +257,13 @@ inline static bool NUMBERP(LispVal *v) {
         .is_constant = false,                                                  \
     };                                                                         \
     LispVal *Q##c_name = (LispVal *) &_Q##c_name;                              \
-    LispVal *F##c_name c_args
+    static_kw LispVal *F##c_name c_args
 #define DEFUN(c_name, lisp_name, c_args) \
-    _INTERNAL_DEFUN_EXTENDED(false, c_name, lisp_name, c_args)
+    _INTERNAL_DEFUN_EXTENDED(false, c_name, lisp_name, c_args, )
 #define DEFMACRO(c_name, lisp_name, c_args) \
-    _INTERNAL_DEFUN_EXTENDED(true, c_name, lisp_name, c_args)
+    _INTERNAL_DEFUN_EXTENDED(true, c_name, lisp_name, c_args, )
+#define STATIC_DEFUN(c_name, lisp_name, c_args) \
+    _INTERNAL_DEFUN_EXTENDED(false, c_name, lisp_name, c_args, static)
 
 // ###############
 // # Loop macros #
@@ -506,6 +508,8 @@ DECLARE_FUNCTION(quote, (LispVal * form));
 DECLARE_FUNCTION(breakpoint, (LispVal * id));
 DECLARE_FUNCTION(symbol_function, (LispVal * symbol, LispVal *resolve));
 DECLARE_FUNCTION(symbol_value, (LispVal * symbol));
+DECLARE_FUNCTION(symbol_plist, (LispVal * symbol));
+DECLARE_FUNCTION(setplist, (LispVal * symbol, LispVal *plist));
 DECLARE_FUNCTION(eval_in_env, (LispVal * form, LispVal *lexenv));
 DECLARE_FUNCTION(eval, (LispVal * form));
 DECLARE_FUNCTION(funcall, (LispVal * function, LispVal *rest));
@@ -530,6 +534,8 @@ DECLARE_FUNCTION(lambda, (LispVal * args, LispVal *body));
 DECLARE_FUNCTION(while, (LispVal * condition, LispVal *body));
 DECLARE_FUNCTION(make_symbol, (LispVal * name));
 DECLARE_FUNCTION(macroexpand_1, (LispVal * form));
+DECLARE_FUNCTION(macroexpand_toplevel, (LispVal * form));
+DECLARE_FUNCTION(macroexpand_all, (LispVal * form));
 DECLARE_FUNCTION(stringp, (LispVal * val));
 DECLARE_FUNCTION(symbolp, (LispVal * val));
 DECLARE_FUNCTION(pairp, (LispVal * val));
@@ -538,6 +544,8 @@ DECLARE_FUNCTION(floatp, (LispVal * val));
 DECLARE_FUNCTION(vectorp, (LispVal * val));
 DECLARE_FUNCTION(functionp, (LispVal * val));
 DECLARE_FUNCTION(macrop, (LispVal * val));
+DECLARE_FUNCTION(builtinp, (LispVal * val));
+DECLARE_FUNCTION(special_form_p, (LispVal * val));
 DECLARE_FUNCTION(hashtablep, (LispVal * val));
 DECLARE_FUNCTION(user_pointer_p, (LispVal * val));
 DECLARE_FUNCTION(atom, (LispVal * val));
@@ -545,6 +553,8 @@ DECLARE_FUNCTION(listp, (LispVal * val));
 DECLARE_FUNCTION(keywordp, (LispVal * val));
 DECLARE_FUNCTION(numberp, (LispVal * val));
 DECLARE_FUNCTION(list_length, (LispVal * list));
+DECLARE_FUNCTION(copy_list, (LispVal * list));
+DECLARE_FUNCTION(copy_tree, (LispVal * tree));
 DECLARE_FUNCTION(num_eq, (LispVal * n1, LispVal *n2));
 DECLARE_FUNCTION(num_gt, (LispVal * n1, LispVal *n2));
 DECLARE_FUNCTION(and, (LispVal * rest));
@@ -555,10 +565,12 @@ DECLARE_FUNCTION(function_docstr, (LispVal * func));
 void debug_dump(FILE *stream, void *obj, bool newline);
 void debug_print_hashtable(FILE *stream, LispVal *table);
 void debug_print_tree(FILE *stream, void *obj);
+void debug_dump_lexenv(FILE *stream, LispVal *lexenv);
 extern LispVal *Qopt;
 extern LispVal *Qkey;
 extern LispVal *Qallow_other_keys;
 extern LispVal *Qrest;
+extern LispVal *Qreturn_signal;
 
 // some internal functions
 LispVal *puthash(LispVal *table, LispVal *key, LispVal *value);