Zander671/simple-lisp
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Some random work

Browse Source
This commit is contained in:
Alexander Rosenberg
2025-09-15 01:12:54 -07:00
parent eb0737e83b
commit 91f2ab8e0a
3 changed files with 322 additions and 56 deletions
Download Patch File Download Diff File Expand all files Collapse all files

77
src/kernel.el → src/kernel.sl
View File

@ -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)
(cond
((and (listp form) (eq (head form) '\,))
(list (eval (second form))))
((and (listp form) (eq (head form) '\,@))
(eval (second form)))
((pairp form)
(let (out end)
(dolist (arg form)
(if (not out)
(setq out (internal-expand-\` arg)
end (lasttail out))
(settail end (internal-expand-\` arg))
(setq end (lasttail end))))
(list out)))
(t (list form))))
(defmacro tcase (obj &rest conds)
(let ((obj-var (make-symbol "obj")))
(list 'let (list (list obj-var obj))
(pair
'cond
(maphead
(lambda (cond)
(let ((pred (pair 'or (maphead
(lambda (elt)
(if (eq elt t)
t
(list 'eq (list 'type-of obj-var)
(list '\' elt))))
(ensure-list (head cond))))))
(pair pred (tail cond))))
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)))

225
src/lisp.c
View File

@ -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)",
"Return non-nil if VAL is a function.");
REGISTER_FUNCTION(macrop, "(val)", "Return non-nil if VAL is a macro.");
REGISTER_FUNCTION(
functionp, "(val)",
"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;
}
}

22
src/lisp.h
View File

@ -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) \
LispVal *F##c_name c_args; \
#define _INTERNAL_DEFUN_EXTENDED(macrop, c_name, lisp_name, c_args, static_kw) \
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);