From 6f927bf76837645caed7fc674b9a34450dbc11b5 Mon Sep 17 00:00:00 2001 From: Alexander Rosenberg Date: Tue, 28 Oct 2025 03:02:39 -0700 Subject: [PATCH] A bunch of changes --- CMakeLists.txt | 4 +- src/kernel.sl | 152 ++++++++++++++++--------- src/lisp.c | 297 ++++++++++++++++++++++++++++++++++++++----------- src/lisp.h | 44 ++++++-- src/main.c | 9 +- 5 files changed, 377 insertions(+), 129 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index d10efaf..01d2dcf 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -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) diff --git a/src/kernel.sl b/src/kernel.sl index 0319fd7..2690c5d 100644 --- a/src/kernel.sl +++ b/src/kernel.sl @@ -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") diff --git a/src/lisp.c b/src/lisp.c index 9d27d22..3de88c2 100644 --- a/src/lisp.c +++ b/src/lisp.c @@ -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, "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, "", (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, "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); diff --git a/src/lisp.h b/src/lisp.h index c708be1..24dc1bc 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -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; diff --git a/src/main.c b/src/main.c index 7cd8787..0660d19 100644 --- a/src/main.c +++ b/src/main.c @@ -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;