Improve printing

src/kernel.sl

@@ -223,6 +223,10 @@
 (define-type-predicate number (obj &opt min max)
   (typep obj (list 'or (list 'float min max)
                    (list 'integer min max))))
+(define-type-predicate readable alias (or number vector pair symbol string))
+
+(defun readablep (obj)
+  (typep obj 'readable))
 
 (defun symbol-type-predicate (symbol)
   "Return the type predicate associated with SYMBOL."
@@ -362,12 +366,6 @@
 (defun import-symbol (symbol &opt target)
   (import-package (symbol-package symbol) (list (symbol-name symbol)) target))
 
-(defun symbol-accessible-p (symbol &opt package)
-  "Return non-nil if SYMBOL is accessible from PACKAGE."
-  (let* ((def '::unbound)
-         (found (intern-soft (symbol-name symbol) def package t)))
-    (eq symbol found)))
-
 (defun length (seq)
   (tcase seq
     (list (list-length seq))
@@ -436,3 +434,13 @@
 
 (defun char-code (str)
   (aref str 0))
+
+(defun print-readably (obj &opt (newline t) stream)
+  (unless (readablep obj)
+    (throw 'type-error '(readablep) obj))
+  (tcase obj
+    (symbol (print (quote-symbol-for-read obj :as-needed)))
+    (string (print (quote-string obj)))
+    (t (print obj)))
+  (when newline
+    (println)))

src/lisp.c

@@ -4,10 +4,14 @@
 #include "read.h" // IWYU pragma: keep
 
 #include <ctype.h>
+#include <errno.h>
 #include <stdarg.h>
 #include <stdio.h>
 #include <string.h>
 
+// TODO switch to stdio
+#include <unistd.h>
+
 // used to fix up some indentation or syntax highlighting problems
 #define IGNORE() struct __ignored_struct
 
@@ -564,16 +568,6 @@ DEFUN(user_pointer_p, "user-pointer-p", (LispVal * val)) {
     return LISP_BOOL(USER_POINTER_P(val));
 }
 
-DEFUN(print, "print", (LispVal * obj)) {
-    debug_dump(stdout, obj, false);
-    return Qnil;
-}
-
-DEFUN(println, "println", (LispVal * obj)) {
-    debug_dump(stdout, obj, true);
-    return Qnil;
-}
-
 // ##################################
 // # Evaluation and Macro Expansion #
 // ##################################
@@ -2398,6 +2392,81 @@ DEFUN(intern, "intern",
     return sym;
 }
 
+DEFUN(quote_symbol_name, "quote-symbol-name", (LispVal * name)) {
+    CHECK_TYPE(TYPE_STRING, name);
+    LispString *str = (LispString *) name;
+    size_t out_len = str->length;
+    char *out = lisp_malloc(str->length + 1);
+    for (size_t i = 0, oi = 0; i < str->length; ++i, ++oi) {
+        char c = str->data[i];
+        if (c == ':' || c == '`' || c == ',' || c == '\'' || c == '"'
+            || isspace(c) || c == '(' || c == ')' || c == '[' || c == ']') {
+            out = lisp_realloc(out, ++out_len + 1);
+            out[oi++] = '\\';
+        }
+        out[oi] = str->data[i];
+    }
+    out[out_len] = '\0';
+    return make_lisp_string(out, out_len, true, false);
+}
+
+DEFUN(symbol_accessible_p, "symbol-accessible-p",
+      (LispVal * symbol, LispVal *package)) {
+    LispVal *name = Fsymbol_name(symbol);
+    LispVal *found;
+    WITH_CLEANUP(name, {
+        found = Fintern_soft(name, Qunbound, package, Qt); //
+    });
+    bool res = found == symbol;
+    refcount_unref(found);
+    return LISP_BOOL(res);
+}
+
+DEF_STATIC_SYMBOL(kw_as_needed, "as-needed");
+DEFUN(quote_symbol_for_read, "quote-symbol-for-read",
+      (LispVal * target, LispVal *include_package)) {
+    CHECK_TYPE(TYPE_SYMBOL, target);
+    LispSymbol *sym = (LispSymbol *) target;
+    LispString *sym_name =
+        (LispString *) Fquote_symbol_name(LISPVAL(sym->name));
+    if (NILP(include_package)) {
+        return LISPVAL(sym_name);
+    } else if (include_package == Qkw_as_needed) {
+        void *cl_handler =
+            register_cleanup(&refcount_unref_as_callback, sym_name);
+        bool accessible = !NILP(Fsymbol_accessible_p(LISPVAL(sym), Qnil));
+        cancel_cleanup(cl_handler);
+        if (accessible) {
+            return LISPVAL(sym_name);
+        }
+        // otherwise, go on to print the package
+    }
+    if (NILP(sym->package)) {
+        size_t size = sym_name->length + 2;
+        char *new_name = lisp_malloc(size + 1);
+        snprintf(new_name, size + 1, "::%s", sym_name->data);
+        refcount_unref(sym_name);
+        return make_lisp_string(new_name, size, true, false);
+    }
+    LispString *pkg_name = (LispString *) Fquote_symbol_name(
+        LISPVAL(((LispPackage *) sym->package)->name));
+    if (NILP(Fexported_symbol_p(LISPVAL(sym)))) {
+        size_t size = pkg_name->length + sym_name->length + 2;
+        char *new_name = lisp_malloc(size + 1);
+        snprintf(new_name, size + 1, "%s::%s", pkg_name->data, sym_name->data);
+        refcount_unref(pkg_name);
+        refcount_unref(sym_name);
+        return make_lisp_string(new_name, size, true, false);
+    } else {
+        size_t size = pkg_name->length + sym_name->length + 1;
+        char *new_name = lisp_malloc(size + 1);
+        snprintf(new_name, size + 1, "%s:%s", pkg_name->data, sym_name->data);
+        refcount_unref(pkg_name);
+        refcount_unref(sym_name);
+        return make_lisp_string(new_name, size, true, false);
+    }
+}
+
 LispVal *intern(const char *name, size_t length, bool take, LispVal *package,
                 bool included_too) {
     if (!NILP(package)) {
@@ -3038,6 +3107,77 @@ DEFUN(string_to_vector, "string-to-vector", (LispVal * str)) {
     return make_lisp_vector(vdata, s->length);
 }
 
+DEFUN(quote_string, "quote-string", (LispVal * target)) {
+    CHECK_TYPE(TYPE_STRING, target);
+    LispString *str = (LispString *) target;
+    size_t out_size = str->length + 2;
+    char *out = lisp_malloc(out_size + 1);
+    out[0] = '"';
+    for (size_t i = 0, oi = 1; i < str->length; ++i, ++oi) {
+        switch (str->data[i]) {
+        case '\n':
+            out = lisp_realloc(out, ++out_size + 1);
+            out[oi++] = '\\';
+            out[oi] = 'n';
+            break;
+        case '\t':
+            out = lisp_realloc(out, ++out_size + 1);
+            out[oi++] = '\\';
+            out[oi] = 't';
+            break;
+        case '\r':
+            out = lisp_realloc(out, ++out_size + 1);
+            out[oi++] = '\\';
+            out[oi] = 'r';
+            break;
+        case '\0':
+            out = lisp_realloc(out, ++out_size + 1);
+            out[oi++] = '\\';
+            out[oi] = '0';
+            break;
+        case '"':
+            out = lisp_realloc(out, ++out_size + 1);
+            out[oi++] = '\\';
+            out[oi] = '"';
+            break;
+        case '\\':
+            out = lisp_realloc(out, ++out_size + 1);
+            out[oi++] = '\\';
+            out[oi] = '\\';
+            break;
+        default:
+            out[oi] = str->data[i];
+            break;
+        }
+    }
+    out[out_size - 1] = '"';
+    out[out_size] = '\0';
+    return make_lisp_string(out, out_size, true, false);
+}
+
+DEFUN(concat, "concat", (LispVal * strings)) {
+    LispVal *retval;
+    WITH_PUSH_FRAME(Qnil, Qnil, true, {
+        char *out = lisp_malloc(1);
+        out[0] = '\0';
+        size_t size = 0;
+        void *cl_handler = register_cleanup(&free_double_ptr, &out);
+        FOREACH(elt, strings) {
+            if (NILP(elt)) {
+                continue;
+            }
+            CHECK_TYPE(TYPE_STRING, elt);
+            LispString *s = (LispString *) elt;
+            size += s->length;
+            out = lisp_realloc(out, size + 1);
+            strncat(out, s->data, s->length);
+        }
+        cancel_cleanup(cl_handler);
+        retval = make_lisp_string(out, size, true, false);
+    });
+    return retval;
+}
+
 LispVal *sprintf_lisp(const char *format, ...) {
     va_list args;
     va_start(args, format);
@@ -3063,6 +3203,169 @@ bool strings_equal_nocase(const char *s1, const char *s2, size_t n) {
     return true;
 }
 
+// ################
+// # IO Functions #
+// ################
+static inline int CHECK_IO_RESULT(int res, int fd) {
+    if (res < 0) {
+        if (errno == EBADFD) {
+            Fthrow(Qtype_error, const_list(false, 1, make_lisp_integer(fd)));
+        } else {
+            Fthrow(Qio_error, Qnil);
+        }
+    }
+    return res;
+}
+
+static int64_t internal_print(void *obj, int64_t fd, bool first_in_list) {
+    switch (TYPEOF(obj)) {
+    case TYPE_STRING: {
+        LispString *str = obj;
+        return CHECK_IO_RESULT(write(fd, str->data, str->length), fd);
+    }
+    case TYPE_SYMBOL: {
+        LispVal *name = Fquote_symbol_for_read(obj, Qkw_as_needed);
+        int64_t np;
+        WITH_CLEANUP(name, {
+            np = internal_print(name, fd, true); //
+        });
+        return np;
+    } break;
+    case TYPE_PAIR: {
+        if (HEAD(obj) == Qquote && PAIRP(TAIL(obj)) && NILP(TAIL(TAIL(obj)))) {
+            int64_t np = CHECK_IO_RESULT(dprintf(fd, "'"), fd);
+            np += internal_print(HEAD(TAIL(obj)), fd, true);
+            return np;
+        }
+        int64_t np;
+        if (first_in_list) {
+            np = CHECK_IO_RESULT(dprintf(fd, "("), fd);
+        } else {
+            np = CHECK_IO_RESULT(dprintf(fd, " "), fd);
+        }
+        np += internal_print(HEAD(obj), fd, true);
+        if (TAIL(obj) == Qnil) {
+            np = CHECK_IO_RESULT(dprintf(fd, ")"), fd);
+        } else {
+            np += internal_print(TAIL(obj), fd, false);
+        }
+        return np;
+    }
+    case TYPE_VECTOR: {
+        LispVector *v = obj;
+        int64_t np = CHECK_IO_RESULT(dprintf(fd, "["), fd);
+        for (size_t i = 0; i < v->length; ++i) {
+            np += internal_print(v->data[i], fd, true);
+            np += CHECK_IO_RESULT(dprintf(fd, " "), fd);
+        }
+        np += CHECK_IO_RESULT(dprintf(fd, "]"), fd);
+        return np;
+    }
+    case TYPE_INTEGER:
+        return CHECK_IO_RESULT(
+            dprintf(fd, "%ji", (intmax_t) ((LispInteger *) obj)->value), fd);
+    case TYPE_FLOAT:
+        return CHECK_IO_RESULT(dprintf(fd, "%Lf", ((LispFloat *) obj)->value),
+                               fd);
+    case TYPE_FUNCTION: {
+        LispFunction *fn = obj;
+        int64_t np;
+        bool need_name = true;
+        if (fn->is_builtin && fn->is_macro) {
+            np = CHECK_IO_RESULT(dprintf(fd, "<special-form "), fd);
+        } else if (fn->is_builtin) {
+            np = CHECK_IO_RESULT(dprintf(fd, "<builtin "), fd);
+        } else if (fn->is_macro && fn->name == Qlambda) {
+            np = CHECK_IO_RESULT(dprintf(fd, "<lambda-macro "), fd);
+            need_name = false;
+        } else if (fn->is_macro) {
+            np = CHECK_IO_RESULT(dprintf(fd, "<macro "), fd);
+        } else if (fn->name == Qlambda) {
+            np = CHECK_IO_RESULT(dprintf(fd, "<lambda "), fd);
+            need_name = false;
+        } else {
+            np = CHECK_IO_RESULT(dprintf(fd, "<function "), fd);
+        }
+        if (need_name) {
+            np += internal_print(fn->name, fd, true);
+            np += CHECK_IO_RESULT(dprintf(fd, " "), fd);
+        }
+        np += CHECK_IO_RESULT(dprintf(fd, "at %#jx>", (uintmax_t) obj), fd);
+        return np;
+    }
+    case TYPE_HASHTABLE: {
+        LispHashtable *ht = obj;
+        LispVal *hash_fn = NILP(ht->hash_fn) ? Qid : ht->hash_fn;
+        LispVal *eq_fn = NILP(ht->eq_fn) ? Qeq : ht->eq_fn;
+        int64_t np = CHECK_IO_RESULT(
+            dprintf(fd, "<hash-table size=%#jx count=%#jx eq-fn=",
+                    (uintmax_t) ht->table_size, (uintmax_t) ht->count),
+            fd);
+        np += internal_print(eq_fn, fd, true);
+        np += CHECK_IO_RESULT(dprintf(fd, " hash-fn="), fd);
+        np += internal_print(hash_fn, fd, true);
+        np += CHECK_IO_RESULT(dprintf(fd, " at %#jx>", (uintmax_t) obj), fd);
+        return np;
+    }
+    case TYPE_PACKAGE: {
+        LispPackage *pkg = obj;
+        int64_t np = CHECK_IO_RESULT(dprintf(fd, "<package "), fd);
+        LispVal *name_str = Fquote_string(LISPVAL(pkg->name));
+        WITH_CLEANUP(name_str, {
+            np += internal_print(name_str, fd, true); //
+        });
+        np += CHECK_IO_RESULT(
+            dprintf(fd, " interned=%ju at %#jx>",
+                    (uintmax_t) ((LispHashtable *) pkg->obarray)->count,
+                    (uintmax_t) obj),
+            fd);
+        return np;
+    } break;
+    case TYPE_USER_POINTER:
+        return CHECK_IO_RESULT(dprintf(fd, "<user-pointer to %#jx at %#jx>",
+                                       (uintmax_t) USERPTR(void *, obj),
+                                       (uintmax_t) obj),
+                               fd);
+    default:
+        abort();
+    }
+}
+
+DEFUN_DISTINGUISHED(print, "print", (LispVal * obj, LispVal *stream)) {
+    int64_t fd;
+    if (stream == Qunbound) {
+        fd = 1;
+    } else {
+        CHECK_TYPE(TYPE_INTEGER, stream);
+        fd = ((LispInteger *) stream)->value;
+        if (fd < 0) {
+            Fthrow(Qtype_error, const_list(true, 1, stream));
+        }
+    }
+    return make_lisp_integer(internal_print(obj, fd, false));
+}
+
+DEFUN_DISTINGUISHED(println, "println", (LispVal * obj, LispVal *stream)) {
+    static char NEWLINE = '\n';
+    int64_t fd;
+    if (stream == Qunbound) {
+        fd = 1;
+    } else {
+        CHECK_TYPE(TYPE_INTEGER, stream);
+        fd = ((LispInteger *) stream)->value;
+        if (fd < 0) {
+            Fthrow(Qtype_error, const_list(true, 1, stream));
+        }
+    }
+    int64_t np = 0;
+    if (obj != Qunbound) {
+        np += internal_print(obj, fd, true);
+    }
+    np += CHECK_IO_RESULT(write(fd, &NEWLINE, 1), fd);
+    fsync(fd);
+    return make_lisp_integer(np);
+}
+
 // ########################
 // # Lexenv and the Stack #
 // ########################
@@ -3268,6 +3571,7 @@ DEF_STATIC_SYMBOL(package_exists_error, "package-exists-error");
 DEF_STATIC_SYMBOL(import_error, "import-error");
 DEF_STATIC_SYMBOL(unknown_package_error, "unknown-package-error");
 DEF_STATIC_SYMBOL(out_of_bounds_error, "out-of-bounds-error");
+DEF_STATIC_SYMBOL(io_error, "io-error");
 
 // ###################
 // # Debug Functions #
@@ -3429,6 +3733,7 @@ static void register_symbols_and_functions(void) {
     REGISTER_SYMBOL(backquote);
     REGISTER_SYMBOL_INTO(kw_success, keyword_package);
     REGISTER_SYMBOL_INTO(kw_finally, keyword_package);
+    REGISTER_SYMBOL_INTO(kw_as_needed, keyword_package);
     REGISTER_SYMBOL(shutdown_signal);
     REGISTER_SYMBOL(type_error);
     REGISTER_SYMBOL(read_error);
@@ -3446,6 +3751,7 @@ static void register_symbols_and_functions(void) {
     REGISTER_SYMBOL(import_error);
     REGISTER_SYMBOL(unknown_package_error);
     REGISTER_SYMBOL(out_of_bounds_error);
+    REGISTER_SYMBOL(io_error);
 
     // some stuff that musn't be user accesable
     REGISTER_SYMBOL_NOINTERN(toplevel);
@@ -3472,11 +3778,6 @@ static void register_symbols_and_functions(void) {
     REGISTER_FUNCTION(quote, "(form)", "Return FORM as read by the reader.");
     REGISTER_FUNCTION(exit, "(&opt code)",
                       "Exit with CODE, defaulting to zero.");
-    REGISTER_FUNCTION(print, "(obj)",
-                      "Print a human-readable representation of OBJ.");
-    REGISTER_FUNCTION(
-        println, "(obj)",
-        "Print a human-readable representation of OBJ followed by a newline.");
     REGISTER_FUNCTION(not, "(obj)",
                       "Return t if OBJ is nil, otherwise return t.");
     REGISTER_FUNCTION(add, "(&rest nums)", "Return the sun of NUMS.");
@@ -3584,4 +3885,12 @@ static void register_symbols_and_functions(void) {
     REGISTER_FUNCTION(subvector, "(seq &opt start end)", "");
     REGISTER_FUNCTION(string_to_vector, "(str)", "");
     REGISTER_FUNCTION(maphash, "(func table)", "");
+    REGISTER_FUNCTION(quote_string, "(target)", "");
+    REGISTER_FUNCTION(quote_symbol_name, "(name)", "");
+    REGISTER_FUNCTION(quote_symbol_for_read, "(target &opt include-package)",
+                      "");
+    REGISTER_FUNCTION(concat, "(&rest strings)", "");
+    REGISTER_FUNCTION(print, "(obj &opt stream)", "");
+    REGISTER_FUNCTION(println, "(&opt obj stream)", "");
+    REGISTER_FUNCTION(symbol_accessible_p, "(symbol &opt package)", "");
 }

src/lisp.h

@@ -397,9 +397,6 @@ DECLARE_FUNCTION(not, (LispVal * obj));
 DECLARE_FUNCTION(type_of, (LispVal * val));
 DECLARE_FUNCTION(user_pointer_p, (LispVal * val));
 
-DECLARE_FUNCTION(print, (LispVal * obj));
-DECLARE_FUNCTION(println, (LispVal * obj));
-
 // ##################################
 // # Evaluation and Macro Expansion #
 // ##################################
@@ -506,6 +503,11 @@ DECLARE_FUNCTION(intern_soft, (LispVal * name, LispVal *def, LispVal *package,
                                LispVal *included_too));
 DECLARE_FUNCTION(intern,
                  (LispVal * name, LispVal *package, LispVal *included_too));
+DECLARE_FUNCTION(quote_symbol_name, (LispVal * name));
+DECLARE_FUNCTION(symbol_accessible_p, (LispVal * symbol, LispVal *package));
+extern LispVal *Qkw_as_needed;
+DECLARE_FUNCTION(quote_symbol_for_read,
+                 (LispVal * target, LispVal *include_package));
 LispVal *intern(const char *name, size_t length, bool take, LispVal *package,
                 bool included_too);
 
@@ -563,9 +565,17 @@ DECLARE_FUNCTION(string, (LispVal * chars));
 DECLARE_FUNCTION(hash_string, (LispVal * obj));
 DECLARE_FUNCTION(strings_equal, (LispVal * obj1, LispVal *obj2));
 DECLARE_FUNCTION(string_to_vector, (LispVal * str));
+DECLARE_FUNCTION(quote_string, (LispVal * src));
+DECLARE_FUNCTION(concat, (LispVal * strings));
 LispVal *sprintf_lisp(const char *format, ...) PRINTF_FORMAT(1, 2);
 bool strings_equal_nocase(const char *s1, const char *s2, size_t n);
 
+// ################
+// # IO Functions #
+// ################
+DECLARE_FUNCTION(print, (LispVal * obj, LispVal *stream));
+DECLARE_FUNCTION(println, (LispVal * obj, LispVal *stream));
+
 // ########################
 // # Lexenv and the Stack #
 // ########################
@@ -683,6 +693,7 @@ extern LispVal *Qpackage_exists_error;
 extern LispVal *Qimport_error;
 extern LispVal *Qunknown_package_error;
 extern LispVal *Qout_of_bounds_error;
+extern LispVal *Qio_error;
 
 #define CHECK_TYPE(type, val)                                                 \
     if (TYPEOF(val) != type) {                                                \

src/read.c

@@ -309,7 +309,7 @@ static LispVal *read_symbol(struct ReadState *state) {
             free(pkg_name);
             free(sym_name);
             READ_ERROR(&prev_state, 1, "invalid character for symbol name");
-        } else if (backslash && (c == '\n' || c == EOS)) {
+        } else if (backslash && c == EOS) {
             free(pkg_name);
             free(sym_name);
             READ_ERROR(&prev_state, 1, "backslash not escaping anything");