From e197e4b1dc1c6a5c6e97f26d4abe30de7c578065 Mon Sep 17 00:00:00 2001 From: Alexander Rosenberg Date: Tue, 8 Sep 2026 08:54:50 -0700 Subject: [PATCH] Fix some bugs --- lisp/kernel.gl | 103 +++++++++++++++++++++++++++++++++++++++++++++---- src/function.c | 26 ++++++++++++- src/interp.c | 40 +++++++++++++++---- src/interp.h | 2 + src/list.c | 14 +++++++ src/list.h | 2 + src/macro.c | 7 +++- 7 files changed, 176 insertions(+), 18 deletions(-) diff --git a/lisp/kernel.gl b/lisp/kernel.gl index cb8b30f..23cd3ff 100644 --- a/lisp/kernel.gl +++ b/lisp/kernel.gl @@ -1,5 +1,6 @@ ;; -*- mode: lisp-data -*- +;; Defining macros and functions (fset 'defmacro (cons 'macro (lambda (name lambda-list &rest body) "Define NAME to be a macro." @@ -18,11 +19,99 @@ (list 'declare (list 'name name)) body))) -(defun princln (datum &optional print-char-fun) - "`princ' DATUM to PRINT-CHAR-FUN. Then print a newline." - (princ datum print-char-fun) - (funcall (or print-char-fun 'write-byte) ?\n)) +;; List indicies +(defun first (list) + "Return the first element of LIST." + (car list)) +(defun second (list) + "Return the second element of LIST." + (car (cdr list))) +(defun third (list) + "Return the third element of LIST." + (car (cdr (cdr list)))) +(defun fourth (list) + "Return the fourth element of LIST." + (car (cdr (cdr (cdr list))))) +(defun fifth (list) + "Return the fifth element of LIST." + (car (cdr (cdr (cdr (cdr list)))))) +(defun sixth (list) + "Return the sixth element of LIST." + (car (cdr (cdr (cdr (cdr (cdr list))))))) +(defun seventh (list) + "Return the seventh element of LIST." + (car (cdr (cdr (cdr (cdr (cdr (cdr list)))))))) +(defun eighth (list) + "Return the eighth element of LIST." + (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr list))))))))) +(defun ninth (list) + "Return the ninth element of LIST." + (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr list)))))))))) +(defun tenth (list) + "Return the tenth element of LIST." + (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr list))))))))))) -(let ((a [0])) - (aset a 1 'a) - (princln a)) +;; Utility macros +(defmacro when (cond &rest body) + "Evaluate BODY if COND evaluates to non-nil." + (list 'if cond + (cons 'progn body))) + +(defmacro unless (cond &rest body) + "Evaluate BODY if COND evaluates to nil." + (list* 'if cond + nil + body)) + +(defmacro dolist (spec &rest body) + "Evaluate BODY for each element of a list. +Spec is of the form (VARIABLE LIST &optional RETURN-FORM)." + (unless (and (or (length= spec 2) (length= spec 3)) + (symbolp (car spec))) + (signal 'error (list spec))) + (let ((list-var (make-symbol "--dolist-list--")) + (cur-var (make-symbol "--dolist-cur--"))) + (list 'let (list (list list-var (second spec)) + cur-var) + (list 'while list-var + (list 'setq cur-var (list 'car list-var)) + (list* 'let (list (list (first spec) cur-var)) + body) + (list 'setq list-var (list 'cdr list-var))) + (when (third spec) + (list 'let (list (list (first spec) cur-var)) + (third spec)))))) + +;; List functions +(defun mapcar (function list) + "Apply FUNCTION to each element of LIST and return a list of the results." + (let (start end) + (dolist (elt list) + (let ((res (funcall function elt))) + (if (null start) + (progn + (setq start (list res) + end start)) + (rplacd end (list res)) + (setq end (cdr end))))) + start)) + +(defun mapc (function list) + "Apply FUNCTION to each element of LIST, then return LIST." + (dolist (elt list list) + (funcall function elt))) + +;; Some other functions +(defun terpri (&optional print-char-fun) + "Print a newline to PRINT-CHAR-FUN, then flush it." + (let ((fun (or print-char-fun #'write-byte))) + (funcall fun ?\n) + (funcall fun nil))) + +(defun princln (datum &optional print-char-fun) + "`princ' DATUM to PRINT-CHAR-FUN, then do a `terpri'." + (princ datum print-char-fun) + (terpri print-char-fun)) + +(princln (mapc (lambda (x) (+ x 1)) + '(1 2 3))) diff --git a/src/function.c b/src/function.c index d131f21..b029e91 100644 --- a/src/function.c +++ b/src/function.c @@ -245,6 +245,7 @@ enum ProcessArgsResult { PROCESS_ARGS_TOO_MANY, PROCESS_ARGS_NO_KEY_VALUE, PROCESS_ARGS_BAD_KEY, + PROCESS_ARGS_DOTTED, PROCESS_ARGS_N_ERRORS, }; @@ -255,6 +256,7 @@ static const char *process_args_strerror(enum ProcessArgsResult status) { [PROCESS_ARGS_TOO_MANY] = "Too many arguments", [PROCESS_ARGS_NO_KEY_VALUE] = "Key without a value", [PROCESS_ARGS_BAD_KEY] = "Unknown key", + [PROCESS_ARGS_DOTTED] = "Dotted argument list", }; return MSGS[status]; } @@ -276,6 +278,8 @@ process_complex_native_args(LispFunction *fobj, LispVal *args, while (rem_req--) { if (NILP(args)) { return PROCESS_ARGS_TOO_FEW; + } else if (!CONSP(args)) { + return PROCESS_ARGS_DOTTED; } out[idx++] = XCAR(args); args = XCDR(args); @@ -283,6 +287,8 @@ process_complex_native_args(LispFunction *fobj, LispVal *args, while (rem_opt--) { if (NILP(args)) { return PROCESS_ARGS_OK; + } else if (!CONSP(args)) { + return PROCESS_ARGS_DOTTED; } out[idx++] = XCAR(args); args = XCDR(args); @@ -291,6 +297,9 @@ process_complex_native_args(LispFunction *fobj, LispVal *args, return PROCESS_ARGS_TOO_MANY; } if (!NILP(fobj->args.rest)) { + if (!LISTP(args) || !NILP(Fdotted_list_p(args))) { + return PROCESS_ARGS_DOTTED; + } *rest_idx = idx; out[idx++] = args; } else { @@ -300,7 +309,9 @@ process_complex_native_args(LispFunction *fobj, LispVal *args, return PROCESS_ARGS_OK; } while (!NILP(args)) { - if (NILP(XCDR(args))) { + if (!CONSP(args)) { + return PROCESS_ARGS_DOTTED; + } else if (NILP(XCDR(args))) { return PROCESS_ARGS_NO_KEY_VALUE; } LispVal *entry = Fgethash(fobj->args.kw, XCAR(args), Qnil); @@ -390,12 +401,17 @@ push_interpreted_args_to_lexenv(LispFunction *fobj, LispVal *args) { while (!NILP(rem_req)) { if (NILP(args)) { return PROCESS_ARGS_TOO_FEW; + } else if (!CONSP(args)) { + return PROCESS_ARGS_DOTTED; } new_lexical_variable(XCAR(rem_req), XCAR(args)); args = XCDR(args); rem_req = XCDR(rem_req); } while (!NILP(rem_opt) && !NILP(args)) { + if (!CONSP(args)) { + return PROCESS_ARGS_DOTTED; + } push_optional_argument_to_lexenv(XCAR(rem_opt), XCAR(args)); args = XCDR(args); rem_opt = XCDR(rem_opt); @@ -405,6 +421,9 @@ push_interpreted_args_to_lexenv(LispFunction *fobj, LispVal *args) { rem_opt = XCDR(rem_opt); } if (!NILP(fobj->args.rest)) { + if (!LISTP(args) || !NILP(Fdotted_list_p(args))) { + return PROCESS_ARGS_DOTTED; + } new_lexical_variable(fobj->args.rest, args); } if (NILP(fobj->args.kw)) { @@ -413,6 +432,9 @@ push_interpreted_args_to_lexenv(LispFunction *fobj, LispVal *args) { } LispVal *seen_kw = make_hash_table_no_gc(Qnil, Qnil); while (!NILP(args)) { + if (!CONSP(args)) { + return PROCESS_ARGS_DOTTED; + } if (NILP(XCDR(args))) { release_hash_table_no_gc(seen_kw); return PROCESS_ARGS_NO_KEY_VALUE; @@ -494,7 +516,7 @@ DEFUN(apply, "apply", (LispVal * func, LispVal *args), "(func &rest args)", if (NILP(args)) { return CALL0(func); } - if (NILP(Fproper_list_p(XCDR(Flast(args))))) { + if (NILP(Fproper_list_p(XCAR(Flast(args))))) { signal_type_error(args, Qlist); } return Ffuncall(func, Flist_star(XCAR(args), XCDR(args))); diff --git a/src/interp.c b/src/interp.c index 0a311e8..1fe4565 100644 --- a/src/interp.c +++ b/src/interp.c @@ -105,8 +105,7 @@ DEFSPECIAL(setq, "setq", (LispVal * bindings), "(&rest bindings)", "") { LIST(LISP_LITSTR("Wrong number of arguments."))); } LispVal *value = Qnil; - for (LispVal *rest = bindings; !NILP(bindings); - bindings = XCDR(XCDR(bindings))) { + for (LispVal *rest = bindings; !NILP(rest); rest = XCDR(XCDR(rest))) { LispVal *name = FIRST(rest); value = eval(SECOND(rest)); set_lexical_variable(name, value); @@ -118,14 +117,16 @@ DEFSPECIAL(let, "let", (LispVal * bindings, LispVal *body), "(bindings &rest body)", "") { CHECK_LISTP(bindings); StackFrame *stack_ref = LISP_STACK_REF(); - DOLIST(binding, bindings) { + bindings = Fcopy_list(bindings); + DOTAILS(rest, bindings) { + LispVal *binding = XCAR(rest); if (CONSP(binding) && list_length_eq(binding, 2)) { - if (!SYMBOLP(XCAR(binding))) { - signal_type_error(XCAR(binding), LIST(Qsymbol)); - } + CHECK_TYPE(XCAR(binding), TYPE_SYMBOL); + binding = Fcopy_list(binding); + RPLACA(rest, binding); RPLACA(XCDR(binding), eval(SECOND(binding))); } else if (!SYMBOLP(binding)) { - signal_type_error(binding, LIST(Qsymbol)); + signal_type_error(binding, LIST(Qsymbol, Qlist)); } } push_copy_lexenv(); @@ -140,6 +141,23 @@ DEFSPECIAL(let, "let", (LispVal * bindings, LispVal *body), return UNWIND_AND_RETURN(stack_ref, Fprogn(body)); } +DEFSPECIAL(let_star, "let*", (LispVal * bindings, LispVal *body), + "(bindings &rest body)", "") { + CHECK_LISTP(bindings); + StackFrame *stack_ref = LISP_STACK_REF(); + DOLIST(binding, bindings) { + if (CONSP(binding) && list_length_eq(binding, 2)) { + CHECK_TYPE(XCAR(binding), TYPE_SYMBOL); + new_lexical_variable(FIRST(binding), eval(SECOND(binding))); + } else if (SYMBOLP(binding)) { + new_lexical_variable(binding, Qnil); + } else { + signal_type_error(binding, LIST(Qsymbol, Qlist)); + } + } + return UNWIND_AND_RETURN(stack_ref, Fprogn(body)); +} + DEFSPECIAL(if, "if", (LispVal * cond, LispVal *then, LispVal *otherwise), "(cond then &rest else)", "") { StackFrame *stack_ref = LISP_STACK_REF(); @@ -180,6 +198,14 @@ DEFUN(not, "not", (LispVal * datum), "(datum)", "") { return NILP(datum) ? Qt : Qnil; } +DEFSPECIAL(while, "while", (LispVal * cond, LispVal *body), "(cond &rest body)", + "") { + while (!NILP(eval(cond))) { + Fprogn(body); + } + return Qnil; +} + DEFSPECIAL(block, "block", (LispVal * name, LispVal *body), "(name &rest body)", "") { CHECK_TYPE(name, TYPE_SYMBOL); diff --git a/src/interp.h b/src/interp.h index 03cc54e..9a1ee9d 100644 --- a/src/interp.h +++ b/src/interp.h @@ -8,11 +8,13 @@ DECLARE_FUNCTION(eval, (LispVal * form, LispVal *lexenv)); DECLARE_FUNCTION(progn, (LispVal * forms)); DECLARE_FUNCTION(setq, (LispVal * bindings)); DECLARE_FUNCTION(let, (LispVal * bindings, LispVal *body)); +DECLARE_FUNCTION(let_star, (LispVal * bindings, LispVal *body)); DECLARE_FUNCTION(if, (LispVal * cond, LispVal *then, LispVal *otherwise)); DECLARE_FUNCTION(and, (LispVal * forms)); DECLARE_FUNCTION(or, (LispVal * forms)); DECLARE_FUNCTION(null, (LispVal * datum)); DECLARE_FUNCTION(not, (LispVal * datum)); +DECLARE_FUNCTION(while, (LispVal * cond, LispVal *body)); DECLARE_FUNCTION(block, (LispVal * name, LispVal *body)); DECLARE_FUNCTION(return_from, (LispVal * name, LispVal *value)); diff --git a/src/list.c b/src/list.c index 3f436ea..5336f68 100644 --- a/src/list.c +++ b/src/list.c @@ -53,6 +53,20 @@ DEFUN(cdr, "cdr", (LispVal * list), "(list)", "") { return NILP(list) ? Qnil : XCDR(list); } +DEFUN(rplaca, "rplaca", (LispVal * cons, LispVal *newcar), "(cons newcar)", + "") { + CHECK_TYPE(cons, TYPE_CONS); + RPLACA(cons, newcar); + return newcar; +} + +DEFUN(rplacd, "rplacd", (LispVal * cons, LispVal *newcdr), "(cons newcdr)", + "") { + CHECK_TYPE(cons, TYPE_CONS); + RPLACD(cons, newcdr); + return newcdr; +} + DEFUN(length_eq, "length=", (LispVal * list, LispVal *length), "(list length)", "Return non-nil if LIST's length is LENGTH.") { CHECK_LISTP(list); diff --git a/src/list.h b/src/list.h index 0dd66d0..9f5467a 100644 --- a/src/list.h +++ b/src/list.h @@ -125,6 +125,8 @@ DECLARE_FUNCTION(atom, (LispVal * val)); DECLARE_FUNCTION(cons, (LispVal * car, LispVal *cdr)); DECLARE_FUNCTION(car, (LispVal * list)); DECLARE_FUNCTION(cdr, (LispVal * list)); +DECLARE_FUNCTION(rplaca, (LispVal * cons, LispVal *newcar)); +DECLARE_FUNCTION(rplacd, (LispVal * cons, LispVal *newcdr)); DECLARE_FUNCTION(length_eq, (LispVal * list, LispVal *length)); DECLARE_FUNCTION(nreverse, (LispVal * list)); DECLARE_FUNCTION(last, (LispVal * list)); diff --git a/src/macro.c b/src/macro.c index 17f5396..799caed 100644 --- a/src/macro.c +++ b/src/macro.c @@ -52,6 +52,9 @@ DEFUN(macroexpand_toplevel, "macroexpand-toplevel", } LispVal *macroexpand_list(LispVal *list, LispVal *lexical_macros) { + if (!CONSP(list)) { + return list; + } LispVal *start = Qnil; LispVal *end = NULL; DOTAILS(rest, list) { @@ -103,7 +106,7 @@ static LispVal *macroexpand_special_form(LispVal *fobj, LispVal *form, return macroexpand_lambda_form(form, lexical_macros); } else if (IS(quote) || IS(function)) { return form; - } else if (IS(progn) || IS(if) || IS(and) || IS(or)) { + } else if (IS(progn) || IS(if) || IS(and) || IS(or) || IS(while)) { if (LISTP(XCDR(form))) { return CONS(XCAR(form), macroexpand_list(XCDR(form), lexical_macros)); @@ -119,7 +122,7 @@ static LispVal *macroexpand_special_form(LispVal *fobj, LispVal *form, expand = !expand; } return CONS(XCAR(form), args); - } else if (IS(let)) { + } else if (IS(let) || IS(let_star)) { if (!CONSP(XCDR(form))) { return form; }