From 8ec08a55ea1b201ae6836e9e14e84543dffd6693 Mon Sep 17 00:00:00 2001 From: Alexander Rosenberg Date: Sat, 5 Sep 2026 07:05:12 -0700 Subject: [PATCH] Apply and read errors --- lisp/kernel.gl | 27 +++++++++++++++++++++++---- src/function.c | 13 ++++++++++++- src/function.h | 6 +++++- src/lisp_string.c | 7 ++++++- src/lisp_string.h | 3 +++ src/list.c | 16 ++++++++++++++++ src/list.h | 1 + src/macro.c | 2 ++ src/read.c | 20 ++++++++++++-------- src/read.h | 3 +++ 10 files changed, 83 insertions(+), 15 deletions(-) diff --git a/lisp/kernel.gl b/lisp/kernel.gl index aa7a8fb..b3ee1ae 100644 --- a/lisp/kernel.gl +++ b/lisp/kernel.gl @@ -1,6 +1,25 @@ ;; -*- mode: lisp-data -*- -(prin1 (let ((l (block 'c (lambda () (return-from 'd 3))))) - (block 'c - (funcall l)))) -(write-byte ?\n) +(fset 'defmacro (cons 'macro + (lambda (name lambda-list &rest body) + "Define NAME to be a macro." + (declare (name defmacro)) + (list 'fset (list 'quote name) + (list 'cons + (quote 'macro) + (list* 'lambda lambda-list + (list 'declare (list 'name name)) + body)))))) + +(defmacro defun (name lambda-list &rest body) + "Define NAME to be a function." + (list 'fset (list 'quote name) + (list* 'lambda lambda-list + (list 'declare (list 'name name)) + body))) + +(defun princln (datum &optional print-char-fun) + (princ datum print-char-fun) + (funcall (or print-char-fun 'write-byte) ?\n)) + +(princln (apply 'cons '(a b))) diff --git a/src/function.c b/src/function.c index 2fda93e..10c33de 100644 --- a/src/function.c +++ b/src/function.c @@ -485,6 +485,14 @@ DEFUN(funcall, "funcall", (LispVal * func, LispVal *args), "(func &rest args)", return UNWIND_AND_RETURN(stack_ref, raw_funcall(res, args)); } +DEFUN(apply, "apply", (LispVal * func, LispVal *args), "(func &rest args)", + "") { + if (NILP(args)) { + return CALL0(func); + } + return Ffuncall(func, Flist_star(XCAR(args), XCDR(args))); +} + static LispVal *parse_lambda_declare_form(LispFunction *fobj, LispVal *body) { while (CONSP(body) && CONSP(XCAR(body)) && EQ(XCAR(XCAR(body)), Qdeclare)) { LispVal *decls = XCDR(XCAR(body)); @@ -588,7 +596,10 @@ DEFUN(special_form_p, "special-form-p", (LispVal * val), "(val)", "") { return builtin_function_p(val, true) ? Qt : Qnil; } -DEFINE_SYMBOL(declare, "declare"); +DEFSPECIAL(declare, "declare", (LispVal * forms), "(&rest forms)", "") { + lisp_signal(Qerror, + LIST(LISP_LITSTR("(declare ...) form in invalid position"))); +} DEFINE_SYMBOL(name, "name"); DEFINE_SYMBOL(callable, "callable"); diff --git a/src/function.h b/src/function.h index 992a0c9..4d770a6 100644 --- a/src/function.h +++ b/src/function.h @@ -2,6 +2,9 @@ #define INCLUDED_FUNCTION_H #include "base.h" +#include "lisp_string.h" +#include "list.h" +#include "stack.h" DECLARE_SYMBOL(and_optional); DECLARE_SYMBOL(and_rest); @@ -95,6 +98,7 @@ LispVal *raw_funcall(LispVal *func, LispVal *args); DECLARE_FUNCTION(funcall, (LispVal * func, LispVal *args)); #define CALL(func, ...) (Ffuncall((func), LIST(__VA_ARGS__))) #define CALL0(func) (Ffuncall((func), Qnil)) +DECLARE_FUNCTION(apply, (LispVal * func, LispVal *args)); DECLARE_FUNCTION(lambda, (LispVal * args, LispVal *body)); DECLARE_FUNCTION(callablep, (LispVal * obj)); @@ -104,7 +108,7 @@ bool builtin_function_p(LispVal *val, bool special_form); DECLARE_FUNCTION(builtin_function_p, (LispVal * val)); DECLARE_FUNCTION(special_form_p, (LispVal * val)); -DECLARE_SYMBOL(declare); +DECLARE_FUNCTION(declare, (LispVal * forms)); DECLARE_SYMBOL(name); DECLARE_SYMBOL(callable); diff --git a/src/lisp_string.c b/src/lisp_string.c index 63166c5..09c5fd9 100644 --- a/src/lisp_string.c +++ b/src/lisp_string.c @@ -22,13 +22,18 @@ LispVal *make_lisp_string(const char *data, size_t length, bool take, LispVal *lisp_sprintf(const char *format, ...) { va_list args; va_start(args, format); + LispVal *s = lisp_vsprintf(format, args); + va_end(args); + return s; +} + +LispVal *lisp_vsprintf(const char *format, va_list args) { va_list args2; va_copy(args2, args); int needed = vsnprintf(NULL, 0, format, args2); va_end(args2); char *buffer = lisp_malloc(needed + 1); int printed = vsnprintf(buffer, needed + 1, format, args); - va_end(args); assert(printed == needed); return make_lisp_string(buffer, printed, true, false); } diff --git a/src/lisp_string.h b/src/lisp_string.h index 4af4f56..2536664 100644 --- a/src/lisp_string.h +++ b/src/lisp_string.h @@ -3,6 +3,8 @@ #include "base.h" +#include + // LispString (the type) is defined in base.h LispVal *make_lisp_string(const char *data, size_t length, bool take, @@ -11,6 +13,7 @@ LispVal *make_lisp_string(const char *data, size_t length, bool take, (make_lisp_string(litstr, sizeof(litstr) - 1, false, false)) LispVal *lisp_sprintf(const char *format, ...) FORMAT(1, 2); +LispVal *lisp_vsprintf(const char *format, va_list args); DECLARE_FUNCTION(strings_equal, (LispVal * string1, LispVal *string2)); DECLARE_FUNCTION(hash_string, (LispVal * string)); diff --git a/src/list.c b/src/list.c index ca9954b..a1b6d0b 100644 --- a/src/list.c +++ b/src/list.c @@ -106,6 +106,22 @@ DEFUN(list, "list", (LispVal * args), "(&rest args)", "") { return args; } +DEFUN(list_star, "list*", (LispVal * arg, LispVal *args), "(arg &rest args)", + "") { + if (NILP(args)) { + return arg; + } else if (NILP(XCDR(args))) { + return CONS(arg, XCAR(args)); + } + LispVal *out = CONS(arg, args); + args = out; + while (CONSP(args) && CONSP(XCDR(args)) && CONSP(XCDR(XCDR(args)))) { + args = XCDR(args); + } + RPLACD(args, XCAR(XCDR(args))); + return out; +} + DEFUN(copy_list, "copy-list", (LispVal * list), "(list)", "") { LispVal *start = Qnil; LispVal *end = NULL; diff --git a/src/list.h b/src/list.h index aed91b8..1287bd2 100644 --- a/src/list.h +++ b/src/list.h @@ -132,6 +132,7 @@ DECLARE_FUNCTION(proper_list_p, (LispVal * obj)); DECLARE_FUNCTION(circular_list_p, (LispVal * obj)); DECLARE_FUNCTION(dotted_list_p, (LispVal * obj)); DECLARE_FUNCTION(list, (LispVal * args)); +DECLARE_FUNCTION(list_star, (LispVal * arg, LispVal *args)); DECLARE_FUNCTION(copy_list, (LispVal * list)); LispVal *nth(size_t n, LispVal *list); DECLARE_FUNCTION(nth, (LispVal * n, LispVal *list)); diff --git a/src/macro.c b/src/macro.c index ce3543f..4a517cc 100644 --- a/src/macro.c +++ b/src/macro.c @@ -134,6 +134,8 @@ static LispVal *macroexpand_special_form(LispVal *fobj, LispVal *form, LispVal *prog = macroexpand_list(XCDR_SAFE(XCDR_SAFE(form)), lexical_macros); return CONS(XCAR(form), CONS(bindings, prog)); + } else if (IS(declare)) { + return form; } abort(); #undef IS diff --git a/src/read.c b/src/read.c index 5b58d7e..3b286e8 100644 --- a/src/read.c +++ b/src/read.c @@ -2,6 +2,7 @@ #include "lisp_string.h" #include "list.h" +#include "stack.h" #include #include @@ -64,17 +65,17 @@ static void skip_whitespace(ReadStream *stream) { } } -noreturn void read_error(ReadStream *stream, size_t length, const char *msg, - ...) { - fprintf(stderr, "read-error at %zu:%zu: ", stream->line, stream->col); +FORMAT(3, 4) +static noreturn void read_error(ReadStream *stream, size_t length, + const char *msg, ...) { va_list args; va_start(args, msg); - vfprintf(stderr, msg, args); + LispVal *lmsg = lisp_vsprintf(msg, args); va_end(args); - fprintf(stderr, ":\n context => "); - fwrite(stream->buffer + stream->off, 1, length, stderr); - fputc('\n', stderr); - exit(1); + lisp_signal(Qread_error, + LIST(MAKE_FIXNUM(stream->line), MAKE_FIXNUM(stream->col), lmsg, + make_lisp_string(stream->buffer + stream->off, length, + true, true))); } static ALWAYS_INLINE bool DOT_SYMBOL_P(LispVal *val) { @@ -480,3 +481,6 @@ LispVal *read(ReadStream *stream) { return next_symbol(stream); } } + +DEFINE_SYMBOL(read_error, "read-error"); +DEFINE_CONDITION_CLASS(read_error, error); diff --git a/src/read.h b/src/read.h index 3ffc75c..7b2bdf3 100644 --- a/src/read.h +++ b/src/read.h @@ -32,4 +32,7 @@ void read_stream_init(ReadStream *stream, const char *buffer, size_t length); // NULL on eof LispVal *read(ReadStream *stream); +DECLARE_SYMBOL(read_error); +MAKE_CONDITION_CLASS(read_error); + #endif