Zander671/simple-lisp
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Improve printing

Browse Source
This commit is contained in:
Alexander Rosenberg
2025-09-24 22:07:32 -07:00
parent 1118d143fc
commit 9c7eee0266
4 changed files with 353 additions and 25 deletions
Download Patch File Download Diff File Expand all files Collapse all files

20
src/kernel.sl
View File

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

339
src/lisp.c
View File

@ -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)", "");
}

17
src/lisp.h
View File

@ -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) { \

2
src/read.c
View File

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