diff --git a/src/kernel.sl b/src/kernel.sl index 4989cee..0319fd7 100644 --- a/src/kernel.sl +++ b/src/kernel.sl @@ -444,6 +444,3 @@ (t (print obj))) (when newline (println))) - -(breakpoint) -' diff --git a/src/lisp.c b/src/lisp.c index b200feb..9d27d22 100644 --- a/src/lisp.c +++ b/src/lisp.c @@ -468,18 +468,23 @@ void lisp_shutdown(void) { // ############################### // # General and Misc. Functions # // ############################### -DEFUN(exit, "exit", (LispVal * code)) { +DEFUN(exit, "exit", (LispVal * code), "(&opt code)", + "Exit with CODE, defaulting to zero.") { if (!NILP(code) && !INTEGERP(code)) { Fthrow(Qtype_error, Qnil); } Fthrow(Qshutdown_signal, const_list(true, 1, code)); } -DEFUN(id, "id", (LispVal * obj)) { +DEFUN(id, "id", (LispVal * obj), "(obj)", + "Return a number identifying OBJ uniquely among all currently live " + "objects.") { return make_lisp_integer((int64_t) obj); } -DEFUN(eq, "eq", (LispVal * obj1, LispVal *obj2)) { +DEFUN(eq, "eq", (LispVal * obj1, LispVal *obj2), "(obj1 obj2)", + "Return non-nil if OBJ1 and OBJ2 are the same object. Objects which are " + "eq also have the same id.") { return LISP_BOOL(obj1 == obj2); } @@ -492,7 +497,8 @@ static bool pairs_equal_internal(LispVal *obj1, LispVal *obj2) { return !PAIRP(obj1) && !NILP(Fequal(obj1, obj2)); } -DEFUN(equal, "equal", (LispVal * obj1, LispVal *obj2)) { +DEFUN(equal, "equal", (LispVal * obj1, LispVal *obj2), "(obj1 obj2)", + "Return non-nil if OBJ1 and OBJ2 are structurally equal.") { if (obj1 == obj2) { return Qt; } else if (TYPEOF(obj1) != TYPEOF(obj2)) { @@ -538,7 +544,7 @@ DEFUN(equal, "equal", (LispVal * obj1, LispVal *obj2)) { } static void breakpoint(int64_t id) {} -DEFUN(breakpoint, "breakpoint", (LispVal * id)) { +DEFUN(breakpoint, "breakpoint", (LispVal * id), "(&opt id)", "Do nothing.") { if (NILP(id)) { breakpoint(0); } else { @@ -548,11 +554,15 @@ DEFUN(breakpoint, "breakpoint", (LispVal * id)) { return Qnil; } -DEFUN(not, "not", (LispVal * obj)) { +DEFUN(not, "not", (LispVal * obj), "(obj)", + "Return t if OBJ is nil, otherwise, return nil.") { return NILP(obj) ? Qt : Qnil; } -DEFUN(type_of, "type-of", (LispVal * obj)) { +DEFUN( + type_of, "type-of", (LispVal * obj), "(obj)", + "Return a symbol that describes the type of OBJ. This is for informational " + "purpoese only, don't use this to test for objects of a specific type.") { if (obj->type < 0 || obj->type >= N_LISP_TYPES) { return Qnil; } @@ -564,7 +574,8 @@ DEFUN(type_of, "type-of", (LispVal * obj)) { return sym; } -DEFUN(user_pointer_p, "user-pointer-p", (LispVal * val)) { +DEFUN(user_pointer_p, "user-pointer-p", (LispVal * val), "(obj)", + "Return non-nil if OBJ is a user pointer.") { return LISP_BOOL(USER_POINTER_P(val)); } @@ -579,11 +590,11 @@ static inline LispVal *eval_function_args(LispVal *args, LispVal *lexenv) { LispVal *end = Qnil; FOREACH(elt, args) { if (NILP(final_args)) { - final_args = Fpair(Feval_in_env(elt, lexenv), Qnil); + final_args = Fpair(Feval(elt, lexenv), Qnil); refcount_unref(HEAD(final_args)); end = final_args; } else { - LispVal *new_end = Fpair(Feval_in_env(elt, lexenv), Qnil); + LispVal *new_end = Fpair(Feval(elt, lexenv), Qnil); refcount_unref(HEAD(new_end)); Fsettail(end, new_end); refcount_unref(new_end); @@ -803,7 +814,7 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args, USERPTR(struct OptArgDesc, HASH_VALUE(func->kwargs, i)); // 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); + LispVal *eval_res = Feval(oad->default_form, the_stack->lexenv); push_to_lexenv(lexenv, oad->name, eval_res); refcount_unref(eval_res); if (!NILP(oad->pred_var)) { @@ -813,7 +824,7 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args, } FOREACH(arg, oargs) { struct OptArgDesc *oad = USERPTR(struct OptArgDesc, arg); - LispVal *default_val = Feval(oad->default_form); + LispVal *default_val = Feval(oad->default_form, the_stack->lexenv); push_to_lexenv(lexenv, oad->name, default_val); refcount_unref(default_val); if (!NILP(oad->pred_var)) { @@ -851,7 +862,7 @@ static LispVal *call_lisp_function(LispVal *name, LispFunction *func, the_stack->enable_handlers = false; WITH_CLEANUP(expansion, { // eval in the outer lexenv - retval = Feval_in_env(expansion, args_lexenv); + retval = Feval(expansion, args_lexenv); }); the_stack->enable_handlers = true; // just in case return retval; @@ -860,8 +871,8 @@ static LispVal *call_lisp_function(LispVal *name, LispFunction *func, } } -STATIC_DEFUN(set_for_return, "set-for-return", - (LispVal * entry, LispVal *dest)) { +STATIC_DEFUN(set_for_return, "set-for-return", (LispVal * entry, LispVal *dest), + "(entry dest)", "Internal function.") { LispVal *retval = HEAD(TAIL(HEAD(entry))); Fsethead(dest, retval); return Qnil; @@ -886,7 +897,7 @@ static LispVal *call_function(LispVal *func, LispVal *args, } else if (SYMBOLP(func)) { fobj = (LispFunction *) Fsymbol_function(func, Qt); } else if (PAIRP(func) && HEAD(func) == Qlambda) { - fobj = (LispFunction *) Feval_in_env(func, args_lexenv); + fobj = (LispFunction *) Feval(func, args_lexenv); assert(FUNCTIONP(fobj)); } else { Fthrow(Qinvalid_function_error, Fpair(func, Qnil)); @@ -952,7 +963,8 @@ static LispVal *symbol_value_in_lexenv(LispVal *lexenv, LispVal *key) { Fthrow(Qvoid_variable_error, const_list(true, 1, key)); } -DEFUN(eval_in_env, "eval-in-env", (LispVal * form, LispVal *lexenv)) { +DEFUN(eval, "eval", (LispVal * form, LispVal *lexenv), "(eval &opt lexenv)", + "Evaluate FORM in the lexical environment LEXENV.") { switch (TYPEOF(form)) { case TYPE_STRING: case TYPE_FUNCTION: @@ -980,7 +992,7 @@ DEFUN(eval_in_env, "eval-in-env", (LispVal * form, LispVal *lexenv)) { void *cl_handler = register_cleanup(&unref_free_list_double_ptr, &uld); for (size_t i = 0; i < vec->length; ++i) { - elts[i] = Feval_in_env(vec->data[i], lexenv); + elts[i] = Feval(vec->data[i], lexenv); } cancel_cleanup(cl_handler); }); @@ -996,15 +1008,15 @@ DEFUN(eval_in_env, "eval-in-env", (LispVal * form, LispVal *lexenv)) { } } -DEFUN(eval, "eval", (LispVal * form)) { - return Feval_in_env(form, LISPVAL(the_stack->lexenv)); -} - -DEFUN(funcall, "funcall", (LispVal * function, LispVal *rest)) { +DEFUN(funcall, "funcall", (LispVal * function, LispVal *rest), + "(function &rest args)", "Call FUNCTION with ARGS as its arguments.") { return call_function(function, rest, Qnil, false, false); } -DEFUN(apply, "apply", (LispVal * function, LispVal *rest)) { +DEFUN(apply, "apply", (LispVal * function, LispVal *rest), + "(function &rest args)", + "Call FUNCTION with ARGS as its arguments. If the last element of ARGS " + "is a list, use its elements as arguments as well.") { LispVal *args = Qnil; LispVal *end = Qnil; while (!NILP(rest) && !NILP(((LispPair *) rest)->tail)) { @@ -1065,8 +1077,11 @@ static inline LispVal *expand_function_as_macro(LispFunction *fobj, return Ffuncall((LispVal *) fobj, args); } -DEFUN(macroexpand_1, "macroexpand-1", - (LispVal * form, LispVal *lexical_macros)) { +DEFUN(macroexpand_1, "macroexpand-1", (LispVal * form, LispVal *lexical_macros), + "(form &opt lexical-macros)", + "Expand the toplevel macro one time in FORM. LEXICAL-MACROS is a plist " + "of symbols and functions that are considered to be addition macros to " + "expand. LEXICAL-MACROS take priority over global macros.") { if (PAIRP(form)) { LispVal *lex_res = lookup_lexical_macro(HEAD(form), lexical_macros); LispFunction *fobj = (LispFunction *) Qunbound; @@ -1076,7 +1091,7 @@ DEFUN(macroexpand_1, "macroexpand-1", } else if (FUNCTIONP(HEAD(form))) { fobj = refcount_ref(HEAD(form)); } else if (PAIRP(HEAD(form)) && HEAD(HEAD(form)) == Qlambda) { - fobj = (LispFunction *) Feval(HEAD(form)); + fobj = (LispFunction *) Feval(HEAD(form), the_stack->lexenv); assert(FUNCTIONP(fobj)); } else { fobj = (LispFunction *) Fsymbol_function(HEAD(form), Qt); @@ -1115,7 +1130,9 @@ DEFUN(macroexpand_1, "macroexpand-1", } DEFUN(macroexpand_toplevel, "macroexpand-toplevel", - (LispVal * form, LispVal *lexical_macros)) { + (LispVal * form, LispVal *lexical_macros), "(form &opt lexical-macros)", + "Expand the toplevel of FORM until it is no longer a macro. " + "LEXICAL-MACROS is the same as for macroexpand-1.") { if (PAIRP(form)) { LispVal *out = refcount_ref(form); void *cl_handler = register_cleanup(&unref_double_ptr, &out); @@ -1162,15 +1179,17 @@ static void expand_lambda_list(LispVal *list, } STATIC_DEFMACRO(internal_real_return, "internal-real-return", - (LispVal * name, LispVal *tag, LispVal *value)) { + (LispVal * name, LispVal *tag, LispVal *value), + "(name tag value)", " Internal function.") { for (StackFrame *cur = the_stack; cur; cur = cur->next) { if (!NILP(cur->return_tag) && cur->enable_handlers && cur->return_tag == tag) { - Fthrow(cur->return_tag, const_list(false, 1, Feval(value))); + Fthrow(cur->return_tag, + const_list(false, 1, Feval(value, the_stack->lexenv))); } } - Fthrow(Qreturn_frame_error, - const_list(false, 2, refcount_ref(name), Feval(value))); + Fthrow(Qreturn_frame_error, const_list(false, 2, refcount_ref(name), + Feval(value, the_stack->lexenv))); } static void expand_builtin_macro(LispFunction *fobj, LispVal *args, @@ -1312,7 +1331,9 @@ static LispVal *macroexpand_toplevel_as_callback(LispVal *form, } DEFUN(macroexpand_all, "macroexpand-all", - (LispVal * form, LispVal *lexical_macros)) { + (LispVal * form, LispVal *lexical_macros), "(form &opt lexical-macros)", + "Expand all macros in the toplevel and arguments of FORM. LEXICAL-MACROS " + "is as it is for macroexpand-1.") { return filter_body_form(form, macroexpand_toplevel_as_callback, lexical_macros); } @@ -1320,16 +1341,19 @@ DEFUN(macroexpand_all, "macroexpand-all", // ################# // # Special Forms # // ################# -DEFMACRO(quote, "'", (LispVal * form)) { +DEFMACRO(quote, "'", (LispVal * form), "(form)", "Return FORM.") { return refcount_ref(form); } -DEFMACRO(if, "if", (LispVal * cond, LispVal *t, LispVal *nil)) { - LispVal *res = Feval(cond); +DEFMACRO(if, "if", (LispVal * cond, LispVal *t, LispVal *nil), + "(cond then &rest else)", + "If COND evaluates to a non-nil value, evaluate THEN, otherwise, " + "evaluate each form in ELSE.") { + LispVal *res = Feval(cond, the_stack->lexenv); LispVal *retval = Qnil; WITH_PUSH_FRAME(Qnil, Qnil, true, { if (!NILP(res)) { - retval = Feval(t); + retval = Feval(t, the_stack->lexenv); } else { retval = Fprogn(nil); } @@ -1349,7 +1373,11 @@ static void set_symbol_in_lexenv(LispVal *key, LispVal *newval, } } -DEFMACRO(setq, "setq", (LispVal * args)) { +DEFMACRO( + setq, "setq", (LispVal * args), "(&rest args)", + "ARGS is a plist of symbols and values. Set each of the symbols to their " + "respective value. Return the last value. Each symbol is set lexically if " + "a lexical binding exists. Otherwise the symbol's value is altered.") { size_t len = list_length(args); if (!len || len % 2) { Fthrow(Qargument_error, Fpair(Qsetq, Qnil)); @@ -1359,22 +1387,36 @@ DEFMACRO(setq, "setq", (LispVal * args)) { CHECK_TYPE(TYPE_SYMBOL, HEAD(tail)); LispVal *name = HEAD(tail); tail = TAIL(tail); - retval = Feval(HEAD(tail)); + retval = Feval(HEAD(tail), the_stack->lexenv); set_symbol_in_lexenv(name, retval, the_stack->lexenv); } return retval; } -DEFMACRO(progn, "progn", (LispVal * forms)) { +DEFMACRO(progn, "progn", (LispVal * forms), "(&rest forms)", + "Evaluate each of FORMS.") { LispVal *retval = Qnil; FOREACH(form, forms) { refcount_unref(retval); - retval = Feval(form); + retval = Feval(form, the_stack->lexenv); } return retval; } -DEFMACRO(condition_case, "condition-case", (LispVal * form, LispVal *rest)) { +DEFMACRO( + condition_case, "condition-case", (LispVal * form, LispVal *rest), + "(form &rest handlers)", + "Evaluate FORM. If an exception is thrown, evaluate the corresponding " + "handler.\n" + "Each handler is HANDLERS is a list with the head being a list of a " + "variable followed by a symbol or a list of symbols and the tail " + "being any number of forms. Each symbol is an error to catch. During " + "the executing of the following forms, the variable will be bound to " + "information about the exception.\n" + "Optionally, the symbols :success or :finally can be used in place of an " + "error or list of errors. :finally forms will be weather or not an error " + "is caught after FORM is done being evaluated. :success forms will be run " + "if the evaluation of FORM finished with no errors.") { bool success = false; LispVal *success_form = Qunbound; LispVal *finally_form = Qunbound; @@ -1420,7 +1462,7 @@ DEFMACRO(condition_case, "condition-case", (LispVal * form, LispVal *rest)) { if (finally_form != Qunbound) { the_stack->unwind_form = finally_form; } - retval = Feval(form); + retval = Feval(form, the_stack->lexenv); cancel_cleanup(cl_handler); success = true; }, @@ -1430,7 +1472,7 @@ DEFMACRO(condition_case, "condition-case", (LispVal * form, LispVal *rest)) { void *cl_handler = register_cleanup(&refcount_unref_as_callback, retval); WITH_CLEANUP(success_form, { - refcount_unref(Feval(success_form)); // + refcount_unref(Feval(success_form, the_stack->lexenv)); // }); cancel_cleanup(cl_handler); } @@ -1503,7 +1545,8 @@ static inline void expand_lambda_list_for_toplevel(LispVal *list) { expand_lambda_list(list, macroexpand_all_as_callback, NULL); } -DEFMACRO(lambda, "lambda", (LispVal * args, LispVal *body)) { +DEFMACRO(lambda, "lambda", (LispVal * args, LispVal *body), "(args &rest body)", + "Return a new function.") { LispVal *doc = Qnil; if (STRINGP(HEAD(body))) { doc = HEAD(body); @@ -1542,21 +1585,27 @@ DEFMACRO(lambda, "lambda", (LispVal * args, LispVal *body)) { return func; } -DEFMACRO(while, "while", (LispVal * cond, LispVal *body)) { +DEFMACRO(while, "while", (LispVal * cond, LispVal *body), "(cond &rest body)", + "Evaluate COND, if its result is non-nil evaluate BODY. Repeat this " + "until COND returns nil. Then return nil.") { LispVal *evaled_cond; - while (!NILP(evaled_cond = Feval(cond))) { + while (!NILP(evaled_cond = Feval(cond, the_stack->lexenv))) { refcount_unref(evaled_cond); refcount_unref(Fprogn(body)); } return Qnil; } -DEFMACRO(and, "and", (LispVal * rest)) { +DEFMACRO(and, "and", (LispVal * rest), "(&rest rest)", + "Evaluate the first argument in REST. If its result is non-nil " + "evaluate the next argument. Otherwise, return nil. Repeat this until " + "one argument returns nil or there are no arguments left. If no " + "argument returned nil, return the result of the last argument.") { LispVal *retval = Qnil; FOREACH(cond, rest) { LispVal *nc; WITH_CLEANUP(retval, { - nc = Feval(cond); // + nc = Feval(cond, the_stack->lexenv); // }); if (NILP(nc)) { return Qnil; @@ -1566,9 +1615,12 @@ DEFMACRO(and, "and", (LispVal * rest)) { return retval; } -DEFMACRO(or, "or", (LispVal * rest)) { +DEFMACRO(or, "or", (LispVal * rest), "(&rest rest)", + "Evaluate the first argument in REST. If it returns non-nil, return " + "its value. Oterwise, evaluate the next argument. Repeat this until " + "there are no more arguments at which time nil is returned.") { FOREACH(cond, rest) { - LispVal *nc = Feval(cond); + LispVal *nc = Feval(cond, the_stack->lexenv); if (!NILP(nc)) { return nc; } @@ -1576,19 +1628,23 @@ DEFMACRO(or, "or", (LispVal * rest)) { return Qnil; } -DEFMACRO(in_package, "in-package", (LispVal * package)) { +DEFMACRO(in_package, "in-package", (LispVal * package), "(package)", + "Set the current package to PACKAGE.") { return Fset_current_package(package); } -DEFMACRO(return_from, "return-from", (LispVal * name, LispVal *value)) { - Fthrow(Qreturn_frame_error, - const_list(false, 2, refcount_ref(name), Feval(value))); +DEFMACRO(return_from, "return-from", (LispVal * name, LispVal *value), + "(name &opt value)", "Return VALUE from the function named NAME.") { + Fthrow(Qreturn_frame_error, const_list(false, 2, refcount_ref(name), + Feval(value, the_stack->lexenv))); } // ###################### // # Function Functions # // ###################### -DEFUN(functionp, "functionp", (LispVal * val)) { +DEFUN(functionp, "functionp", (LispVal * val), "(obj)", + "Return non-nil if OBJ is a non-macro function object or a symbol whose " + "value as a function resolves to a non-macro function object.") { if (FUNCTIONP(val) && !((LispFunction *) val)->is_macro) { return Qt; } else if (SYMBOLP(val)) { @@ -1601,7 +1657,11 @@ DEFUN(functionp, "functionp", (LispVal * val)) { return Qnil; } -DEFUN(macrop, "macrop", (LispVal * val, LispVal *lexical_macros)) { +DEFUN(macrop, "macrop", (LispVal * val, LispVal *lexical_macros), + "(obj &opt lexical-macros)", + "Return non-nil if OBJ is a macro object, a symbol whose value as a " + "function resolves to a macro object, or a symbol with a definition in " + "LEXICAL-MACROS.") { if (FUNCTIONP(val) && !((LispFunction *) val)->is_builtin && ((LispFunction *) val)->is_macro) { return Qt; @@ -1619,7 +1679,9 @@ DEFUN(macrop, "macrop", (LispVal * val, LispVal *lexical_macros)) { return Qnil; } -DEFUN(builtinp, "builtinp", (LispVal * val)) { +DEFUN(builtinp, "builtinp", (LispVal * val), "(obj)", + "Return non-nil if OBJ is a built-in function or a symbol whose value as " + "a function resolves to a built-in function.") { if (FUNCTIONP(val) && ((LispFunction *) val)->is_builtin && !((LispFunction *) val)->is_macro) { return Qt; @@ -1634,7 +1696,9 @@ DEFUN(builtinp, "builtinp", (LispVal * val)) { return Qnil; } -DEFUN(special_form_p, "special-form-p", (LispVal * val)) { +DEFUN(special_form_p, "special-form-p", (LispVal * val), "(obj)", + "Return non-nil if OBJ is a special-function (built-in macro) or a " + "symbol whose value as a function resolves to such a function.") { if (FUNCTIONP(val) && ((LispFunction *) val)->is_builtin && ((LispFunction *) val)->is_macro) { return Qt; @@ -1649,12 +1713,17 @@ DEFUN(special_form_p, "special-form-p", (LispVal * val)) { return Qnil; } -DEFUN(function_docstr, "function-docstr", (LispVal * func)) { +DEFUN(function_docstr, "function-docstr", (LispVal * func), "(func)", + "Return the documentation string for FUNC, or nil if it has no " + "documentation string.") { if (FUNCTIONP(func)) { return ((LispFunction *) func)->doc; } LispFunction *fobj = (LispFunction *) Fsymbol_function(func, Qt); - CHECK_TYPE(TYPE_FUNCTION, fobj); + if (!FUNCTIONP(fobj)) { + refcount_unref(fobj); + CHECK_TYPE(TYPE_FUNCTION, fobj); + } LispVal *retval = refcount_ref(fobj->doc); refcount_unref(fobj); return retval; @@ -1831,34 +1900,41 @@ malformed: // ########################### // # Pair and List Functions # // ########################### -DEFUN(pairp, "pairp", (LispVal * val)) { +DEFUN(pairp, "pairp", (LispVal * val), "(obj)", + "Return non-nil if OBJ is a pair.") { return LISP_BOOL(PAIRP(val)); } -DEFUN(atom, "atom", (LispVal * val)) { +DEFUN(atom, "atom", (LispVal * val), "(obj)", + "Return non-nil if OBJ is not a pair. Nil is not a pair.") { return LISP_BOOL(ATOM(val)); } -DEFUN(pair, "pair", (LispVal * head, LispVal *tail)) { +DEFUN(pair, "pair", (LispVal * head, LispVal *tail), "(head tail)", + "Construct a new pair from HEAD and TAIL.") { return make_lisp_pair(head, tail); } -DEFUN(head, "head", (LispVal * list)) { +DEFUN(head, "head", (LispVal * list), "(list)", + "Return the first element in LIST.") { return refcount_ref(HEAD(list)); } -DEFUN(tail, "tail", (LispVal * list)) { +DEFUN(tail, "tail", (LispVal * list), "(list)", + "Return everything but the first element in LIST.") { return refcount_ref(TAIL(list)); } -DEFUN(sethead, "sethead", (LispVal * pair, LispVal *head)) { +DEFUN(sethead, "sethead", (LispVal * pair, LispVal *head), "(pair head)", + "Set the head of PAIR to HEAD.") { CHECK_TYPE(TYPE_PAIR, pair); refcount_unref(((LispPair *) pair)->head); ((LispPair *) pair)->head = refcount_ref(head); return Qnil; } -DEFUN(settail, "settail", (LispVal * pair, LispVal *tail)) { +DEFUN(settail, "settail", (LispVal * pair, LispVal *tail), "(pair tail)", + "Set the tail of PAIR to TAIL.") { CHECK_TYPE(TYPE_PAIR, pair); refcount_unref(((LispPair *) pair)->tail); ((LispPair *) pair)->tail = refcount_ref(tail); @@ -1866,15 +1942,18 @@ DEFUN(settail, "settail", (LispVal * pair, LispVal *tail)) { } // lists -DEFUN(listp, "listp", (LispVal * val)) { +DEFUN(listp, "listp", (LispVal * val), "(obj)", + "Return non-nil if OBJ is a pair or nil.") { return LISP_BOOL(LISTP(val)); } -DEFUN(list_length, "list-length", (LispVal * list)) { +DEFUN(list_length, "list-length", (LispVal * list), "(list)", + "Return the length of LIST. Throw an error if LIST is circular.") { return make_lisp_integer(list_length(list)); } -DEFUN(copy_list, "copy-list", (LispVal * list)) { +DEFUN(copy_list, "copy-list", (LispVal * list), "(list)", + "Return a shallow copy of LIST.") { if (NILP(list)) { return Qnil; } @@ -1899,7 +1978,8 @@ DEFUN(copy_list, "copy-list", (LispVal * list)) { return copy; } -DEFUN(copy_tree, "copy-tree", (LispVal * tree)) { +DEFUN(copy_tree, "copy-tree", (LispVal * tree), "(tree)", + "Return a copy of TREE and each sub-tree of TREE.") { if (NILP(tree)) { return Qnil; } @@ -1991,7 +2071,10 @@ static bool call_eq_pred(LispVal *pred, LispVal *v1, LispVal *v2) { } DEFUN(plist_get, "plist-get", - (LispVal * plist, LispVal *key, LispVal *def, LispVal *pred)) { + (LispVal * plist, LispVal *key, LispVal *def, LispVal *pred), + "(plist key &opt def pred)", + "Find and return the value associated with KEY in PLIST. If it is not " + "found, return DEF. Keys are compared with PRED.") { for (LispVal *cur = plist; !NILP(cur); cur = TAIL(TAIL(cur))) { if (call_eq_pred(pred, key, HEAD(cur))) { if (NILP(TAIL(cur))) { @@ -2004,7 +2087,10 @@ DEFUN(plist_get, "plist-get", } DEFUN(plist_set, "plist-set", - (LispVal * plist, LispVal *key, LispVal *value, LispVal *pred)) { + (LispVal * plist, LispVal *key, LispVal *value, LispVal *pred), + "(plist key value &opt pred)", + "Set the value associated with KEY in PLIST to VALUE. Keys are compared " + "with PRED. Return the modified PLIST.") { for (LispVal *cur = plist; !NILP(cur); cur = TAIL(TAIL(cur))) { if (call_eq_pred(pred, key, HEAD(cur))) { if (NILP(TAIL(cur))) { @@ -2017,7 +2103,10 @@ DEFUN(plist_set, "plist-set", return push_many(plist, 2, value, key); } -DEFUN(plist_rem, "plist-rem", (LispVal * plist, LispVal *key, LispVal *pred)) { +DEFUN(plist_rem, "plist-rem", (LispVal * plist, LispVal *key, LispVal *pred), + "(plist key &rest pred)", + "Removed KEY and its associated value from PLIST. Keys are compared with " + "PRED. Return the modified PLIST.") { for (LispVal *prev = Qnil, *cur = plist; !NILP(cur); prev = cur, cur = TAIL(TAIL(cur))) { if (call_eq_pred(pred, key, HEAD(cur))) { @@ -2033,7 +2122,9 @@ DEFUN(plist_rem, "plist-rem", (LispVal * plist, LispVal *key, LispVal *pred)) { } DEFUN(plist_assoc, "plist-assoc", - (LispVal * plist, LispVal *key, LispVal *pred)) { + (LispVal * plist, LispVal *key, LispVal *pred), "(plist key &rest pred)", + "Return the sub-list starting with KEY from PLIST. Keys are compared " + "with PRED.") { for (LispVal *cur = plist; !NILP(cur); cur = TAIL(TAIL(cur))) { if (call_eq_pred(pred, key, HEAD(cur))) { return cur; @@ -2060,11 +2151,13 @@ static LispVal *normalize_package(LispVal *arg) { } } -DEFUN(packagep, "packagep", (LispVal * val)) { +DEFUN(packagep, "packagep", (LispVal * val), "(obj)", + "Return non-nil if OBJ is a package object.") { return LISP_BOOL(PACKAGEP(val)); } -DEFUN(make_package, "make-package", (LispVal * name)) { +DEFUN(make_package, "make-package", (LispVal * name), "(name)", + "Return a new un-registed package object called NAME.") { if (SYMBOLP(name)) { name = Fsymbol_name(name); } else { @@ -2075,12 +2168,14 @@ DEFUN(make_package, "make-package", (LispVal * name)) { return np; } -DEFUN(package_name, "package-name", (LispVal * package)) { +DEFUN(package_name, "package-name", (LispVal * package), "(package)", + "Return the name of PACKAGE.") { CHECK_TYPE(TYPE_PACKAGE, package); return LISPVAL(((LispPackage *) package)->name); } -DEFUN(register_package, "register-package", (LispVal * package)) { +DEFUN(register_package, "register-package", (LispVal * package), "(package)", + "Register PACKAGE with the reader.") { if (STRINGP(package)) { package = make_lisp_package(package); } else if (SYMBOLP(package)) { @@ -2098,12 +2193,13 @@ DEFUN(register_package, "register-package", (LispVal * package)) { return package; } -DEFUN(current_package, "current-package", (void) ) { +DEFUN(current_package, "current-package", (void), "()", + "Return the current package.") { return refcount_ref(current_package); } -IGNORE(); // fix indentation -DEFUN(set_current_package, "set-current-package", (LispVal * package)) { +DEFUN(set_current_package, "set-current-package", (LispVal * package), + "(package)", "Set the current package.") { LispVal *new = normalize_package(package); LispVal *old = current_package; current_package = new; @@ -2111,7 +2207,10 @@ DEFUN(set_current_package, "set-current-package", (LispVal * package)) { return refcount_ref(current_package); } -DEFUN(mapsymbols, "mapsymbols", (LispVal * func, LispVal *package)) { +DEFUN(mapsymbols, "mapsymbols", (LispVal * func, LispVal *package), + "(func &opt package)", + "Call FUNC for each symbol in PACKAGE, defaulting to the current " + "package.") { LispPackage *pkg; if (NILP(package)) { pkg = refcount_ref(current_package); @@ -2128,10 +2227,15 @@ DEFUN(mapsymbols, "mapsymbols", (LispVal * func, LispVal *package)) { return Qnil; } -DEFUN(export_symbol, "export-symbol", (LispVal * symbol)) { +DEFUN(export_symbol, "export-symbol", (LispVal * symbol), "(symbol)", + "Mark SYMBOL as exported from its package. If SYMBOL is not interned in " + "any package, throw and error.") { if (SYMBOLP(symbol)) { LispSymbol *sym = (LispSymbol *) symbol; LispPackage *pkg = (LispPackage *) sym->package; + if (NILP(pkg)) { + Fthrow(Qtype_error, Qnil); + } puthash(pkg->exported_sym_table, symbol, Qt); } else if (LISTP(symbol)) { FOREACH(cur, symbol) { @@ -2158,7 +2262,11 @@ static bool check_recursive_import(LispVal *source, LispVal *target) { } DEFUN_DISTINGUISHED(import_package, "import-package", - (LispVal * source, LispVal *names, LispVal *target)) { + (LispVal * source, LispVal *names, LispVal *target), + "(source names &opt target)", + "Import each symbol with a name in NAMES from SOURCE into " + "TARGET. TARGET defaults to the current package. If NAMES " + "is t, import every symbol exported by SOURCE.") { LispPackage *target_pkg; if (target == Qunbound || NILP(target)) { target_pkg = refcount_ref(current_package); @@ -2232,7 +2340,9 @@ done: return Qnil; } -DEFUN(find_package, "find-package", (LispVal * name)) { +DEFUN(find_package, "find-package", (LispVal * name), "(name)", + "Return the package named NAME registered with the reader, if one " + "exists.") { if (STRINGP(name)) { return Fgethash(package_table, name, Qnil); } else if (SYMBOLP(name)) { @@ -2262,30 +2372,37 @@ LispVal *find_package(const char *name, size_t length) { // #################### // # Symbol Functions # // #################### -DEFUN(symbolp, "symbolp", (LispVal * val)) { +DEFUN(symbolp, "symbolp", (LispVal * val), "(obj)", + "Return non-nil if OBJ is a symbol.") { return LISP_BOOL(SYMBOLP(val)); } -DEFUN(keywordp, "keywordp", (LispVal * val)) { +DEFUN(keywordp, "keywordp", (LispVal * val), "(obj)", + "Return non-nil if OBJ is a symbol interned in the kw package.") { return LISP_BOOL(KEYWORDP(val)); } -DEFUN(make_symbol, "make-symbol", (LispVal * name)) { +DEFUN(make_symbol, "make-symbol", (LispVal * name), "(name)", + "Return a new uninterned symbol named NAME.") { return make_lisp_symbol(name); } -DEFUN(symbol_package, "symbol-package", (LispVal * symbol)) { +DEFUN(symbol_package, "symbol-package", (LispVal * symbol), "(symbol)", + "Return the package of SYMBOL.") { CHECK_TYPE(TYPE_SYMBOL, symbol); return refcount_ref(((LispSymbol *) symbol)->package); } -DEFUN(symbol_name, "symbol-name", (LispVal * symbol)) { +DEFUN(symbol_name, "symbol-name", (LispVal * symbol), "(symbol)", + "Return the name of SYMBOL.") { CHECK_TYPE(TYPE_SYMBOL, symbol); return refcount_ref(((LispSymbol *) symbol)->name); } -DEFUN(symbol_function, "symbol-function", - (LispVal * symbol, LispVal *resolve)) { +DEFUN(symbol_function, "symbol-function", (LispVal * symbol, LispVal *resolve), + "(symbol &opt resolve)", + "Return the value as a function of SYMBOL. If RESOLVE is non-nil and the " + "value is also a non-nil symbol, repeat this process.") { CHECK_TYPE(TYPE_SYMBOL, symbol); if (NILP(resolve)) { return refcount_ref(((LispSymbol *) symbol)->function); @@ -2296,17 +2413,20 @@ DEFUN(symbol_function, "symbol-function", return refcount_ref(symbol); } -DEFUN(symbol_value, "symbol-value", (LispVal * symbol)) { +DEFUN(symbol_value, "symbol-value", (LispVal * symbol), "(symbol)", + "Return the global value of SYMBOL.") { CHECK_TYPE(TYPE_SYMBOL, symbol); return refcount_ref(((LispSymbol *) symbol)->value); } -DEFUN(symbol_plist, "symbol-plist", (LispVal * symbol)) { +DEFUN(symbol_plist, "symbol-plist", (LispVal * symbol), "(symbol)", + "Return the plist of SYMBOL.") { CHECK_TYPE(TYPE_SYMBOL, symbol); return refcount_ref(((LispSymbol *) symbol)->plist); } -DEFUN(setplist, "setplist", (LispVal * symbol, LispVal *plist)) { +DEFUN(setplist, "setplist", (LispVal * symbol, LispVal *plist), + "(symbol plist)", "Set the plist of SYMBOL to PLIST.") { CHECK_TYPE(TYPE_SYMBOL, symbol); LispSymbol *real = (LispSymbol *) symbol; refcount_unref(real->plist); @@ -2314,7 +2434,8 @@ DEFUN(setplist, "setplist", (LispVal * symbol, LispVal *plist)) { return Qnil; } -DEFUN(fset, "fset", (LispVal * sym, LispVal *new_func)) { +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 @@ -2324,7 +2445,8 @@ DEFUN(fset, "fset", (LispVal * sym, LispVal *new_func)) { return refcount_ref(new_func); } -DEFUN(exported_symbol_p, "exported-symbol-p", (LispVal * symbol)) { +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)) { @@ -2335,7 +2457,11 @@ DEFUN(exported_symbol_p, "exported-symbol-p", (LispVal * symbol)) { } DEFUN(intern_soft, "intern-soft", - (LispVal * name, LispVal *def, LispVal *package, LispVal *included_too)) { + (LispVal * name, LispVal *def, LispVal *package, LispVal *included_too), + "(name &opt def package included-too)", + "If a symbol named NAME is interned in PACKAGE, return it. Otherwise, " + "return DEF. If INCLUDED-TOO is non-nil also check symbol imported by " + "PACKAGE.") { LispPackage *real_pkg; if (NILP(package)) { real_pkg = refcount_ref(current_package); @@ -2373,7 +2499,11 @@ DEFUN(intern_soft, "intern-soft", } DEFUN(intern, "intern", - (LispVal * name, LispVal *package, LispVal *included_too)) { + (LispVal * name, LispVal *package, LispVal *included_too), + "(name &opt package included-too)", + "If a SYMBOL named NAME is interned in PACKAGE, return it, otherwise, " + "intern a new symbol into PACKAGE. If INCLUDED-TOO is non-nil, also " + "search imported symbols of PACKAGE.") { CHECK_TYPE(TYPE_STRING, name); LispPackage *real_pkg; if (NILP(package)) { @@ -2392,7 +2522,9 @@ DEFUN(intern, "intern", return sym; } -DEFUN(quote_symbol_name, "quote-symbol-name", (LispVal * name)) { +DEFUN(quote_symbol_name, "quote-symbol-name", (LispVal * name), "(name)", + "Quote NAME such that it could be read back by the reader as a symbol " + "called NAME.") { CHECK_TYPE(TYPE_STRING, name); LispString *str = (LispString *) name; size_t out_len = str->length; @@ -2411,7 +2543,9 @@ DEFUN(quote_symbol_name, "quote-symbol-name", (LispVal * name)) { } DEFUN(symbol_accessible_p, "symbol-accessible-p", - (LispVal * symbol, LispVal *package)) { + (LispVal * symbol, LispVal *package), "(symbol &opt package)", + "Return non-nil if SYMBOL is interned in PACKAGE or transiently imported " + "into it.") { LispVal *name = Fsymbol_name(symbol); LispVal *found; WITH_CLEANUP(name, { @@ -2424,7 +2558,12 @@ DEFUN(symbol_accessible_p, "symbol-accessible-p", DEF_STATIC_SYMBOL(kw_as_needed, "as-needed"); DEFUN(quote_symbol_for_read, "quote-symbol-for-read", - (LispVal * target, LispVal *include_package)) { + (LispVal * target, LispVal *include_package, LispVal *from), + "(target &opt include-package from)", + "Quote TARGET, as symbol, such that a symbol with the same name as it " + "will read by the reader. If INCLUDE-PACKAGE is :as-needed, add the " + "package if it would be required to read back from the package FROM. If " + "it is any other non-nil value, add the package regardless.") { CHECK_TYPE(TYPE_SYMBOL, target); LispSymbol *sym = (LispSymbol *) target; LispString *sym_name = @@ -2434,7 +2573,7 @@ DEFUN(quote_symbol_for_read, "quote-symbol-for-read", } else if (include_package == Qkw_as_needed) { void *cl_handler = register_cleanup(&refcount_unref_as_callback, sym_name); - bool accessible = !NILP(Fsymbol_accessible_p(LISPVAL(sym), Qnil)); + bool accessible = !NILP(Fsymbol_accessible_p(LISPVAL(sym), from)); cancel_cleanup(cl_handler); if (accessible) { return LISPVAL(sym_name); @@ -2481,15 +2620,20 @@ LispVal *intern(const char *name, size_t length, bool take, LispVal *package, // ######################## // # Hash Table Functions # // ######################## -DEFUN(hash_table_p, "hash-table-p", (LispVal * val)) { +DEFUN(hash_table_p, "hash-table-p", (LispVal * val), "(obj)", + "Return non-nil if OBJ is a hash table.") { return LISP_BOOL(HASHTABLEP(val)); } -DEFUN(make_hash_table, "make-hash-table", (LispVal * hash_fn, LispVal *eq_fn)) { +DEFUN(make_hash_table, "make-hash-table", (LispVal * hash_fn, LispVal *eq_fn), + "(&opt hash-fn eq-fn)", + "Create a new hash table with hash function HASH-FN, defaulting to id, " + "and equality test EQ-FN, defaulting to eq.") { return make_lisp_hashtable(eq_fn, hash_fn); } -DEFUN(copy_hash_table, "copy-hash-table", (LispVal * table)) { +DEFUN(copy_hash_table, "copy-hash-table", (LispVal * table), "(table)", + "Return a copy of TABLE.") { CHECK_TYPE(TYPE_HASHTABLE, table); LispHashtable *src = (LispHashtable *) table; CONSTRUCT_OBJECT(copy, LispHashtable, TYPE_HASHTABLE); @@ -2507,12 +2651,15 @@ DEFUN(copy_hash_table, "copy-hash-table", (LispVal * table)) { return LISPVAL(copy); } -DEFUN(hash_table_count, "hash-table-count", (LispVal * table)) { +DEFUN(hash_table_count, "hash-table-count", (LispVal * table), "(table)", + "Return the number of entries in TABLE.") { CHECK_TYPE(TYPE_HASHTABLE, table); return make_lisp_integer(((LispHashtable *) table)->count); } -DEFUN(maphash, "maphash", (LispVal * func, LispVal *table)) { +DEFUN(maphash, "maphash", (LispVal * func, LispVal *table), "(func table)", + "Call FUNC for each key-value pair in TABLE. FUNC may modify table only " + "by altering the current entry.") { HT_FOREACH_VALID_INDEX(table, i) { LispVal *args = const_list(true, 2, HASH_KEY(table, i), HASH_VALUE(table, i)); @@ -2523,11 +2670,17 @@ DEFUN(maphash, "maphash", (LispVal * func, LispVal *table)) { return Qnil; } -DEFUN(puthash, "puthash", (LispVal * table, LispVal *key, LispVal *value)) { +DEFUN( + puthash, "puthash", (LispVal * table, LispVal *key, LispVal *value), + "(table key value)", + "Associate VALUE with KEY in TABLE, overriding any current association.") { return refcount_ref(puthash(table, key, value)); } -DEFUN(gethash, "gethash", (LispVal * table, LispVal *key, LispVal *def)) { +DEFUN(gethash, "gethash", (LispVal * table, LispVal *key, LispVal *def), + "(table key &opt def)", + "Return the VALUE associated with KEY in table, or DEF is no such " + "mapping exists.") { return refcount_ref(gethash(table, key, def)); } @@ -2582,7 +2735,10 @@ static ptrdiff_t hash_table_find_entry(struct HashtableEntry *entries, return i; } -DEFUN(remhash, "remhash", (LispVal * table, LispVal *key)) { +DEFUN(remhash, "remhash", (LispVal * table, LispVal *key, LispVal *def), + "(table key &opt def)", + "Remove the value associated with KEY from TABLE. Return the removed " + "value or DEF if no association was found.") { CHECK_TYPE(TYPE_HASHTABLE, table); LispHashtable *self = (LispHashtable *) table; uint64_t hash = hash_table_hash(self, key); @@ -2707,22 +2863,25 @@ LispVal *gethash(LispVal *table, LispVal *key, LispVal *def) { } } -LispVal *remhash(LispVal *table, LispVal *key) { - return refcount_unref(Fremhash(table, key)); +void remhash(LispVal *table, LispVal *key) { + refcount_unref(Fremhash(table, key, Qnil)); } // ##################### // # Numeric Functions # // ##################### -DEFUN(integerp, "integerp", (LispVal * val)) { +DEFUN(integerp, "integerp", (LispVal * val), "(obj)", + "Return non-nil of OBJ is an integer.") { return LISP_BOOL(INTEGERP(val)); } -DEFUN(floatp, "floatp", (LispVal * val)) { +DEFUN(floatp, "floatp", (LispVal * val), "(obj)", + "Return non-nil if OBJ is a float.") { return LISP_BOOL(FLOATP(val)); } -DEFUN(num_eq, "=", (LispVal * n1, LispVal *n2)) { +DEFUN(num_eq, "=", (LispVal * n1, LispVal *n2), "(n1 n2)", + "Return non-nil if N1 and N2 are numerically equal.") { if (INTEGERP(n1) && INTEGERP(n2)) { return LISP_BOOL(((LispInteger *) n1)->value == ((LispInteger *) n2)->value); @@ -2740,7 +2899,8 @@ DEFUN(num_eq, "=", (LispVal * n1, LispVal *n2)) { } } -DEFUN(num_gt, ">", (LispVal * n1, LispVal *n2)) { +DEFUN(num_gt, ">", (LispVal * n1, LispVal *n2), "(n1 n2)", + "Return non-nil if N1 is greater than N2.") { if (INTEGERP(n1) && INTEGERP(n2)) { return LISP_BOOL(((LispInteger *) n1)->value > ((LispInteger *) n2)->value); @@ -2784,7 +2944,7 @@ static inline LispVal *copy_number(LispVal *v) { } } -DEFUN(add, "+", (LispVal * args)) { +DEFUN(add, "+", (LispVal * args), "(&rest nums)", "Return the sum of NUMS.") { if (NILP(args)) { return make_lisp_integer(0); } @@ -2798,7 +2958,8 @@ DEFUN(add, "+", (LispVal * args)) { return out; } -DEFUN(sub, "-", (LispVal * args)) { +DEFUN(sub, "-", (LispVal * args), "(&rest nums)", + "Subtract from the first number in NUMS each other number in NUMS.") { if (NILP(args)) { return make_lisp_integer(0); } @@ -2812,7 +2973,7 @@ DEFUN(sub, "-", (LispVal * args)) { return out; } -DEFUN(mul, "*", (LispVal * args)) { +DEFUN(mul, "*", (LispVal * args), "(nums)", "Return the product of NUMS.") { if (NILP(args)) { return make_lisp_integer(1); } @@ -2826,7 +2987,9 @@ DEFUN(mul, "*", (LispVal * args)) { return out; } -DEFUN(div, "/", (LispVal * first, LispVal *rest)) { +DEFUN(div, "/", (LispVal * first, LispVal *rest), "(first &rest rest)", + "If REST is nil, return the reciprocal of FIRST. Otherwise, return FIRST " + "divided by the product of REST.") { if (NILP(rest)) { if (INTEGERP(first)) { return make_lisp_float(1.0 / ((LispInteger *) first)->value); @@ -2863,12 +3026,16 @@ DEFUN(div, "/", (LispVal * first, LispVal *rest)) { // #################### // # Vector Functions # // #################### -DEFUN(vectorp, "vectorp", (LispVal * val)) { +DEFUN(vectorp, "vectorp", (LispVal * val), "(obj)", + "Return non-nil of OBJ is a vector.") { return LISP_BOOL(VECTORP(val)); } DEFUN(make_vector, "make-vector", - (LispVal * initial_size, LispVal *initial_elem)) { + (LispVal * initial_size, LispVal *initial_elem), + "(initial-size &opt initial-elem)", + "Return a new vector of INITIAL-SIZE with each element being " + "INITIAL-ELEM.") { CHECK_TYPE(TYPE_INTEGER, initial_size); int64_t size = ((LispInteger *) initial_size)->value; if (size < 0) { @@ -2881,7 +3048,8 @@ DEFUN(make_vector, "make-vector", return make_lisp_vector(data, size); } -DEFUN(vector, "vector", (LispVal * elems)) { +DEFUN(vector, "vector", (LispVal * elems), "(&rest elems)", + "Construct a vector form each of ELEMS.") { if (LISTP(elems)) { struct UnrefListData uld = {.vals = NULL, .len = 0}; WITH_PUSH_FRAME(Qnil, Qnil, true, { @@ -2917,7 +3085,8 @@ DEFUN(vector, "vector", (LispVal * elems)) { } } -DEFUN(vector_length, "vector-length", (LispVal * vec)) { +DEFUN(vector_length, "vector-length", (LispVal * vec), "(vec-or-str)", + "Return the length of VEC-OR-STR, a vector or string.") { if (VECTORP(vec)) { return make_lisp_integer(((LispVector *) vec)->length); } else if (STRINGP(vec)) { @@ -2929,7 +3098,8 @@ DEFUN(vector_length, "vector-length", (LispVal * vec)) { } } -DEFUN(aref, "aref", (LispVal * vec, LispVal *index)) { +DEFUN(aref, "aref", (LispVal * vec, LispVal *index), "(vec-or-str index)", + "Return the element numbered INDEX in VEC-OR-STR, starting from zero.") { CHECK_TYPE(TYPE_INTEGER, index); int64_t idx = ((LispInteger *) index)->value; if (idx < 0) { @@ -2954,7 +3124,8 @@ DEFUN(aref, "aref", (LispVal * vec, LispVal *index)) { } } -DEFUN(aset, "aset", (LispVal * vec, LispVal *index, LispVal *elem)) { +DEFUN(aset, "aset", (LispVal * vec, LispVal *index, LispVal *elem), + "(vec index elem)", "Set the element at INDEX in VEC to ELEM.") { CHECK_TYPE(TYPE_INTEGER, index); CHECK_TYPE(TYPE_VECTOR, vec); int64_t idx = ((LispInteger *) index)->value; @@ -2970,7 +3141,10 @@ DEFUN(aset, "aset", (LispVal * vec, LispVal *index, LispVal *elem)) { return refcount_ref(elem); } -DEFUN(subvector, "subvector", (LispVal * seq, LispVal *start, LispVal *end)) { +DEFUN(subvector, "subvector", (LispVal * seq, LispVal *start, LispVal *end), + "(vec-or-str &opt start end)", + "Return a sub-vector or sub-string of VEC-OR-STR between START and END, " + "defaulting to 0 and the length of VEC-OR-STR.") { if (!NILP(start)) { CHECK_TYPE(TYPE_INTEGER, start); } @@ -3027,11 +3201,13 @@ DEFUN(subvector, "subvector", (LispVal * seq, LispVal *start, LispVal *end)) { // #################### // # String Functions # // #################### -DEFUN(stringp, "stringp", (LispVal * val)) { +DEFUN(stringp, "stringp", (LispVal * val), "(obj)", + "Return non-nil if OBJ is a string.") { return LISP_BOOL(STRINGP(val)); } -DEFUN(string, "string", (LispVal * val)) { +DEFUN(string, "string", (LispVal * val), "(seq)", + "Convert SEQ—a string, vector, or list—to a string.") { if (STRINGP(val)) { return refcount_ref(val); } else if (VECTORP(val)) { @@ -3075,7 +3251,8 @@ DEFUN(string, "string", (LispVal * val)) { } } -DEFUN(hash_string, "hash-string", (LispVal * obj)) { +DEFUN(hash_string, "hash-string", (LispVal * obj), "(str)", + "Return the hash of STR.") { CHECK_TYPE(TYPE_STRING, obj); const char *str = ((LispString *) obj)->data; uint64_t hash = 5381; @@ -3086,7 +3263,8 @@ DEFUN(hash_string, "hash-string", (LispVal * obj)) { return make_lisp_integer(hash); } -DEFUN(strings_equal, "strings-equal", (LispVal * obj1, LispVal *obj2)) { +DEFUN(strings_equal, "strings-equal", (LispVal * obj1, LispVal *obj2), + "(str1 str2)", "Return non-nil if STR1 and STR2 are equal.") { CHECK_TYPE(TYPE_STRING, obj1); CHECK_TYPE(TYPE_STRING, obj2); LispString *str1 = (LispString *) obj1; @@ -3097,7 +3275,8 @@ DEFUN(strings_equal, "strings-equal", (LispVal * obj1, LispVal *obj2)) { return LISP_BOOL(memcmp(str1->data, str2->data, str1->length) == 0); } -DEFUN(string_to_vector, "string-to-vector", (LispVal * str)) { +DEFUN(string_to_vector, "string-to-vector", (LispVal * str), "(str)", + "Convert STR to a vector.") { CHECK_TYPE(TYPE_STRING, str); LispString *s = (LispString *) str; LispVal **vdata = lisp_malloc(sizeof(LispVal *) * s->length); @@ -3107,7 +3286,8 @@ DEFUN(string_to_vector, "string-to-vector", (LispVal * str)) { return make_lisp_vector(vdata, s->length); } -DEFUN(quote_string, "quote-string", (LispVal * target)) { +DEFUN(quote_string, "quote-string", (LispVal * target), "(target)", + "Quote TARGET such that it can be read back by the reader.") { CHECK_TYPE(TYPE_STRING, target); LispString *str = (LispString *) target; size_t out_size = str->length + 2; @@ -3155,7 +3335,8 @@ DEFUN(quote_string, "quote-string", (LispVal * target)) { return make_lisp_string(out, out_size, true, false); } -DEFUN(concat, "concat", (LispVal * strings)) { +DEFUN(concat, "concat", (LispVal * strings), "(&rest strings)", + "Concatenate each string in STRINGS.") { LispVal *retval; WITH_PUSH_FRAME(Qnil, Qnil, true, { char *out = lisp_malloc(1); @@ -3224,7 +3405,7 @@ static int64_t internal_print(void *obj, int64_t fd, bool first_in_list) { return CHECK_IO_RESULT(write(fd, str->data, str->length), fd); } case TYPE_SYMBOL: { - LispVal *name = Fquote_symbol_for_read(obj, Qkw_as_needed); + LispVal *name = Fquote_symbol_for_read(obj, Qkw_as_needed, Qnil); int64_t np; WITH_CLEANUP(name, { np = internal_print(name, fd, true); // @@ -3331,7 +3512,10 @@ 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", (LispVal * obj, LispVal *stream), + "(obj &opt stream)", + "Write a human readable representation of OBJ to STREAM, " + "defaulting to the standard output.") { int64_t fd; if (stream == Qunbound) { fd = 1; @@ -3345,7 +3529,9 @@ DEFUN_DISTINGUISHED(print, "print", (LispVal * obj, LispVal *stream)) { return make_lisp_integer(internal_print(obj, fd, false)); } -DEFUN_DISTINGUISHED(println, "println", (LispVal * obj, LispVal *stream)) { +DEFUN_DISTINGUISHED( + println, "println", (LispVal * obj, LispVal *stream), "(obj &opt stream)", + "Call print with OBJ and STREAM, then write a newline to STREAM.") { static char NEWLINE = '\n'; int64_t fd; if (stream == Qunbound) { @@ -3372,7 +3558,7 @@ DEFUN_DISTINGUISHED(println, "println", (LispVal * obj, LispVal *stream)) { DEF_STATIC_SYMBOL(kw_success, "success"); DEF_STATIC_SYMBOL(kw_finally, "finally"); -DEFUN(backtrace, "backtrace", (void) ) { +DEFUN(backtrace, "backtrace", (void), "()", "Return a backtrace.") { LispVal *head = Qnil; LispVal *end = Qnil; for (StackFrame *frame = the_stack; frame; frame = frame->next) { @@ -3394,11 +3580,11 @@ DEFUN(backtrace, "backtrace", (void) ) { } return head; } -IGNORE(); // fix indentation #pragma GCC diagnostic push #pragma GCC diagnostic ignored "-Winfinite-recursion" -DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) { +DEFUN(throw, "throw", (LispVal * signal, LispVal *rest), "(signal &rest rest)", + "Throw a signal SIGNAL with data REST.") { CHECK_TYPE(TYPE_SYMBOL, signal); LispVal *error_arg = const_list(false, 2, Fpair(signal, rest), Fbacktrace()); @@ -3422,7 +3608,7 @@ DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) { push_to_lexenv(&the_stack->lexenv, var, error_arg); } WITH_CLEANUP(error_arg, { - stack_return = Feval(form); // + stack_return = Feval(form, the_stack->lexenv); // }); }); longjmp(the_stack->start, STACK_EXIT_THROW); @@ -3437,7 +3623,7 @@ DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) { void *cl_handler = register_cleanup(&refcount_unref_as_callback, error_arg); WITH_CLEANUP(unwind_form, { - refcount_unref(Feval(unwind_form)); // + refcount_unref(Feval(unwind_form, the_stack->lexenv)); // }); cancel_cleanup(cl_handler); } @@ -3499,7 +3685,7 @@ void stack_leave(void) { lisp_free(frame); if (!NILP(unwind_form)) { WITH_CLEANUP(unwind_form, { - refcount_unref(Feval(unwind_form)); // + refcount_unref(Feval(unwind_form, the_stack->lexenv)); // }) } } @@ -3752,145 +3938,175 @@ static void register_symbols_and_functions(void) { REGISTER_SYMBOL(unknown_package_error); REGISTER_SYMBOL(out_of_bounds_error); REGISTER_SYMBOL(io_error); + REGISTER_SYMBOL(toplevel); - // some stuff that musn't be user accesable - REGISTER_SYMBOL_NOINTERN(toplevel); - REGISTER_STATIC_FUNCTION(set_for_return, "(entry dest)", ""); - REGISTER_STATIC_FUNCTION(internal_real_return, "(name tag value)", ""); + // some functions that mustn't be user accessible + REGISTER_STATIC_FUNCTION(set_for_return); + REGISTER_STATIC_FUNCTION(internal_real_return); - REGISTER_FUNCTION(make_hash_table, "(&opt hash-fn eq-fn)", ""); - REGISTER_FUNCTION(puthash, "(table key value)", ""); - REGISTER_FUNCTION(gethash, "(table key &opt def)", ""); - REGISTER_FUNCTION(remhash, "(table key)", ""); - REGISTER_FUNCTION(vector, "(&rest elements)", ""); - REGISTER_FUNCTION(breakpoint, "(&opt id)", "Do nothing..."); - REGISTER_FUNCTION(sethead, "(pair newval)", - "Set the head of PAIR to NEWVAL."); - REGISTER_FUNCTION(settail, "(pair newval)", - "Set the tail of PAIR to NEWVAL."); - REGISTER_FUNCTION(funcall, "(function &rest args)", "") - REGISTER_FUNCTION(apply, "(function &rest args)", "") - REGISTER_FUNCTION(throw, "(signal &rest data)", ""); - REGISTER_FUNCTION(pair, "(head tail)", - "Return a new pair with HEAD and TAIL."); - REGISTER_FUNCTION(head, "(pair)", "Return the head of PAIR."); - REGISTER_FUNCTION(tail, "(pair)", "Return the tail of PAIR."); - REGISTER_FUNCTION(quote, "(form)", "Return FORM as read by the reader."); - REGISTER_FUNCTION(exit, "(&opt code)", - "Exit with CODE, defaulting to zero."); - REGISTER_FUNCTION(not, "(obj)", - "Return t if OBJ is nil, otherwise return t."); - REGISTER_FUNCTION(add, "(&rest nums)", "Return the sun of NUMS."); - REGISTER_FUNCTION(sub, "(&rest nums)", - "Return (head NUMS) - (apply '+ (tail NUMS))."); - REGISTER_FUNCTION(mul, "(&rest nums)", ""); - REGISTER_FUNCTION(div, "(first &rest rest)", ""); - REGISTER_FUNCTION( - if, "(cond then &rest else)", - "Evaluate THEN if COND is non-nil, otherwise evaluate ELSE."); - REGISTER_FUNCTION( - setq, "(&rest name-value-pairs)", - "Set each of a number of variables to their respective values."); - REGISTER_FUNCTION(progn, "(&rest forms)", "Evaluate each of FORMS."); - REGISTER_FUNCTION(symbol_name, "(sym)", ""); - REGISTER_FUNCTION(symbol_package, "(sym)", ""); - REGISTER_FUNCTION(symbol_function, "(sym &opt resolve)", ""); - REGISTER_FUNCTION(symbol_value, "(sym)", "Return the global value of SYM."); - REGISTER_FUNCTION(symbol_plist, "(sym)", "Return the plist of SYM."); - REGISTER_FUNCTION(setplist, "(sym plist)", - "Set the plist of SYM to PLIST."); - REGISTER_FUNCTION(fset, "(sym new-func)", ""); - REGISTER_FUNCTION(lambda, "(args &rest body)", "Return a new closure."); - REGISTER_FUNCTION(while, "(cond &rest body)", - "Run BODY until COND returns nil."); - REGISTER_FUNCTION(eval, "(expr)", "Evaluate the lisp expression EXPR"); - REGISTER_FUNCTION(read, "(source)", - "Read and return the next s-expr from SOURCE."); - REGISTER_FUNCTION(eq, "(obj1 obj2)", - "Return non-nil if OBJ1 and OBJ2 are the same object."); - REGISTER_FUNCTION( - equal, "(obj1 obj2)", - "Return non-nil if OBJE1 and OBJ2 are structurally equal."); - REGISTER_FUNCTION(make_symbol, "(name)", - "Return a new un-interned symbol named NAME."); - REGISTER_FUNCTION(macroexpand_1, "(form &opt lexical-macros)", - "Return the form which FORM expands to."); - REGISTER_FUNCTION(macroexpand_toplevel, "(form &opt lexical-macros)", ""); - REGISTER_FUNCTION(macroexpand_all, "(form &opt lexical-macros)", ""); - REGISTER_FUNCTION(stringp, "(val)", "Return non-nil if VAL is a string."); - REGISTER_FUNCTION(symbolp, "(val)", "Return non-nil if VAL is a symbol."); - REGISTER_FUNCTION(pairp, "(val)", "Return non-nil if VAL is a pair."); - REGISTER_FUNCTION(hash_table_p, "(val)", - "Return non-nil if VAL is a hash table."); - REGISTER_FUNCTION(integerp, "(val)", "Return non-nil if VAL is a integer."); - REGISTER_FUNCTION(floatp, "(val)", "Return non-nil if VAL is a float."); - REGISTER_FUNCTION(vectorp, "(val)", "Return non-nil if VAL is a vector."); - REGISTER_FUNCTION(packagep, "(val)", "Return non-nil if VAL is a package."); - REGISTER_FUNCTION( - functionp, "(val)", - "Return non-nil if VAL is a non-macro function (includes buitlins)."); - REGISTER_FUNCTION(macrop, "(val &opt lexical-macros)", - "Return non-nil if VAL is a non-builtin macro."); - REGISTER_FUNCTION(builtinp, "(val)", - "Return non-nil if VAL is a non-macro builtin."); - REGISTER_FUNCTION(special_form_p, "(val)", - "Return non-nil if VAL is a macro-builtin."); - REGISTER_FUNCTION(user_pointer_p, "(val)", - "Return non-nil if VAL is a user pointer."); - REGISTER_FUNCTION(atom, "(val)", "Return non-nil if VAL is a atom."); - REGISTER_FUNCTION(listp, "(val)", "Return non-nil if VAL is a list."); - REGISTER_FUNCTION(keywordp, "(val)", "Return non-nil if VAL is a keyword."); - REGISTER_FUNCTION(list_length, "(list)", "Return the length of LIST."); - REGISTER_FUNCTION(copy_list, "(list)", "Return a shallow copy of LIST."); - REGISTER_FUNCTION(copy_tree, "(tree)", - "Return a deep copy of TREE and all sublists in it."); - REGISTER_FUNCTION(num_eq, "(n1 n2)", - "Return non-nil if N1 and N2 are equal numerically.") - REGISTER_FUNCTION(num_gt, "(n1 n2)", - "Return non-nil if N1 is greather than N2.") - REGISTER_FUNCTION(and, "(&rest args)", - "Logical and (with short circuit evaluation.)"); - REGISTER_FUNCTION(or, "(&rest args)", - "Logical or (with short circuit evaluation.)"); - REGISTER_FUNCTION(type_of, "(obj)", "Return the type of OBJ."); - REGISTER_FUNCTION(function_docstr, "(func)", - "Return the documentation string of FUNC."); - REGISTER_FUNCTION(plist_get, "(plist key &opt def pred)", ""); - REGISTER_FUNCTION(plist_set, "(plist key value &opt pred)", ""); - REGISTER_FUNCTION(plist_rem, "(plist key &opt pred)", ""); - REGISTER_FUNCTION(return_from, "(name &opt value)", - "Return from the function named NAME and return VALUE."); - REGISTER_FUNCTION(intern, "(name &opt package included-too)", ""); - REGISTER_FUNCTION(intern_soft, "(name &opt default package included-too)", - ""); - REGISTER_FUNCTION(condition_case, "(form &rest handlers)", ""); - REGISTER_FUNCTION(set_current_package, "(package)", ""); - REGISTER_FUNCTION(in_package, "(package)", ""); - REGISTER_FUNCTION(current_package, "()", ""); - REGISTER_FUNCTION(make_package, "(name)", ""); - REGISTER_FUNCTION(register_package, "(package)", ""); - REGISTER_FUNCTION(find_package, "(name)", ""); - REGISTER_FUNCTION(exported_symbol_p, "(symbol)", ""); - REGISTER_FUNCTION(export_symbol, "(symbol)", ""); - REGISTER_FUNCTION(import_package, "(source &opt names target)", ""); - REGISTER_FUNCTION(hash_table_count, "(table)", ""); - REGISTER_FUNCTION(copy_hash_table, "(table)", ""); - REGISTER_FUNCTION(package_name, "(package)", ""); - REGISTER_FUNCTION(mapsymbols, "(func &opt package)", ""); - REGISTER_FUNCTION(vector_length, "(vec-or-str)", ""); - REGISTER_FUNCTION(aref, "(vec-or-str index)", ""); - REGISTER_FUNCTION(aset, "(vec index elem)", ""); - REGISTER_FUNCTION(make_vector, "(size &opt initial-element)", ""); - REGISTER_FUNCTION(string, "(val)", ""); - REGISTER_FUNCTION(subvector, "(seq &opt start end)", ""); - REGISTER_FUNCTION(string_to_vector, "(str)", ""); - REGISTER_FUNCTION(maphash, "(func table)", ""); - REGISTER_FUNCTION(quote_string, "(target)", ""); - REGISTER_FUNCTION(quote_symbol_name, "(name)", ""); - REGISTER_FUNCTION(quote_symbol_for_read, "(target &opt include-package)", - ""); - REGISTER_FUNCTION(concat, "(&rest strings)", ""); - REGISTER_FUNCTION(print, "(obj &opt stream)", ""); - REGISTER_FUNCTION(println, "(&opt obj stream)", ""); - REGISTER_FUNCTION(symbol_accessible_p, "(symbol &opt package)", ""); + // ############################### + // # General and Misc. Functions # + // ############################### + REGISTER_FUNCTION(exit); + REGISTER_FUNCTION(id); + REGISTER_FUNCTION(eq); + REGISTER_FUNCTION(equal); + REGISTER_FUNCTION(breakpoint); + REGISTER_FUNCTION(not); + REGISTER_FUNCTION(type_of); + REGISTER_FUNCTION(user_pointer_p); + + // ################################## + // # Evaluation and Macro Expansion # + // ################################## + REGISTER_FUNCTION(eval); + REGISTER_FUNCTION(funcall); + REGISTER_FUNCTION(apply); + REGISTER_FUNCTION(macroexpand_1); + REGISTER_FUNCTION(macroexpand_toplevel); + REGISTER_FUNCTION(macroexpand_all); + + // ################# + // # Special Forms # + // ################# + REGISTER_FUNCTION(quote); + REGISTER_FUNCTION(if); + REGISTER_FUNCTION(setq); + REGISTER_FUNCTION(progn); + REGISTER_FUNCTION(condition_case); + REGISTER_FUNCTION(lambda); + REGISTER_FUNCTION(while); + REGISTER_FUNCTION(and); + REGISTER_FUNCTION(or); + REGISTER_FUNCTION(in_package); + REGISTER_FUNCTION(return_from); + + // ###################### + // # Function Functions # + // ###################### + REGISTER_FUNCTION(functionp); + REGISTER_FUNCTION(macrop); + REGISTER_FUNCTION(builtinp); + REGISTER_FUNCTION(special_form_p); + REGISTER_FUNCTION(function_docstr); + + // ########################### + // # Pair and List Functions # + // ########################### + REGISTER_FUNCTION(pairp); + REGISTER_FUNCTION(atom); + REGISTER_FUNCTION(pair); + REGISTER_FUNCTION(head); + REGISTER_FUNCTION(tail); + REGISTER_FUNCTION(sethead); + REGISTER_FUNCTION(settail); + + // lists + REGISTER_FUNCTION(listp); + REGISTER_FUNCTION(list_length); + REGISTER_FUNCTION(copy_list); + REGISTER_FUNCTION(copy_tree); + + // plists + REGISTER_FUNCTION(plist_get); + REGISTER_FUNCTION(plist_set); + REGISTER_FUNCTION(plist_rem); + REGISTER_FUNCTION(plist_assoc); + + // ##################### + // # Package Functions # + // ##################### + REGISTER_FUNCTION(packagep); + REGISTER_FUNCTION(make_package); + REGISTER_FUNCTION(package_name); + REGISTER_FUNCTION(register_package); + REGISTER_FUNCTION(current_package); + REGISTER_FUNCTION(set_current_package); + REGISTER_FUNCTION(mapsymbols); + REGISTER_FUNCTION(export_symbol); + REGISTER_FUNCTION(import_package); + REGISTER_FUNCTION(find_package); + + // #################### + // # Symbol Functions # + // #################### + REGISTER_FUNCTION(symbolp); + REGISTER_FUNCTION(keywordp); + REGISTER_FUNCTION(make_symbol); + REGISTER_FUNCTION(symbol_package); + REGISTER_FUNCTION(symbol_name); + REGISTER_FUNCTION(symbol_function); + REGISTER_FUNCTION(symbol_value); + REGISTER_FUNCTION(symbol_plist); + REGISTER_FUNCTION(setplist); + REGISTER_FUNCTION(fset); + REGISTER_FUNCTION(exported_symbol_p); + REGISTER_FUNCTION(intern_soft); + REGISTER_FUNCTION(intern); + REGISTER_FUNCTION(quote_symbol_name); + REGISTER_FUNCTION(symbol_accessible_p); + REGISTER_FUNCTION(quote_symbol_for_read); + + // ######################## + // # Hash Table Functions # + // ######################## + REGISTER_FUNCTION(hash_table_p); + REGISTER_FUNCTION(make_hash_table); + REGISTER_FUNCTION(copy_hash_table); + REGISTER_FUNCTION(hash_table_count); + REGISTER_FUNCTION(maphash); + REGISTER_FUNCTION(puthash); + REGISTER_FUNCTION(gethash); + REGISTER_FUNCTION(remhash); + + // ##################### + // # Numeric Functions # + // ##################### + REGISTER_FUNCTION(integerp); + REGISTER_FUNCTION(floatp); + REGISTER_FUNCTION(num_eq); + REGISTER_FUNCTION(num_gt); + REGISTER_FUNCTION(add); + REGISTER_FUNCTION(sub); + REGISTER_FUNCTION(mul); + REGISTER_FUNCTION(div); + + // #################### + // # Vector Functions # + // #################### + REGISTER_FUNCTION(vectorp); + REGISTER_FUNCTION(make_vector); + REGISTER_FUNCTION(vector); + REGISTER_FUNCTION(vector_length); + REGISTER_FUNCTION(aref); + REGISTER_FUNCTION(aset); + REGISTER_FUNCTION(subvector); + + // #################### + // # String Functions # + // #################### + REGISTER_FUNCTION(stringp); + REGISTER_FUNCTION(string); + REGISTER_FUNCTION(hash_string); + REGISTER_FUNCTION(strings_equal); + REGISTER_FUNCTION(string_to_vector); + REGISTER_FUNCTION(quote_string); + REGISTER_FUNCTION(concat); + + // ################ + // # IO Functions # + // ################ + REGISTER_FUNCTION(print); + REGISTER_FUNCTION(println); + + // ######################## + // # Lexenv and the Stack # + // ######################## + REGISTER_FUNCTION(backtrace); + REGISTER_FUNCTION(throw); + + // ############### + // # From read.c # + // ############### + register_reader_functions(); } diff --git a/src/lisp.h b/src/lisp.h index f3b03ea..c708be1 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -161,6 +161,16 @@ typedef struct { LispVal *imported; // list of (package . (str -> bool)) } LispPackage; +typedef struct { + LISP_OBJECT_HEADER; + + LispVal *class; +} LispObject; + +typedef struct { + LispObject as_obj; +} LispClass; + // ####################### // # nil, unbound, and t # // ####################### @@ -258,7 +268,9 @@ inline static bool NUMBERP(LispVal *v) { extern LispVal *Q##c_name // The args and doc fields are filled when the function is registered #define _INTERNAL_DEFUN_EXTENDED(macrop, du, c_name, lisp_name, c_args, \ - static_kw) \ + static_kw, lisp_args, doc_cstr) \ + static const char _F##c_name##lisp_args_cstr[] = lisp_args; \ + static const char _F##c_name##doccstr[] = doc_cstr; \ static_kw LispVal *F##c_name c_args; \ DEF_STATIC_STRING(_Q##c_name##_fnnamestr, lisp_name); \ static LispSymbol _Q##c_name; \ @@ -288,16 +300,21 @@ inline static bool NUMBERP(LispVal *v) { }; \ LispVal *Q##c_name = (LispVal *) &_Q##c_name; \ static_kw LispVal *F##c_name c_args -#define DEFUN(c_name, lisp_name, c_args) \ - _INTERNAL_DEFUN_EXTENDED(false, false, c_name, lisp_name, c_args, ) -#define DEFUN_DISTINGUISHED(c_name, lisp_name, c_args) \ - _INTERNAL_DEFUN_EXTENDED(false, true, c_name, lisp_name, c_args, ) -#define DEFMACRO(c_name, lisp_name, c_args) \ - _INTERNAL_DEFUN_EXTENDED(true, false, c_name, lisp_name, c_args, ) -#define STATIC_DEFUN(c_name, lisp_name, c_args) \ - _INTERNAL_DEFUN_EXTENDED(false, false, c_name, lisp_name, c_args, static) -#define STATIC_DEFMACRO(c_name, lisp_name, c_args) \ - _INTERNAL_DEFUN_EXTENDED(true, false, c_name, lisp_name, c_args, static) +#define DEFUN(c_name, lisp_name, c_args, lisp_args, doc_cstr) \ + _INTERNAL_DEFUN_EXTENDED(false, false, c_name, lisp_name, c_args, , \ + lisp_args, doc_cstr) +#define DEFUN_DISTINGUISHED(c_name, lisp_name, c_args, lisp_args, doc_cstr) \ + _INTERNAL_DEFUN_EXTENDED(false, true, c_name, lisp_name, c_args, , \ + lisp_args, doc_cstr) +#define DEFMACRO(c_name, lisp_name, c_args, lisp_args, doc_cstr) \ + _INTERNAL_DEFUN_EXTENDED(true, false, c_name, lisp_name, c_args, , \ + lisp_args, doc_cstr) +#define STATIC_DEFUN(c_name, lisp_name, c_args, lisp_args, doc_cstr) \ + _INTERNAL_DEFUN_EXTENDED(false, false, c_name, lisp_name, c_args, static, \ + lisp_args, doc_cstr) +#define STATIC_DEFMACRO(c_name, lisp_name, c_args, lisp_args, doc_cstr) \ + _INTERNAL_DEFUN_EXTENDED(true, false, c_name, lisp_name, c_args, static, \ + lisp_args, doc_cstr) // registration #define REGISTER_SYMBOL_NOINTERN(sym) \ @@ -313,20 +330,20 @@ inline static bool NUMBERP(LispVal *v) { REGISTER_SYMBOL_NOINTERN(sym) \ REGISTER_DO_INTERN(sym, pkg) #define REGISTER_SYMBOL(sym) REGISTER_SYMBOL_INTO(sym, system_package) -#define REGISTER_STATIC_FUNCTION(name, args, docstr) \ - REGISTER_SYMBOL_NOINTERN(name); \ - { \ - LispVal *obj = ((LispSymbol *) Q##name)->function; \ - refcount_init_static(obj); \ - ((LispFunction *) (obj))->doc = STATIC_STRING(docstr); \ - LispVal *src = STATIC_STRING(args); \ - LispVal *a = Fread(src, system_package); \ - set_function_args((LispFunction *) (obj), a); \ - refcount_unref(src); \ - refcount_unref(a); \ +#define REGISTER_STATIC_FUNCTION(name) \ + REGISTER_SYMBOL_NOINTERN(name); \ + { \ + LispVal *obj = ((LispSymbol *) Q##name)->function; \ + refcount_init_static(obj); \ + ((LispFunction *) (obj))->doc = STATIC_STRING(_F##name##doccstr); \ + LispVal *src = STATIC_STRING(_F##name##lisp_args_cstr); \ + LispVal *a = Fread(src, system_package); \ + set_function_args((LispFunction *) (obj), a); \ + refcount_unref(src); \ + refcount_unref(a); \ } -#define REGISTER_FUNCTION(fn, args, docstr) \ - REGISTER_STATIC_FUNCTION(fn, args, docstr); \ +#define REGISTER_FUNCTION(fn) \ + REGISTER_STATIC_FUNCTION(fn); \ ((LispSymbol *) Q##fn)->package = refcount_ref(system_package); \ puthash(((LispPackage *) system_package)->obarray, \ LISPVAL(((LispSymbol *) Q##fn)->name), Q##fn); @@ -400,8 +417,7 @@ DECLARE_FUNCTION(user_pointer_p, (LispVal * val)); // ################################## // # Evaluation and Macro Expansion # // ################################## -DECLARE_FUNCTION(eval_in_env, (LispVal * form, LispVal *lexenv)); -DECLARE_FUNCTION(eval, (LispVal * form)); +DECLARE_FUNCTION(eval, (LispVal * form, LispVal *lexenv)); DECLARE_FUNCTION(funcall, (LispVal * function, LispVal *rest)); DECLARE_FUNCTION(apply, (LispVal * function, LispVal *rest)); DECLARE_FUNCTION(macroexpand_1, (LispVal * form, LispVal *lexical_macros)); @@ -507,7 +523,7 @@ DECLARE_FUNCTION(quote_symbol_name, (LispVal * name)); DECLARE_FUNCTION(symbol_accessible_p, (LispVal * symbol, LispVal *package)); extern LispVal *Qkw_as_needed; DECLARE_FUNCTION(quote_symbol_for_read, - (LispVal * target, LispVal *include_package)); + (LispVal * target, LispVal *include_package, LispVal *from)); LispVal *intern(const char *name, size_t length, bool take, LispVal *package, bool included_too); @@ -521,7 +537,7 @@ DECLARE_FUNCTION(hash_table_count, (LispVal * table)); DECLARE_FUNCTION(maphash, (LispVal * func, LispVal *table)); DECLARE_FUNCTION(puthash, (LispVal * table, LispVal *key, LispVal *value)); DECLARE_FUNCTION(gethash, (LispVal * table, LispVal *key, LispVal *def)); -DECLARE_FUNCTION(remhash, (LispVal * table, LispVal *key)); +DECLARE_FUNCTION(remhash, (LispVal * table, LispVal *key, LispVal *def)); struct HashtableDataArray { size_t size; struct HashtableEntry *entries; @@ -531,7 +547,7 @@ void free_hash_table_data_array(void *data); // Don't ref their return value LispVal *puthash(LispVal *table, LispVal *key, LispVal *value); LispVal *gethash(LispVal *table, LispVal *key, LispVal *def); -LispVal *remhash(LispVal *table, LispVal *key); +void remhash(LispVal *table, LispVal *key); // ##################### // # Numeric Functions # diff --git a/src/main.c b/src/main.c index 29f46d2..7cd8787 100644 --- a/src/main.c +++ b/src/main.c @@ -3,8 +3,8 @@ static int exit_status = 0; -STATIC_DEFUN(toplevel_exit_handler, "toplevel-exit-handler", - (LispVal * except)) { +STATIC_DEFUN(toplevel_exit_handler, "toplevel-exit-handler", (LispVal * except), + "(except)", "Internal function.") { LispVal *detail = TAIL(HEAD(except)); if (NILP(detail) || NILP(HEAD(detail))) { exit_status = 0; @@ -17,7 +17,7 @@ STATIC_DEFUN(toplevel_exit_handler, "toplevel-exit-handler", } STATIC_DEFUN(toplevel_error_handler, "toplevel-error-handler", - (LispVal * except)) { + (LispVal * except), "(except)", "Internal function.") { LispVal *type = HEAD(HEAD(except)); LispVal *detail = TAIL(HEAD(except)); LispVal *backtrace = HEAD(TAIL(except)); @@ -56,8 +56,8 @@ int main(int argc, const char **argv) { fclose(in); lisp_init(); REGISTER_SYMBOL(toplevel_read); - REGISTER_STATIC_FUNCTION(toplevel_error_handler, "(e)", ""); - REGISTER_STATIC_FUNCTION(toplevel_exit_handler, "(e)", ""); + REGISTER_STATIC_FUNCTION(toplevel_error_handler); + REGISTER_STATIC_FUNCTION(toplevel_exit_handler); size_t pos = 0; WITH_PUSH_FRAME(Qtoplevel, Qnil, false, { the_stack->hidden = false; @@ -92,7 +92,7 @@ int main(int argc, const char **argv) { && list_length(tv) == 2) { refcount_unref(Fset_current_package(HEAD(TAIL(tv)))); } else { - refcount_unref(Feval(tv)); // + refcount_unref(Feval(tv, the_stack->lexenv)); // } }); } diff --git a/src/read.c b/src/read.c index dd94f1b..fb1b95e 100644 --- a/src/read.c +++ b/src/read.c @@ -575,7 +575,8 @@ size_t read_from_buffer(const char *text, size_t length, LispVal *package, return state.off; } -DEFUN(read, "read", (LispVal * source, LispVal *package)) { +DEFUN(read, "read", (LispVal * source, LispVal *package), "(source package)", + "Read a single form from SOURCE.") { LispString *str = (LispString *) source; CHECK_TYPE(TYPE_STRING, source); struct ReadState state = { @@ -600,3 +601,7 @@ DEFUN(read, "read", (LispVal * source, LispVal *package)) { return res; } } + +void register_reader_functions(void) { + REGISTER_FUNCTION(read); +} diff --git a/src/read.h b/src/read.h index 7efe3fc..a28d49b 100644 --- a/src/read.h +++ b/src/read.h @@ -13,4 +13,6 @@ size_t read_from_buffer(const char *text, size_t length, LispVal *package, DECLARE_FUNCTION(read, (LispVal * source, LispVal *package)); +void register_reader_functions(void); + #endif