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) FetchContent_MakeAvailable(refcount)
add_compile_options(-fsanitize=address,leak,undefined) # add_compile_options(-fsanitize=address,leak,undefined)
add_link_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) add_executable(simple-lisp src/main.c src/lisp.c src/read.c)
target_link_libraries(simple-lisp PUBLIC refcount) target_link_libraries(simple-lisp PUBLIC refcount)

140
src/kernel.sl
View File

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

289
src/lisp.c
View File

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

44
src/lisp.h
View File

@ -67,7 +67,10 @@ typedef struct {
LispVal *plist; LispVal *plist;
LispVal *function; LispVal *function;
LispVal *value; 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; } LispSymbol;
typedef struct { typedef struct {
@ -213,7 +216,9 @@ extern LispVal *current_package;
#define TYPEOF(v) (LISPVAL(v)->type) #define TYPEOF(v) (LISPVAL(v)->type)
// only use on symbols! // 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 NILP(v) (((void *) (v)) == (void *) Qnil)
#define STRINGP(v) (TYPEOF(v) == TYPE_STRING) #define STRINGP(v) (TYPEOF(v) == TYPE_STRING)
@ -260,7 +265,10 @@ inline static bool NUMBERP(LispVal *v) {
.plist = Qnil, \ .plist = Qnil, \
.function = Qnil, \ .function = Qnil, \
.value = Qunbound, \ .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) LispVal *Q##c_name = LISPVAL(&_Q##c_name)
#define DECLARE_FUNCTION(c_name, args) \ #define DECLARE_FUNCTION(c_name, args) \
@ -295,8 +303,11 @@ inline static bool NUMBERP(LispVal *v) {
.package = Qnil, \ .package = Qnil, \
.plist = Qnil, \ .plist = Qnil, \
.value = Qunbound, \ .value = Qunbound, \
.value_doc = Qnil, \
.function = LISPVAL(&_Q##c_name##_function), \ .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; \ LispVal *Q##c_name = (LispVal *) &_Q##c_name; \
static_kw LispVal *F##c_name c_args static_kw LispVal *F##c_name c_args
@ -329,6 +340,11 @@ inline static bool NUMBERP(LispVal *v) {
#define REGISTER_SYMBOL_INTO(sym, pkg) \ #define REGISTER_SYMBOL_INTO(sym, pkg) \
REGISTER_SYMBOL_NOINTERN(sym) \ REGISTER_SYMBOL_NOINTERN(sym) \
REGISTER_DO_INTERN(sym, pkg) 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_SYMBOL(sym) REGISTER_SYMBOL_INTO(sym, system_package)
#define REGISTER_STATIC_FUNCTION(name) \ #define REGISTER_STATIC_FUNCTION(name) \
REGISTER_SYMBOL_NOINTERN(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(symbolp, (LispVal * val));
DECLARE_FUNCTION(keywordp, (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, (LispVal * name));
DECLARE_FUNCTION(make_symbol_special, (LispVal * sym));
DECLARE_FUNCTION(symbol_package, (LispVal * symbol)); DECLARE_FUNCTION(symbol_package, (LispVal * symbol));
DECLARE_FUNCTION(symbol_name, (LispVal * symbol)); DECLARE_FUNCTION(symbol_name, (LispVal * symbol));
DECLARE_FUNCTION(symbol_function, (LispVal * symbol, LispVal *resolve)); 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(symbol_plist, (LispVal * symbol));
DECLARE_FUNCTION(setplist, (LispVal * symbol, LispVal *plist)); DECLARE_FUNCTION(setplist, (LispVal * symbol, LispVal *plist));
DECLARE_FUNCTION(fset, (LispVal * sym, LispVal *new_func));
DECLARE_FUNCTION(exported_symbol_p, (LispVal * symbol)); DECLARE_FUNCTION(exported_symbol_p, (LispVal * symbol));
DECLARE_FUNCTION(intern_soft, (LispVal * name, LispVal *def, LispVal *package, DECLARE_FUNCTION(intern_soft, (LispVal * name, LispVal *def, LispVal *package,
LispVal *included_too)); LispVal *included_too));
@ -589,8 +613,8 @@ bool strings_equal_nocase(const char *s1, const char *s2, size_t n);
// ################ // ################
// # IO Functions # // # IO Functions #
// ################ // ################
DECLARE_FUNCTION(print, (LispVal * obj, LispVal *stream)); DECLARE_FUNCTION(print, (LispVal * obj, LispVal *readably, LispVal *stream));
DECLARE_FUNCTION(println, (LispVal * obj, LispVal *stream)); DECLARE_FUNCTION(println, (LispVal * obj, LispVal *readably, LispVal *stream));
// ######################## // ########################
// # Lexenv and the Stack # // # Lexenv and the Stack #
@ -615,6 +639,7 @@ typedef struct StackFrame {
LispVal *return_tag; LispVal *return_tag;
LispVal *detail; // function arguments LispVal *detail; // function arguments
LispVal *lexenv; // symbol -> value LispVal *lexenv; // symbol -> value
LispVal *dynenv; // symbol -> value (for dynamic variables)
bool enable_handlers; bool enable_handlers;
LispVal *handlers; // symbol -> (error-var form) LispVal *handlers; // symbol -> (error-var form)
LispVal *unwind_form; LispVal *unwind_form;
@ -693,10 +718,13 @@ void cancel_cleanup(void *handle);
// # Errors and Conditions # // # Errors and Conditions #
// ######################### // #########################
extern LispVal *Qshutdown_signal; extern LispVal *Qshutdown_signal;
extern LispVal *Qerror;
extern LispVal *Qtype_error; extern LispVal *Qtype_error;
extern LispVal *Qread_error; extern LispVal *Qread_error;
extern LispVal *Qeof_error; extern LispVal *Qeof_error;
extern LispVal *Qunclosed_error; extern LispVal *Qunclosed_error;
extern LispVal *Qconstant_function_error;
extern LispVal *Qconstant_value_error;
extern LispVal *Qvoid_variable_error; extern LispVal *Qvoid_variable_error;
extern LispVal *Qvoid_function_error; extern LispVal *Qvoid_function_error;
extern LispVal *Qcircular_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)); LispVal *backtrace = HEAD(TAIL(except));
fprintf(stderr, "Caught signal of type "); fprintf(stderr, "Caught signal of type ");
debug_dump(stderr, type, true); debug_dump(stderr, type, true);
LispVal *stream = make_lisp_integer(fileno(stderr));
if (!NILP(detail)) { if (!NILP(detail)) {
fprintf(stderr, "Details: "); fprintf(stderr, "Details: ");
debug_dump(stderr, detail, true); Fprintln(detail, Qt, stream);
} }
fprintf(stderr, "\nBacktrace (toplevel comes last):\n"); fprintf(stderr, "\nBacktrace (toplevel comes last):\n");
FOREACH(frame, backtrace) { FOREACH(frame, backtrace) {
fprintf(stderr, " "); 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; exit_status = 1;
return Qnil; return Qnil;