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

A bunch of changes

Browse Source
This commit is contained in:
Alexander Rosenberg
2025-10-28 03:02:39 -07:00
parent b8c685fa17
commit 6f927bf768
5 changed files with 377 additions and 129 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
CMakeLists.txt
View File

@ -15,8 +15,8 @@ FetchContent_Declare(
FetchContent_MakeAvailable(refcount)
add_compile_options(-fsanitize=address,leak,undefined)
add_link_options(-fsanitize=address,leak,undefined)
# add_compile_options(-fsanitize=address,leak,undefined)
# add_link_options(-fsanitize=address,leak,undefined)
add_executable(simple-lisp src/main.c src/lisp.c src/read.c)
target_link_libraries(simple-lisp PUBLIC refcount)

152
src/kernel.sl
View File

@ -3,24 +3,38 @@
(fset 'null 'not)
(fset 'list (lambda (&rest r) (declare (name list)) r))
;; these versions do not support (declare) forms
(fset 'defmacro
(lambda (name args &rest body)
(declare (name defmacro) macro)
(list 'progn
(list 'fset (list '\' name)
(apply 'list 'lambda args
(list 'declare (list 'name name) 'macro)
body)))))
(defmacro defun (name args &rest body)
(list 'progn
(list 'fset (list '\' name)
(apply 'list 'lambda args
(list 'declare (list 'name name))
body))))
(if (and (stringp (head body)) (not (null (tail body))))
(progn
(apply 'list
(head body)
(list 'declare (list 'name name)
'macro)
body))
(apply 'list
(list 'declare (list 'name name) 'macro)
body))))))
(defmacro defun (name args &rest body)
(list 'fset (list '\' name)
(apply 'list 'lambda args
(if (and (stringp (head body)) (not (null (tail body))))
(progn
(apply 'list
(head body)
(list 'declare (list 'name name))
(tail body)))
(progn
(list 'declare (list 'name name))
body)))))
(defun ensure-list (arg)
(if (pairp arg)
(if (or (null arg) (pairp arg))
arg
(list arg)))
@ -62,7 +76,7 @@
(list 'head tail-var))
(list 'setq tail-var (list 'tail tail-var))))
(second vars)))
(make-symbol "tail")))
'::tail))
(defun maphead (func list)
(funcall
@ -106,14 +120,13 @@
(throw 'argument-error))))
(apply 'list 'funcall (apply 'list 'lambda
(reverse vars)
(list 'declare (list 'name
(make-symbol "let")))
(list 'declare (list 'name '::let))
body)
(reverse vals)))))
(defmacro let* (bindings &rest body)
(list 'funcall (apply 'list 'lambda (apply 'list '&opt bindings)
(list 'declare (list 'name (make-symbol "let*")))
(list 'declare (list 'name '::let*))
body)))
(defun lasttail (list)
@ -124,12 +137,69 @@
list (tail list)))
out))
(defun mapconcat (func list)
(let (start end)
(dolist (elt list)
(if (not start)
(setq start (copy-list (funcall func elt))
end (lasttail start))
(settail end (copy-list (funcall func elt)))
(setq end (lasttail end))))
start))
(defun identity (e) e)
(defun append (&rest lists)
;; another implementation
;; (mapconcat 'identity lists)
(let* ((start (copy-list (head lists)))
(end (lasttail start)))
(dolist (list (tail lists))
(settail end (copy-list list))
(setq end (lasttail end)))
start))
(defmacro prog1 (first-form &rest body)
(let ((rval '::rval))
(list 'let (list (list rval first-form))
(apply 'list 'progn body)
rval)))
;; these versions support (declare) forms
(defmacro defmacro (name args &rest body)
(list 'fset (list '\' name)
(append (list 'lambda args)
(when (and (stringp (head body)) (not (null (tail body))))
(prog1 (list (head body))
(setq body (tail body))))
(list
(apply 'list 'declare (list 'name name) 'macro
(when (and (pairp (head body))
(eq (head (head body)) 'declare))
(prog1 (tail (head body))
(setq body (tail body))))))
body)))
(defmacro defun (name args &rest body)
(list 'fset (list '\' name)
(append (list 'lambda args)
(when (and (stringp (head body)) (not (null (tail body))))
(prog1 (list (head body))
(setq body (tail body))))
(list
(apply 'list 'declare (list 'name name)
(when (and (pairp (head body))
(eq (head (head body)) 'declare))
(prog1 (tail (head body))
(setq body (tail body))))))
body)))
(defun internal-expand-single-cond (cond)
(if (tail cond)
(let ((res (list 'if (head cond)
(apply 'list 'progn (tail cond)))))
(pair res res))
(let* ((res-var (make-symbol "res"))
(let* ((res-var '::res)
(if-stmt (list 'if res-var res-var)))
(pair (list 'let (list (list res-var (head cond)))
if-stmt)
@ -158,7 +228,7 @@
(defmacro define-type-predicate (name args &rest body)
(cond
((eq args 'alias)
(let ((var (make-symbol "var")))
(let ((var '::var))
(list 'put (list '\' name) ''type-predicate
(list 'lambda (list var) (list 'typep var (pair '\' body))))))
((and (symbolp args) (null body))
@ -233,7 +303,7 @@
(get symbol 'type-predicate))
(defmacro tcase (obj &rest conds)
(let ((obj-var (make-symbol "obj")))
(let ((obj-var '::obj))
(list 'let (list (list obj-var obj))
(pair
'cond
@ -253,7 +323,7 @@
(list 'return-from nil value))
(defmacro dotails (vars &rest body)
(let ((cur (make-symbol "cur")))
(let ((cur '::cur))
(list 'let (list (list cur (second vars)))
(list 'while (list 'pairp cur)
(apply 'list 'let (list (list (first vars) cur))
@ -284,28 +354,6 @@
(return-from find-if cur)))
default)
(defun mapconcat (func list)
(let (start end)
(dolist (elt list)
(if (not start)
(setq start (copy-list (funcall func elt))
end (lasttail start))
(settail end (copy-list (funcall func elt)))
(setq end (lasttail end))))
start))
(defun identity (e) e)
(defun append (&rest lists)
;; another implementation
;; (mapconcat 'identity lists)
(let* ((start (copy-list (head lists)))
(end (lasttail start)))
(dolist (list (tail lists))
(settail end (copy-list list))
(setq end (lasttail end)))
start))
(defmacro macrolet (macros &rest body)
(let* ((found-macros (make-hash-table))
(macro-fns (mapconcat (lambda (entry)
@ -435,12 +483,16 @@
(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)))
(defmacro defvar (name value &opt doc)
(unless (symbolp name)
(throw 'type-error '(symbolp) name))
(unless (or (not doc) (stringp doc))
(throw 'type-error '(null stringp) doc))
(apply 'list 'progn
(list 'make-symbol-special (list '\' name))
(list 'setq name value)
(when doc
(list (list 'set-symbol-value-docstr
(list '\' name) doc)))))
(set-symbol-value-docstr :a "d")

297
src/lisp.c
View File

@ -39,7 +39,10 @@ LispSymbol _Qnil = {
.plist = Qnil,
.function = Qnil,
.value = Qnil,
.is_constant = true,
.value_doc = Qnil,
.is_const_value = true,
.is_const_func = false,
.is_special_var = true,
};
DEF_STATIC_STRING(_Qunbound_name, "unbound");
@ -50,7 +53,10 @@ LispSymbol _Qunbound = {
.plist = Qnil,
.function = Qnil,
.value = Qunbound,
.is_constant = true,
.value_doc = Qnil,
.is_const_value = true,
.is_const_func = true,
.is_special_var = true,
};
DEF_STATIC_STRING(_Qt_name, "t");
@ -61,7 +67,10 @@ LispSymbol _Qt = {
.plist = Qnil,
.function = Qnil,
.value = Qt,
.is_constant = true,
.value_doc = Qnil,
.is_const_value = true,
.is_const_func = true,
.is_special_var = true,
};
// ###########################
@ -136,6 +145,7 @@ static bool held_refs_callback(void *obj, RefcountList **held, void *ignored) {
*held = refcount_list_push(*held, ((LispSymbol *) obj)->function);
*held = refcount_list_push(*held, ((LispSymbol *) obj)->plist);
*held = refcount_list_push(*held, ((LispSymbol *) obj)->value);
*held = refcount_list_push(*held, ((LispSymbol *) obj)->value_doc);
return true;
case TYPE_PAIR:
*held = refcount_list_push(*held, ((LispPair *) obj)->head);
@ -260,7 +270,10 @@ LispVal *make_lisp_symbol(LispVal *name) {
self->plist = Qnil;
self->function = Qnil;
self->value = Qunbound;
self->is_constant = false;
self->value_doc = Qnil;
self->is_const_value = false;
self->is_const_func = false;
self->is_special_var = false;
return LISPVAL(self);
}
@ -634,7 +647,8 @@ static LispVal **process_builtin_args(LispVal *fname, LispFunction *func,
goto key_no_val;
}
vec[oad->index] = refcount_ref(HEAD(arg));
} else if (KEYWORDP(arg) && !func->allow_other_keys && NILP(rest)) {
} else if (KEYWORDP(arg) && !func->allow_other_keys
&& NILP(func->rest_arg)) {
goto unknown_key;
} else if (NILP(func->rest_arg)) {
goto too_many;
@ -732,6 +746,14 @@ static LispVal *call_builtin(LispVal *name, LispFunction *func, LispVal *args,
return retval;
}
static void new_lexical_var(LispVal **lexenv, LispVal *name, LispVal *value) {
if (SPECIALP(name)) {
push_to_lexenv(&the_stack->dynenv, name, value);
} else {
push_to_lexenv(lexenv, name, value);
}
}
static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
LispVal **lexenv) {
LispVal *added_kwds = make_lisp_hashtable(Qnil, Qnil);
@ -747,7 +769,7 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
mode = OPT;
continue; // skip increment
}
push_to_lexenv(lexenv, HEAD(rargs), arg);
new_lexical_var(lexenv, HEAD(rargs), arg);
rargs = TAIL(rargs);
} break;
case OPT: {
@ -756,9 +778,9 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
continue; // skip increment
}
struct OptArgDesc *oad = USERPTR(struct OptArgDesc, HEAD(oargs));
push_to_lexenv(lexenv, oad->name, arg);
new_lexical_var(lexenv, oad->name, arg);
if (!NILP(oad->pred_var)) {
push_to_lexenv(lexenv, oad->pred_var, Qt);
new_lexical_var(lexenv, oad->pred_var, Qt);
}
oargs = TAIL(oargs);
} break;
@ -782,9 +804,9 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
}
LispVal *value = HEAD(args);
puthash(added_kwds, oad->name, Qt);
push_to_lexenv(lexenv, oad->name, value);
new_lexical_var(lexenv, oad->name, value);
if (!NILP(oad->pred_var)) {
push_to_lexenv(lexenv, oad->pred_var, Qt);
new_lexical_var(lexenv, oad->pred_var, Qt);
}
break;
case REST:
@ -800,7 +822,7 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
goto too_many_args;
}
}
push_to_lexenv(lexenv, func->rest_arg, args);
new_lexical_var(lexenv, func->rest_arg, args);
// done processing
goto done_adding;
}
@ -815,24 +837,24 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
// only check the current function's lexenv and not its parents'
if (NILP(gethash(added_kwds, oad->name, Qnil))) {
LispVal *eval_res = Feval(oad->default_form, the_stack->lexenv);
push_to_lexenv(lexenv, oad->name, eval_res);
new_lexical_var(lexenv, oad->name, eval_res);
refcount_unref(eval_res);
if (!NILP(oad->pred_var)) {
push_to_lexenv(lexenv, oad->pred_var, Qnil);
new_lexical_var(lexenv, oad->pred_var, Qnil);
}
}
}
FOREACH(arg, oargs) {
struct OptArgDesc *oad = USERPTR(struct OptArgDesc, arg);
LispVal *default_val = Feval(oad->default_form, the_stack->lexenv);
push_to_lexenv(lexenv, oad->name, default_val);
new_lexical_var(lexenv, oad->name, default_val);
refcount_unref(default_val);
if (!NILP(oad->pred_var)) {
push_to_lexenv(lexenv, oad->pred_var, Qnil);
new_lexical_var(lexenv, oad->pred_var, Qnil);
}
}
if (!NILP(func->rest_arg)) {
push_to_lexenv(lexenv, func->rest_arg, Qnil);
new_lexical_var(lexenv, func->rest_arg, Qnil);
}
done_adding:
cancel_cleanup(cl_handle);
@ -949,14 +971,27 @@ static inline LispVal *find_in_lexenv(LispVal *lexenv, LispVal *key) {
return Fplist_get(lexenv, key, Qunbound, Qnil);
}
static inline LispVal *find_dynamic_value_on_stack(LispVal *key) {
if (!the_stack) {
return Qunbound;
}
return Fplist_get(the_stack->dynenv, key, Qunbound, Qnil);
}
static LispVal *symbol_value_in_lexenv(LispVal *lexenv, LispVal *key) {
if (!NILP(lexenv)) {
CHECK_TYPE(TYPE_SYMBOL, key);
if (SPECIALP(key)) {
LispVal *local = find_dynamic_value_on_stack(key);
if (local != Qunbound) {
return local;
}
} else if (!NILP(lexenv)) {
LispVal *local = find_in_lexenv(lexenv, key);
if (local != Qunbound) {
return local;
}
}
LispVal *sym_val = Fsymbol_value(key);
LispVal *sym_val = Fsymbol_value(key, Qt);
if (sym_val != Qunbound) {
return sym_val;
}
@ -979,7 +1014,6 @@ DEFUN(eval, "eval", (LispVal * form, LispVal *lexenv), "(eval &opt lexenv)",
if (KEYWORDP(form)) {
return refcount_ref(form);
} else {
// this refs its return value
return symbol_value_in_lexenv(lexenv, form);
}
case TYPE_VECTOR: {
@ -1363,13 +1397,20 @@ DEFMACRO(if, "if", (LispVal * cond, LispVal *t, LispVal *nil),
static void set_symbol_in_lexenv(LispVal *key, LispVal *newval,
LispVal *lexenv) {
LispVal *lexval = Fplist_assoc(lexenv, key, Qnil);
if (PAIRP(lexval)) {
Fsethead(TAIL(lexval), newval);
if (VALUE_CONSTANTP(key)) {
Fthrow(Qconstant_value_error, Fpair(key, Qnil));
}
LispVal *val_pair = Qnil;
if (SPECIALP(key)) {
val_pair = Fplist_assoc(the_stack->dynenv, key, Qnil);
} else {
val_pair = Fplist_assoc(lexenv, key, Qnil);
}
if (PAIRP(val_pair)) {
Fsethead(TAIL(val_pair), newval);
} else {
refcount_ref(newval);
refcount_unref(((LispSymbol *) key)->value);
((LispSymbol *) key)->value = newval;
((LispSymbol *) key)->value = refcount_ref(newval);
}
}
@ -1388,7 +1429,9 @@ DEFMACRO(
LispVal *name = HEAD(tail);
tail = TAIL(tail);
retval = Feval(HEAD(tail), the_stack->lexenv);
set_symbol_in_lexenv(name, retval, the_stack->lexenv);
WITH_CLEANUP(retval, {
set_symbol_in_lexenv(name, retval, the_stack->lexenv); //
});
}
return retval;
}
@ -2382,11 +2425,40 @@ DEFUN(keywordp, "keywordp", (LispVal * val), "(obj)",
return LISP_BOOL(KEYWORDP(val));
}
DEFUN(const_value_p, "const-value-p", (LispVal * val), "(obj)",
"Return non-nil if OBJ's value is constant.") {
CHECK_TYPE(TYPE_SYMBOL, val);
return LISP_BOOL(VALUE_CONSTANTP(val));
}
DEFUN(const_func_p, "const-func-p", (LispVal * val), "(obj)",
"Return non-nil if OBJ's value as a function is constant.") {
CHECK_TYPE(TYPE_SYMBOL, val);
return LISP_BOOL(FUNC_CONSTANTP(val));
}
DEFUN(specialp, "specialp", (LispVal * val), "(obj)",
"Return non-nil if OBJ is a special variable.") {
CHECK_TYPE(TYPE_SYMBOL, val);
return LISP_BOOL(SPECIALP(val));
}
DEFUN(make_symbol, "make-symbol", (LispVal * name), "(name)",
"Return a new uninterned symbol named NAME.") {
return make_lisp_symbol(name);
}
DEFUN(make_symbol_special, "make-symbol-special", (LispVal * sym), "(sym)",
"Make it so that SYM is a special symbol, that is, it is dynamically "
"bound.") {
CHECK_TYPE(TYPE_SYMBOL, sym);
if (VALUE_CONSTANTP(sym)) {
Fthrow(Qconstant_value_error, Fpair(sym, Qnil));
}
((LispSymbol *) sym)->is_special_var = true;
return refcount_ref(sym);
}
DEFUN(symbol_package, "symbol-package", (LispVal * symbol), "(symbol)",
"Return the package of SYMBOL.") {
CHECK_TYPE(TYPE_SYMBOL, symbol);
@ -2413,12 +2485,72 @@ DEFUN(symbol_function, "symbol-function", (LispVal * symbol, LispVal *resolve),
return refcount_ref(symbol);
}
DEFUN(symbol_value, "symbol-value", (LispVal * symbol), "(symbol)",
"Return the global value of SYMBOL.") {
DEFUN(fset, "fset", (LispVal * sym, LispVal *new_func), "(symbol func)",
"Set the value as a function of SYMBOL to FUNC.") {
CHECK_TYPE(TYPE_SYMBOL, sym);
LispSymbol *sobj = ((LispSymbol *) sym);
if (FUNC_CONSTANTP(sobj)) {
Fthrow(Qconstant_function_error, Fpair(sym, Qnil));
}
refcount_ref(new_func);
refcount_unref(sobj->function);
sobj->function = new_func;
return refcount_ref(new_func);
}
DEFUN(symbol_value, "symbol-value", (LispVal * symbol, LispVal *default_only),
"(symbol &opt default-only)", "Return the global value of SYMBOL.") {
CHECK_TYPE(TYPE_SYMBOL, symbol);
if (KEYWORDP(symbol)) {
return refcount_ref(symbol);
} else if (SPECIALP(symbol) && NILP(default_only)) {
LispVal *dynenv_entry = Fplist_assoc(the_stack->dynenv, symbol, Qnil);
if (!NILP(dynenv_entry)) {
return refcount_ref(HEAD(TAIL(dynenv_entry)));
}
}
return refcount_ref(((LispSymbol *) symbol)->value);
}
DEFUN(set, "set", (LispVal * symbol, LispVal *value, LispVal *default_only),
"(symbol value &opt default-only)",
"Set the global value of SYMBOL to VALUE.") {
CHECK_TYPE(TYPE_SYMBOL, symbol);
if (VALUE_CONSTANTP(symbol)) {
Fthrow(Qconstant_value_error, Fpair(symbol, Qnil));
}
if (SPECIALP(symbol) && NILP(default_only)) {
LispVal *dynenv_entry = Fplist_assoc(the_stack->dynenv, symbol, Qnil);
if (!NILP(dynenv_entry)) {
Fsethead(TAIL(dynenv_entry), value);
return refcount_ref(value);
}
}
LispSymbol *sobj = (LispSymbol *) symbol;
refcount_unref(sobj->value);
sobj->value = refcount_ref(value);
return refcount_ref(value);
}
DEFUN(symbol_value_docstr, "symbol-value-docstr", (LispVal * symbol),
"(symbol)", "Return the documentation for SYMBOL's value.") {
CHECK_TYPE(TYPE_SYMBOL, symbol);
return refcount_ref(((LispSymbol *) symbol)->value_doc);
}
DEFUN(set_symbol_value_docstr, "set-symbol-value-docstr",
(LispVal * symbol, LispVal *docstr), "(symbol value)",
"Set the documentation for SYMBOL's value.") {
CHECK_TYPE(TYPE_SYMBOL, symbol);
if (VALUE_CONSTANTP(symbol)) {
Fthrow(Qconstant_value_error, Fpair(symbol, Qnil));
}
LispSymbol *sobj = (LispSymbol *) symbol;
refcount_unref(sobj->value_doc);
sobj->value_doc = refcount_ref(docstr);
return refcount_ref(docstr);
}
DEFUN(symbol_plist, "symbol-plist", (LispVal * symbol), "(symbol)",
"Return the plist of SYMBOL.") {
CHECK_TYPE(TYPE_SYMBOL, symbol);
@ -2434,23 +2566,14 @@ DEFUN(setplist, "setplist", (LispVal * symbol, LispVal *plist),
return Qnil;
}
DEFUN(fset, "fset", (LispVal * sym, LispVal *new_func), "(symbol func)",
"Set the value as a function of SYMBOL to FUNC.") {
CHECK_TYPE(TYPE_SYMBOL, sym);
LispSymbol *sobj = ((LispSymbol *) sym);
// TODO make sure this is not constant
refcount_ref(new_func);
refcount_unref(sobj->function);
sobj->function = new_func;
return refcount_ref(new_func);
}
DEFUN(exported_symbol_p, "exported-symbol-p", (LispVal * symbol), "(symbol)",
"Return non-nil if SYMBOL is exported by its package.") {
CHECK_TYPE(TYPE_SYMBOL, symbol);
LispSymbol *sym = (LispSymbol *) symbol;
if (NILP(sym->package)) {
return Qnil;
} else if (KEYWORDP(symbol)) {
return Qt;
}
LispPackage *pkg = (LispPackage *) sym->package;
return Fgethash(pkg->exported_sym_table, LISPVAL(sym), Qnil);
@ -2568,7 +2691,13 @@ DEFUN(quote_symbol_for_read, "quote-symbol-for-read",
LispSymbol *sym = (LispSymbol *) target;
LispString *sym_name =
(LispString *) Fquote_symbol_name(LISPVAL(sym->name));
if (NILP(include_package)) {
if (KEYWORDP(target)) {
size_t size = sym_name->length + 1;
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);
} else if (NILP(include_package)) {
return LISPVAL(sym_name);
} else if (include_package == Qkw_as_needed) {
void *cl_handler =
@ -3368,7 +3497,7 @@ LispVal *sprintf_lisp(const char *format, ...) {
va_end(args_measure);
char *buffer = lisp_malloc(size);
vsnprintf(buffer, size, format, args);
LispVal *obj = make_lisp_string(buffer, size, true, false);
LispVal *obj = make_lisp_string(buffer, size - 1, true, false);
va_end(args);
return obj;
}
@ -3398,24 +3527,34 @@ static inline int CHECK_IO_RESULT(int res, int fd) {
return res;
}
static int64_t internal_print(void *obj, int64_t fd, bool first_in_list) {
static int64_t internal_print(void *obj, int64_t fd, bool readably,
bool first_in_list) {
switch (TYPEOF(obj)) {
case TYPE_STRING: {
LispString *str = obj;
return CHECK_IO_RESULT(write(fd, str->data, str->length), fd);
if (readably) {
LispVal *quoted = Fquote_string(obj);
int64_t rval = 0;
WITH_CLEANUP(quoted, {
rval = internal_print(quoted, fd, false, true); //
});
return rval;
} else {
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, Qnil);
int64_t np;
WITH_CLEANUP(name, {
np = internal_print(name, fd, true); //
np = internal_print(name, fd, false, 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);
np += internal_print(HEAD(TAIL(obj)), fd, readably, true);
return np;
}
int64_t np;
@ -3424,11 +3563,11 @@ static int64_t internal_print(void *obj, int64_t fd, bool first_in_list) {
} else {
np = CHECK_IO_RESULT(dprintf(fd, " "), fd);
}
np += internal_print(HEAD(obj), fd, true);
np += internal_print(HEAD(obj), fd, readably, true);
if (TAIL(obj) == Qnil) {
np = CHECK_IO_RESULT(dprintf(fd, ")"), fd);
} else {
np += internal_print(TAIL(obj), fd, false);
np += internal_print(TAIL(obj), fd, readably, false);
}
return np;
}
@ -3436,7 +3575,7 @@ static int64_t internal_print(void *obj, int64_t fd, bool first_in_list) {
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 += internal_print(v->data[i], fd, readably, true);
np += CHECK_IO_RESULT(dprintf(fd, " "), fd);
}
np += CHECK_IO_RESULT(dprintf(fd, "]"), fd);
@ -3468,7 +3607,7 @@ static int64_t internal_print(void *obj, int64_t fd, bool first_in_list) {
np = CHECK_IO_RESULT(dprintf(fd, "<function "), fd);
}
if (need_name) {
np += internal_print(fn->name, fd, true);
np += internal_print(fn->name, fd, readably, true);
np += CHECK_IO_RESULT(dprintf(fd, " "), fd);
}
np += CHECK_IO_RESULT(dprintf(fd, "at %#jx>", (uintmax_t) obj), fd);
@ -3482,9 +3621,9 @@ static int64_t internal_print(void *obj, int64_t fd, bool first_in_list) {
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 += internal_print(eq_fn, fd, readably, true);
np += CHECK_IO_RESULT(dprintf(fd, " hash-fn="), fd);
np += internal_print(hash_fn, fd, true);
np += internal_print(hash_fn, fd, readably, true);
np += CHECK_IO_RESULT(dprintf(fd, " at %#jx>", (uintmax_t) obj), fd);
return np;
}
@ -3493,7 +3632,7 @@ static int64_t internal_print(void *obj, int64_t fd, bool first_in_list) {
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 += internal_print(name_str, fd, readably, true); //
});
np += CHECK_IO_RESULT(
dprintf(fd, " interned=%ju at %#jx>",
@ -3512,10 +3651,12 @@ static int64_t internal_print(void *obj, int64_t fd, bool first_in_list) {
}
}
DEFUN_DISTINGUISHED(print, "print", (LispVal * obj, LispVal *stream),
"(obj &opt stream)",
DEFUN_DISTINGUISHED(print, "print",
(LispVal * obj, LispVal *readably, LispVal *stream),
"(obj &opt readably stream)",
"Write a human readable representation of OBJ to STREAM, "
"defaulting to the standard output.") {
"defaulting to the standard output. With READABLY non-nil, "
"print OBJ in a way that it can be read back.") {
int64_t fd;
if (stream == Qunbound) {
fd = 1;
@ -3526,12 +3667,15 @@ DEFUN_DISTINGUISHED(print, "print", (LispVal * obj, LispVal *stream),
Fthrow(Qtype_error, const_list(true, 1, stream));
}
}
return make_lisp_integer(internal_print(obj, fd, false));
bool readably_bool = readably != Qunbound && !NILP(readably);
return make_lisp_integer(internal_print(obj, fd, readably_bool, true));
}
DEFUN_DISTINGUISHED(
println, "println", (LispVal * obj, LispVal *stream), "(obj &opt stream)",
"Call print with OBJ and STREAM, then write a newline to STREAM.") {
println, "println", (LispVal * obj, LispVal *readably, LispVal *stream),
"(obj &opt readably stream)",
"Call print with OBJ and STREAM, then write a newline to STREAM. With "
"READABLY non-nil, print OBJ in a way that it can be read back.") {
static char NEWLINE = '\n';
int64_t fd;
if (stream == Qunbound) {
@ -3545,7 +3689,8 @@ DEFUN_DISTINGUISHED(
}
int64_t np = 0;
if (obj != Qunbound) {
np += internal_print(obj, fd, true);
bool readably_bool = readably != Qunbound && !NILP(readably);
np += internal_print(obj, fd, readably_bool, true);
}
np += CHECK_IO_RESULT(write(fd, &NEWLINE, 1), fd);
fsync(fd);
@ -3603,11 +3748,14 @@ DEFUN(throw, "throw", (LispVal * signal, LispVal *rest), "(signal &rest rest)",
LispVal *var = HEAD(handler);
LispVal *form = TAIL(handler);
WITH_PUSH_FRAME(Qnil, Qnil, true, {
if (!NILP(var)) {
// TODO make sure this isn't constant
push_to_lexenv(&the_stack->lexenv, var, error_arg);
}
WITH_CLEANUP(error_arg, {
if (!NILP(var)) {
CHECK_TYPE(TYPE_SYMBOL, var);
if (VALUE_CONSTANTP(var)) {
Fthrow(Qconstant_value_error, Fpair(var, Qnil));
}
push_to_lexenv(&the_stack->lexenv, var, error_arg);
}
stack_return = Feval(form, the_stack->lexenv); //
});
});
@ -3656,6 +3804,7 @@ void stack_enter(LispVal *name, LispVal *detail, bool inherit) {
if (inherit && the_stack) {
frame->lexenv = refcount_ref(the_stack->lexenv);
}
frame->dynenv = the_stack ? refcount_ref(the_stack->dynenv) : Qnil;
frame->enable_handlers = true;
frame->handlers = make_lisp_hashtable(Qnil, Qnil);
frame->unwind_form = Qnil;
@ -3672,6 +3821,7 @@ void stack_leave(void) {
refcount_unref(frame->return_tag);
refcount_unref(frame->detail);
refcount_unref(frame->lexenv);
refcount_unref(frame->dynenv);
refcount_unref(frame->handlers);
while (frame->cleanup_handlers) {
frame->cleanup_handlers->fun(frame->cleanup_handlers->data);
@ -3741,9 +3891,12 @@ void cancel_cleanup(void *handle) {
// # Errors and Conditions #
// #########################
DEF_STATIC_SYMBOL(shutdown_signal, "shutdown-signal");
DEF_STATIC_SYMBOL(error, "error");
DEF_STATIC_SYMBOL(type_error, "type-error");
DEF_STATIC_SYMBOL(read_error, "read-error");
DEF_STATIC_SYMBOL(unclosed_error, "read-error");
DEF_STATIC_SYMBOL(constant_function_error, "constant-function-error");
DEF_STATIC_SYMBOL(constant_value_error, "constant-value-error");
DEF_STATIC_SYMBOL(eof_error, "eof-error");
DEF_STATIC_SYMBOL(void_variable_error, "void-variable-error");
DEF_STATIC_SYMBOL(void_function_error, "void-function-error");
@ -3917,14 +4070,17 @@ static void register_symbols_and_functions(void) {
REGISTER_SYMBOL(comma);
REGISTER_SYMBOL(comma_at);
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_KEYWORD(kw_success);
REGISTER_KEYWORD(kw_finally);
REGISTER_KEYWORD(kw_as_needed);
REGISTER_SYMBOL(shutdown_signal);
REGISTER_SYMBOL(error);
REGISTER_SYMBOL(type_error);
REGISTER_SYMBOL(read_error);
REGISTER_SYMBOL(eof_error);
REGISTER_SYMBOL(unclosed_error);
REGISTER_SYMBOL(constant_function_error);
REGISTER_SYMBOL(constant_value_error);
REGISTER_SYMBOL(void_variable_error);
REGISTER_SYMBOL(void_function_error);
REGISTER_SYMBOL(circular_error);
@ -4032,14 +4188,21 @@ static void register_symbols_and_functions(void) {
// ####################
REGISTER_FUNCTION(symbolp);
REGISTER_FUNCTION(keywordp);
REGISTER_FUNCTION(const_value_p);
REGISTER_FUNCTION(const_func_p);
REGISTER_FUNCTION(specialp);
REGISTER_FUNCTION(make_symbol);
REGISTER_FUNCTION(make_symbol_special);
REGISTER_FUNCTION(symbol_package);
REGISTER_FUNCTION(symbol_name);
REGISTER_FUNCTION(symbol_function);
REGISTER_FUNCTION(fset);
REGISTER_FUNCTION(symbol_value);
REGISTER_FUNCTION(set);
REGISTER_FUNCTION(symbol_value_docstr);
REGISTER_FUNCTION(set_symbol_value_docstr);
REGISTER_FUNCTION(symbol_plist);
REGISTER_FUNCTION(setplist);
REGISTER_FUNCTION(fset);
REGISTER_FUNCTION(exported_symbol_p);
REGISTER_FUNCTION(intern_soft);
REGISTER_FUNCTION(intern);

44
src/lisp.h
View File

@ -67,7 +67,10 @@ typedef struct {
LispVal *plist;
LispVal *function;
LispVal *value;
bool is_constant;
LispVal *value_doc;
unsigned int is_const_value : 1;
unsigned int is_const_func : 1;
unsigned int is_special_var : 1;
} LispSymbol;
typedef struct {
@ -213,7 +216,9 @@ extern LispVal *current_package;
#define TYPEOF(v) (LISPVAL(v)->type)
// only use on symbols!
#define VALUE_CONSTANTP(v) (((LispSymbol *) (v))->is_constant)
#define VALUE_CONSTANTP(v) (((LispSymbol *) (v))->is_const_value || KEYWORDP(v))
#define FUNC_CONSTANTP(v) (((LispSymbol *) (v))->is_const_func)
#define SPECIALP(v) (((LispSymbol *) (v))->is_special_var)
#define NILP(v) (((void *) (v)) == (void *) Qnil)
#define STRINGP(v) (TYPEOF(v) == TYPE_STRING)
@ -260,7 +265,10 @@ inline static bool NUMBERP(LispVal *v) {
.plist = Qnil, \
.function = Qnil, \
.value = Qunbound, \
.is_constant = false, \
.value_doc = Qnil, \
.is_const_value = false, \
.is_const_func = false, \
.is_special_var = false, \
}; \
LispVal *Q##c_name = LISPVAL(&_Q##c_name)
#define DECLARE_FUNCTION(c_name, args) \
@ -295,8 +303,11 @@ inline static bool NUMBERP(LispVal *v) {
.package = Qnil, \
.plist = Qnil, \
.value = Qunbound, \
.value_doc = Qnil, \
.function = LISPVAL(&_Q##c_name##_function), \
.is_constant = false, \
.is_const_value = false, \
.is_const_func = true, \
.is_special_var = false, \
}; \
LispVal *Q##c_name = (LispVal *) &_Q##c_name; \
static_kw LispVal *F##c_name c_args
@ -329,6 +340,11 @@ inline static bool NUMBERP(LispVal *v) {
#define REGISTER_SYMBOL_INTO(sym, pkg) \
REGISTER_SYMBOL_NOINTERN(sym) \
REGISTER_DO_INTERN(sym, pkg)
#define REGISTER_KEYWORD(sym) \
REGISTER_SYMBOL_NOINTERN(sym) \
REGISTER_DO_INTERN(sym, keyword_package) \
((LispSymbol *) Q##sym)->is_const_value = true; \
((LispSymbol *) Q##sym)->is_special_var = true;
#define REGISTER_SYMBOL(sym) REGISTER_SYMBOL_INTO(sym, system_package)
#define REGISTER_STATIC_FUNCTION(name) \
REGISTER_SYMBOL_NOINTERN(name); \
@ -506,14 +522,22 @@ LispVal *find_package(const char *name, size_t length);
// ####################
DECLARE_FUNCTION(symbolp, (LispVal * val));
DECLARE_FUNCTION(keywordp, (LispVal * val));
DECLARE_FUNCTION(const_value_p, (LispVal * val));
DECLARE_FUNCTION(const_func_p, (LispVal * val));
DECLARE_FUNCTION(specialp, (LispVal * val));
DECLARE_FUNCTION(make_symbol, (LispVal * name));
DECLARE_FUNCTION(make_symbol_special, (LispVal * sym));
DECLARE_FUNCTION(symbol_package, (LispVal * symbol));
DECLARE_FUNCTION(symbol_name, (LispVal * symbol));
DECLARE_FUNCTION(symbol_function, (LispVal * symbol, LispVal *resolve));
DECLARE_FUNCTION(symbol_value, (LispVal * symbol));
DECLARE_FUNCTION(fset, (LispVal * sym, LispVal *new_func));
DECLARE_FUNCTION(symbol_value, (LispVal * symbol, LispVal *default_only));
DECLARE_FUNCTION(set,
(LispVal * symbol, LispVal *value, LispVal *default_only));
DECLARE_FUNCTION(symbol_value_docstr, (LispVal * symbol));
DECLARE_FUNCTION(set_symbol_value_docstr, (LispVal * symbol, LispVal *docstr));
DECLARE_FUNCTION(symbol_plist, (LispVal * symbol));
DECLARE_FUNCTION(setplist, (LispVal * symbol, LispVal *plist));
DECLARE_FUNCTION(fset, (LispVal * sym, LispVal *new_func));
DECLARE_FUNCTION(exported_symbol_p, (LispVal * symbol));
DECLARE_FUNCTION(intern_soft, (LispVal * name, LispVal *def, LispVal *package,
LispVal *included_too));
@ -589,8 +613,8 @@ 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));
DECLARE_FUNCTION(print, (LispVal * obj, LispVal *readably, LispVal *stream));
DECLARE_FUNCTION(println, (LispVal * obj, LispVal *readably, LispVal *stream));
// ########################
// # Lexenv and the Stack #
@ -615,6 +639,7 @@ typedef struct StackFrame {
LispVal *return_tag;
LispVal *detail; // function arguments
LispVal *lexenv; // symbol -> value
LispVal *dynenv; // symbol -> value (for dynamic variables)
bool enable_handlers;
LispVal *handlers; // symbol -> (error-var form)
LispVal *unwind_form;
@ -693,10 +718,13 @@ void cancel_cleanup(void *handle);
// # Errors and Conditions #
// #########################
extern LispVal *Qshutdown_signal;
extern LispVal *Qerror;
extern LispVal *Qtype_error;
extern LispVal *Qread_error;
extern LispVal *Qeof_error;
extern LispVal *Qunclosed_error;
extern LispVal *Qconstant_function_error;
extern LispVal *Qconstant_value_error;
extern LispVal *Qvoid_variable_error;
extern LispVal *Qvoid_function_error;
extern LispVal *Qcircular_error;

9
src/main.c
View File

@ -23,14 +23,19 @@ STATIC_DEFUN(toplevel_error_handler, "toplevel-error-handler",
LispVal *backtrace = HEAD(TAIL(except));
fprintf(stderr, "Caught signal of type ");
debug_dump(stderr, type, true);
LispVal *stream = make_lisp_integer(fileno(stderr));
if (!NILP(detail)) {
fprintf(stderr, "Details: ");
debug_dump(stderr, detail, true);
Fprintln(detail, Qt, stream);
}
fprintf(stderr, "\nBacktrace (toplevel comes last):\n");
FOREACH(frame, backtrace) {
fprintf(stderr, " ");
debug_dump(stderr, frame, true);
Fprint(frame, Qt, stream);
if (SYMBOLP(HEAD(frame)) && !NILP(Fmacrop(HEAD(frame), Qnil))) {
fprintf(stderr, " ;; macro");
}
fputc('\n', stderr);
}
exit_status = 1;
return Qnil;