Apply and read errors

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)))

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");

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);

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);
 }

src/lisp_string.h

@@ -3,6 +3,8 @@
 
 #include "base.h"
 
+#include <stdarg.h>
+
 // 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));

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;

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));

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

src/read.c

@@ -2,6 +2,7 @@
 
 #include "lisp_string.h"
 #include "list.h"
+#include "stack.h"
 
 #include <ctype.h>
 #include <inttypes.h>
@@ -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);

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