From 9c7eee0266149d0a3d2ea5015a145174c2f5afd4 Mon Sep 17 00:00:00 2001 From: Alexander Rosenberg Date: Wed, 24 Sep 2025 22:07:32 -0700 Subject: [PATCH] Improve printing --- src/kernel.sl | 20 ++- src/lisp.c | 339 +++++++++++++++++++++++++++++++++++++++++++++++--- src/lisp.h | 17 ++- src/read.c | 2 +- 4 files changed, 353 insertions(+), 25 deletions(-) diff --git a/src/kernel.sl b/src/kernel.sl index 3ada365..0319fd7 100644 --- a/src/kernel.sl +++ b/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))) diff --git a/src/lisp.c b/src/lisp.c index a314a09..b200feb 100644 --- a/src/lisp.c +++ b/src/lisp.c @@ -4,10 +4,14 @@ #include "read.h" // IWYU pragma: keep #include +#include #include #include #include +// TODO switch to stdio +#include + // 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, "is_builtin) { + np = CHECK_IO_RESULT(dprintf(fd, "is_macro && fn->name == Qlambda) { + np = CHECK_IO_RESULT(dprintf(fd, "is_macro) { + np = CHECK_IO_RESULT(dprintf(fd, "name == Qlambda) { + np = CHECK_IO_RESULT(dprintf(fd, "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, "", (uintmax_t) obj), fd); + return np; + } + case TYPE_PACKAGE: { + LispPackage *pkg = obj; + int64_t np = CHECK_IO_RESULT(dprintf(fd, "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, "", + (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)", ""); } diff --git a/src/lisp.h b/src/lisp.h index bcbbe56..f3b03ea 100644 --- a/src/lisp.h +++ b/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) { \ diff --git a/src/read.c b/src/read.c index f3e308a..6ddc18b 100644 --- a/src/read.c +++ b/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");