diff --git a/ListTalk/classes/Class.h b/ListTalk/classes/Class.h index 6c03152..fce794a 100644 --- a/ListTalk/classes/Class.h +++ b/ListTalk/classes/Class.h @@ -34,6 +34,7 @@ struct LT_SlotType_s { extern LT_SlotType LT_SlotType_Object; extern LT_SlotType LT_SlotType_ReadonlyObject; extern LT_SlotType LT_SlotType_ReadonlyAtomicObject; +extern LT_SlotType LT_SlotType_ReadonlyNativeObjectPointer; #define LT_CLASS_FLAG_FLEXIBLE 1 #define LT_CLASS_FLAG_SPECIAL 2 diff --git a/ListTalk/classes/Package.h b/ListTalk/classes/Package.h index fe1da43..817a997 100644 --- a/ListTalk/classes/Package.h +++ b/ListTalk/classes/Package.h @@ -58,11 +58,13 @@ void LT_set_current_package(LT_Package* package); extern LT_Package LT_Package_LISTTALK; extern LT_Package LT_Package_LISTTALK_IMPLEMENTATION; extern LT_Package LT_Package_LISTTALK_USER; +extern LT_Package LT_Package_LISTTALK_DEBUG; extern LT_Package LT_Package_KEYWORD; #define LT_PACKAGE_LISTTALK (<_Package_LISTTALK) #define LT_PACKAGE_LISTTALK_IMPLEMENTATION (<_Package_LISTTALK_IMPLEMENTATION) #define LT_PACKAGE_LISTTALK_USER (<_Package_LISTTALK_USER) +#define LT_PACKAGE_LISTTALK_DEBUG (<_Package_LISTTALK_DEBUG) #define LT_PACKAGE_KEYWORD (<_Package_KEYWORD) LT__END_DECLS diff --git a/ListTalk/classes/Restart.h b/ListTalk/classes/Restart.h index a5d6e79..3af91a4 100644 --- a/ListTalk/classes/Restart.h +++ b/ListTalk/classes/Restart.h @@ -53,11 +53,15 @@ struct LT_Restart_s { .argument_list = LT_INVALID, \ .callable = LT_INVALID \ }; \ + static void LT___materialize_##restart_object_name(void){ \ + (void)LT_Restart_from_static(&restart_object_name); \ + } \ static void LT___init_##restart_object_name(void){ \ LT_Restart_init_static( \ &restart_object_name, \ &restart_object_name##_primitive \ ); \ + LT_register_constructor(LT___materialize_##restart_object_name); \ } \ LT_REGISTER_CONSTRUCTOR(LT___init_##restart_object_name) diff --git a/ListTalk/debugger/debugger.h b/ListTalk/debugger/debugger.h new file mode 100644 index 0000000..48a634b --- /dev/null +++ b/ListTalk/debugger/debugger.h @@ -0,0 +1,31 @@ +/* + * SPDX-License-Identifier: MIT + * Copyright (c) 2023 - 2026 Ales Hakl + */ + +#ifndef H__ListTalk__debugger__debugger__ +#define H__ListTalk__debugger__debugger__ + +#include +#include + +LT__BEGIN_DECLS + +/* + * Enter a debugger REPL for CONDITION in a fresh lexical environment. + * DEBUGGER_HOOK is dynamically reinstalled while evaluating REPL forms. + */ +void LT_Debugger_break(LT_Value condition, LT_Value debugger_hook); + +/* Return the two-argument primitive suitable for use as debugger_hook. */ +LT_Value LT_Debugger_get_hook(void); + +/* Install LT_Debugger_get_hook() as the current thread's debugger hook. */ +void LT_Debugger_enable(void); + +/* Interactively display OBJECT and descend through its named slots. */ +void LT_Debugger_inspect(LT_Value object); + +LT__END_DECLS + +#endif diff --git a/ListTalk/vm/conditions.h b/ListTalk/vm/conditions.h index 6833622..74c4e24 100644 --- a/ListTalk/vm/conditions.h +++ b/ListTalk/vm/conditions.h @@ -27,10 +27,26 @@ typedef struct LT_RestartFrame_s { #define LT__restart_stack (LT_thread_state()->restart_stack) void LT_signal(LT_Value condition); +void LT_invoke_debugger(LT_Value condition); +void LT_set_debugger_hook(LT_Value hook); LT_Value LT_current_restarts(void); LT_Value LT_find_restart(LT_Value name); LT_Value LT_invoke_restart(LT_Value name, LT_Value arguments); +#define LT_WITH_DEBUGGER_HOOK(HOOK_EXPR, BODY) \ + do { \ + LT_Value LT__with_debugger_hook_previous = \ + LT_thread_state()->debugger_hook; \ + LT_set_debugger_hook((HOOK_EXPR)); \ + LT_UNWIND_PROTECT( \ + { \ + BODY \ + }, \ + { \ + LT_set_debugger_hook(LT__with_debugger_hook_previous); \ + }); \ + } while (0) + #define LT_HANDLER_BIND(HANDLER_EXPR, BODY) \ do { \ LT_ConditionHandlerFrame LT__condition_handler_frame; \ diff --git a/ListTalk/vm/error.h b/ListTalk/vm/error.h index af4d2fe..65c2c2a 100644 --- a/ListTalk/vm/error.h +++ b/ListTalk/vm/error.h @@ -23,6 +23,12 @@ LT__BEGIN_DECLS void _Noreturn LT_error_impl(const char* message, ...); #define LT_error(...) LT_error_impl(__VA_ARGS__, NULL) +/** Report a correctable error with an active :continue restart. Trailing + * arguments have the same key-value shape as LT_error. + */ +void LT_cerror_impl(const char* message, ...); +#define LT_cerror(...) LT_cerror_impl(__VA_ARGS__, NULL) + void _Noreturn LT_system_error(const char* message, int errnum); void _Noreturn LT_subclass_responsibility_error(void); void _Noreturn LT_type_error(LT_Value value, LT_Class* expected_class); diff --git a/ListTalk/vm/stack_trace.h b/ListTalk/vm/stack_trace.h index 80e8074..1a90b81 100644 --- a/ListTalk/vm/stack_trace.h +++ b/ListTalk/vm/stack_trace.h @@ -61,6 +61,7 @@ static inline void LT_stack_trace_restore(LT_StackFrame* frame){ unsigned int LT_stack_trace_depth(void); LT_Value LT_stack_trace_capture(void); void LT_stack_trace_print(FILE* stream); +void LT_stack_trace_print_skipping(FILE* stream, unsigned int skip); LT__END_DECLS diff --git a/ListTalk/vm/thread_state.h b/ListTalk/vm/thread_state.h index 880aab7..a56c7ba 100644 --- a/ListTalk/vm/thread_state.h +++ b/ListTalk/vm/thread_state.h @@ -30,6 +30,7 @@ struct LT_ThreadState_s { LT_IdentityDictionary* dynamic_values; LT_Package* current_package; LT_Thread* current_thread; + LT_Value debugger_hook; _Atomic LT_Value pending_signal; int current_package_is_set; }; diff --git a/meson.build b/meson.build index 6ca6f31..c7605e2 100644 --- a/meson.build +++ b/meson.build @@ -251,6 +251,24 @@ pkg.generate( requires_private : libedit_dep.found() ? [libedit_dep] : [] ) +debugger_lib = library( + 'ListTalkDebugger', + 'src/debugger/debugger.c', + link_with : [vm_lib, repl_lib], + dependencies : listtalk_deps, + c_args : listtalk_c_args, + install : true +) + +pkg.generate( + debugger_lib, + filebase : 'ListTalkDebugger', + name : 'ListTalkDebugger', + description : 'ListTalk debugger and object inspector library', + subdirs : '.', + requires : ['ListTalkVM', 'ListTalkREPL'] +) + os_module = shared_module( 'os', 'src/modules/os.c', @@ -390,7 +408,7 @@ endif listtalk_exe = executable( 'listtalk', 'src/bin/listtalk/main.c', - link_with: [vm_lib, repl_lib], + link_with: [vm_lib, repl_lib, debugger_lib], dependencies : listtalk_deps, c_args : listtalk_c_args + [ '-DLT_NATIVE_MODULE_DIR="@0@"'.format(listtalk_native_module_runtime_dir), diff --git a/src/bin/listtalk/main.c b/src/bin/listtalk/main.c index 8041ed3..151fcb2 100644 --- a/src/bin/listtalk/main.c +++ b/src/bin/listtalk/main.c @@ -8,6 +8,7 @@ #include #include #include +#include #include #include #include @@ -17,11 +18,28 @@ #include #include #include +#include #include #include #include static LT_Value LT__repl_error_tag = LT_NIL; +static LT_Value LT__return_to_toplevel_tag = LT_NIL; + +LT_DEFINE_PRIMITIVE_RESTART( + return_to_toplevel_restart, + "return-to-toplevel", + "()", + "Abort the current computation and return to the interactive top level." +){ + LT_Value cursor = arguments; + (void)invocation_context_kind; + (void)invocation_context_data; + (void)tail_call_unwind_marker; + + LT_ARG_END(cursor); + LT_throw(LT__return_to_toplevel_tag, LT_TRUE); +} static void print_condition(LT_Value condition){ if (LT_Value_class(condition) == <_String_class){ @@ -58,6 +76,7 @@ static LT_Value throwing_error_handler( (void)invocation_context_data; (void)tail_call_unwind_marker; + LT_invoke_debugger(condition); print_condition(condition); LT_throw(LT__repl_error_tag, condition); } @@ -146,25 +165,6 @@ typedef struct { int standard_resolvers_initialized; } CommandActionBaton; -typedef struct { - LT_Environment* environment; - LT_Value error_handler; -} ReplEvalContext; - -static void eval_repl_object(LT_Value object, void* opaque){ - ReplEvalContext* context = opaque; - LT_Value caught = LT_NIL; - - LT_CATCH(LT__repl_error_tag, caught, { - LT_HANDLER_BIND(context->error_handler, { - LT_Value result = LT_eval(object, context->environment, NULL); - - LT_printer_print_object(result); - fputc('\n', stdout); - }); - }); -} - static void prepend_standard_module_resolvers(LT_Environment* environment){ #ifdef LT_SOURCE_MODULE_DIR LT_base_environment_prepend_module_resolver( @@ -314,8 +314,17 @@ static void no_std_lib_option_callback(LT_CmdOpts* parser, action->no_std_lib = 1; } +static void debug_option_callback(LT_CmdOpts* parser, + void* baton, + char* value){ + (void)parser; + (void)baton; + (void)value; + + LT_Debugger_enable(); +} + int main(int argc, char**argv){ - LT_Value repl_handler; LT_Value repl_reader_handler; LT_Value file_handler; LT_Environment* base_environment; @@ -328,11 +337,8 @@ int main(int argc, char**argv){ LT_INIT(); LT_set_current_package(LT_PACKAGE_LISTTALK_USER); LT__repl_error_tag = LT_Symbol_new("repl-error"); - repl_handler = LT_Primitive_new( - "repl-error-handler", - "(condition)", - "Print top-level REPL error and continue REPL loop.", - throwing_error_handler + LT__return_to_toplevel_tag = LT_Symbol_new_uninterned( + "return-to-toplevel" ); repl_reader_handler = LT_Primitive_new( "repl-reader-error-handler", @@ -355,6 +361,14 @@ int main(int argc, char**argv){ command_action.standard_resolvers_initialized = 0; cmdopts = LT_CmdOpts_new(LT_CMDOPTS_STRICT_ORDER); + LT_CmdOpts_addOption( + cmdopts, + 0, + 'd', + "debug", + debug_option_callback, + NULL + ); LT_CmdOpts_addOption( cmdopts, 1, @@ -416,20 +430,52 @@ int main(int argc, char**argv){ } command_action_ensure_standard_resolvers(&command_action); LT_enable_KeyboardInterrupt(); + LT_Debugger_enable(); { - LT_Value caught = LT_NIL; LT_REPL_State* repl = LT_REPL_State_new(); - ReplEvalContext repl_context = { - .environment = base_environment, - .error_handler = repl_handler - }; - - LT_CATCH(LT__repl_error_tag, caught, { - LT_HANDLER_BIND(repl_reader_handler, { - LT_REPL_State_loop(repl, eval_repl_object, &repl_context); - }); - }); - eval_status = caught == LT_NIL ? 0 : 1; + + eval_status = 0; + while (1){ + LT_Value reader_error = LT_NIL; + LT_Value returned_to_toplevel = LT_NIL; + LT_Value object = LT_INVALID; + + LT_CATCH( + LT__return_to_toplevel_tag, + returned_to_toplevel, + { + LT_RESTART_BIND( + LT_Restart_from_static(&return_to_toplevel_restart), { + LT_CATCH(LT__repl_error_tag, reader_error, { + LT_HANDLER_BIND(repl_reader_handler, { + object = LT_REPL_State_read(repl); + }); + }); + + if (reader_error == LT_NIL + && object != LT_INVALID){ + LT_Value result = LT_eval( + object, + base_environment, + NULL + ); + + LT_printer_print_object(result); + fputc('\n', stdout); + } + }); + } + ); + + if (returned_to_toplevel == LT_NIL){ + if (reader_error != LT_NIL){ + continue; + } + if (object == LT_INVALID){ + break; + } + } + } } LT_disable_KeyboardInterrupt(); return eval_status; diff --git a/src/classes/Class.c b/src/classes/Class.c index b46fb08..b7c8f99 100644 --- a/src/classes/Class.c +++ b/src/classes/Class.c @@ -38,6 +38,16 @@ static LT_Value atomic_object_slot_ref(LT_Class_Slot* slot, LT_Value object){ ); return atomic_load_explicit(val, memory_order_acquire); } +static LT_Value readonly_native_object_pointer_slot_ref( + LT_Class_Slot* slot, + LT_Value object +){ + void** pointer = (void**)( + (uint8_t*)LT_VALUE_POINTER_VALUE(object) + slot->offset + ); + + return *pointer == NULL ? LT_NIL : (LT_Value)(uintptr_t)*pointer; +} static void object_slot_set(LT_Class_Slot* slot, LT_Value object, LT_Value value){ LT_Value* val = (LT_Value*)( (uint8_t*)LT_VALUE_POINTER_VALUE(object) + slot->offset @@ -65,6 +75,10 @@ LT_SlotType LT_SlotType_ReadonlyAtomicObject = { .ref = atomic_object_slot_ref, .set = readonly_object_slot_set, }; +LT_SlotType LT_SlotType_ReadonlyNativeObjectPointer = { + .ref = readonly_native_object_pointer_slot_ref, + .set = readonly_object_slot_set, +}; static void invalidate_inline_caches(void){ LT_ilc_epoch_increment(); diff --git a/src/classes/Environment.c b/src/classes/Environment.c index 0b3c98c..cd98162 100644 --- a/src/classes/Environment.c +++ b/src/classes/Environment.c @@ -36,7 +36,11 @@ LT_InvocationContextKind LT_send_invocation_context = { }; static LT_Slot_Descriptor Environment_slots[] = { - {"parent", offsetof(LT_Environment, parent), <_SlotType_ReadonlyObject}, + { + "parent", + offsetof(LT_Environment, parent), + <_SlotType_ReadonlyNativeObjectPointer + }, LT_NULL_NATIVE_CLASS_SLOT_DESCRIPTOR }; diff --git a/src/classes/Package.c b/src/classes/Package.c index e2d806a..a27cd9a 100644 --- a/src/classes/Package.c +++ b/src/classes/Package.c @@ -30,6 +30,7 @@ struct LT_Package_s { LT_Package LT_Package_LISTTALK = {0}; LT_Package LT_Package_LISTTALK_IMPLEMENTATION = {0}; LT_Package LT_Package_LISTTALK_USER = {0}; +LT_Package LT_Package_LISTTALK_DEBUG = {0}; LT_Package LT_Package_KEYWORD = {0}; static LT_InlineHash package_table; static pthread_once_t package_table_once = PTHREAD_ONCE_INIT; @@ -674,6 +675,13 @@ static void predefined_packages_init_once(void){ <_Package_LISTTALK_USER ); + package_init(<_Package_LISTTALK_DEBUG, "ListTalk-debug"); + LT_StringHash_at_put( + package_table, + LT_Package_LISTTALK_DEBUG.name, + <_Package_LISTTALK_DEBUG + ); + package_init(<_Package_KEYWORD, "keyword"); LT_StringHash_at_put( package_table, @@ -691,6 +699,11 @@ static void predefined_packages_init_once(void){ <_Package_LISTTALK, NULL ); + package_use_package_initialized( + <_Package_LISTTALK_DEBUG, + <_Package_LISTTALK, + NULL + ); } static void ensure_predefined_packages_initialized(void){ diff --git a/src/classes/Restart.c b/src/classes/Restart.c index 1889ef5..a945f05 100644 --- a/src/classes/Restart.c +++ b/src/classes/Restart.c @@ -32,6 +32,13 @@ static LT_Value restart_string_or_nil(char* string){ return (LT_Value)(uintptr_t)LT_String_new_cstr(string); } +static LT_Value restart_name_or_nil(char* name){ + if (name == NULL){ + return LT_NIL; + } + return LT_Symbol_new_in(LT_PACKAGE_KEYWORD, name); +} + static LT_Value restart_argument_list_or_nil(char* arguments_text){ LT_Reader* reader; LT_ReaderStream* stream; @@ -58,7 +65,7 @@ static void Restart_materialize_static(LT_Restart* restart){ } primitive = LT_Primitive_from_value(restart->callable); - restart->name = restart_string_or_nil(LT_Primitive_name(primitive)); + restart->name = restart_name_or_nil(LT_Primitive_name(primitive)); restart->description = restart_string_or_nil(LT_Primitive_description(primitive)); restart->argument_list = restart_argument_list_or_nil( LT_Primitive_arguments(primitive) @@ -251,11 +258,9 @@ LT_Value LT_Restart_from_static(LT_Restart* restart){ void LT_Restart_init_static(LT_Restart* restart, LT_Primitive* primitive){ restart->callable = LT_Primitive_from_static(primitive); - restart->name = restart_string_or_nil(LT_Primitive_name(primitive)); - restart->description = restart_string_or_nil(LT_Primitive_description(primitive)); - restart->argument_list = restart_argument_list_or_nil( - LT_Primitive_arguments(primitive) - ); + restart->name = LT_INVALID; + restart->description = LT_INVALID; + restart->argument_list = LT_INVALID; } LT_Value LT_Restart_name(LT_Restart* restart){ diff --git a/src/debugger/debugger.c b/src/debugger/debugger.c new file mode 100644 index 0000000..2eeefc6 --- /dev/null +++ b/src/debugger/debugger.c @@ -0,0 +1,587 @@ +/* + * SPDX-License-Identifier: MIT + * Copyright (c) 2023 - 2026 Ales Hakl + */ + +#include + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include +#include +#include + +typedef struct { + LT_Value condition; + LT_Value backtrace; + LT_Value restarts; + LT_Environment* environment; + LT_Value debugger_hook; + LT_REPL_State* repl; + unsigned int level; +} DebuggerContext; + +typedef struct { + LT_Value object; + LT_Value slots; + int list_p; +} InspectorContext; + +static _Thread_local unsigned int debugger_level = 0; + +static LT_Value return_to_debugger_tag = LT_NIL; +static pthread_once_t return_to_debugger_tag_once = PTHREAD_ONCE_INIT; + +static void return_to_debugger_tag_init(void){ + return_to_debugger_tag = LT_Symbol_new_uninterned("return-to-debugger"); +} + +static LT_Value return_to_debugger_tag_value(void){ + pthread_once(&return_to_debugger_tag_once, return_to_debugger_tag_init); + return return_to_debugger_tag; +} + +LT_DEFINE_PRIMITIVE( + debugger_hook_primitive, + "debugger-hook", + "(condition debugger-hook)", + "Enter the interactive debugger for an unhandled condition." +){ + LT_Value cursor = arguments; + LT_Value condition; + LT_Value debugger_hook; + (void)invocation_context_kind; + (void)invocation_context_data; + (void)tail_call_unwind_marker; + + LT_OBJECT_ARG(cursor, condition); + LT_OBJECT_ARG(cursor, debugger_hook); + LT_ARG_END(cursor); + + LT_Debugger_break(condition, debugger_hook); + return LT_NIL; +} + +LT_DEFINE_PRIMITIVE_RESTART( + return_to_debugger_restart, + "return-to-debugger", + "()", + "Abort the current debugger evaluation and return to its REPL." +){ + LT_Value cursor = arguments; + (void)invocation_context_kind; + (void)invocation_context_data; + (void)tail_call_unwind_marker; + + LT_ARG_END(cursor); + LT_throw(return_to_debugger_tag_value(), LT_TRUE); +} + +LT_DEFINE_PRIMITIVE( + inspect_primitive, + "ListTalk-debug:inspect", + "(object)", + "Interactively inspect an object." +){ + LT_Value cursor = arguments; + LT_Value object; + (void)invocation_context_kind; + (void)invocation_context_data; + (void)tail_call_unwind_marker; + + LT_OBJECT_ARG(cursor, object); + LT_ARG_END(cursor); + LT_Debugger_inspect(object); + return object; +} + +LT_Value LT_Debugger_get_hook(void){ + return LT_Primitive_from_static(&debugger_hook_primitive); +} + +void LT_Debugger_enable(void){ + LT_set_debugger_hook(LT_Debugger_get_hook()); +} + +static const char* debugger_name_cstr(LT_Value value){ + if (LT_Symbol_p(value)){ + return LT_Symbol_name(LT_Symbol_from_value(value)); + } + if (LT_String_p(value)){ + return LT_String_value_cstr(LT_String_from_value(value)); + } + return NULL; +} + +static LT_Value list_at_1_based(LT_Value list, int64_t index){ + int64_t current = 1; + + while (LT_Pair_p(list)){ + if (current == index){ + return LT_car(list); + } + current++; + list = LT_cdr(list); + } + return LT_INVALID; +} + +static void debugger_print_restarts(LT_Value restarts){ + LT_Value cursor = restarts; + unsigned int index = 1; + + fputs("Restarts:\n", stdout); + if (cursor == LT_NIL){ + fputs(" (none)\n", stdout); + return; + } + while (LT_Pair_p(cursor)){ + LT_Restart* restart = LT_Restart_from_value(LT_car(cursor)); + LT_Value name = LT_Restart_name(restart); + LT_Value description = LT_Restart_description(restart); + + fprintf(stdout, " %u: ", index++); + LT_Value_debugPrintOn(name, stdout); + if (description != LT_NIL){ + fputs(" -- ", stdout); + if (LT_String_p(description)){ + fputs( + LT_String_value_cstr(LT_String_from_value(description)), + stdout + ); + } else { + LT_Value_debugPrintOn(description, stdout); + } + } + fputc('\n', stdout); + cursor = LT_cdr(cursor); + } +} + +static void debugger_print_condition_argument_name(LT_Value name){ + if (LT_Symbol_p(name)){ + fputs(LT_Symbol_name(LT_Symbol_from_value(name)), stdout); + } else if (LT_String_p(name)){ + fputs(LT_String_value_cstr(LT_String_from_value(name)), stdout); + } else { + LT_Value_debugPrintOn(name, stdout); + } +} + +static void debugger_print_entered_on(LT_Value object){ + fputs("Debugger entered on:\n", stdout); + if (!LT_Value_is_instance_of( + object, + (LT_Value)(uintptr_t)<_Condition_class + )){ + fputs(" ", stdout); + LT_Value_debugPrintOn(object, stdout); + fputc('\n', stdout); + return; + } + + { + LT_Value message = LT_Object_slot_ref( + object, + LT_Symbol_new_in(LT_PACKAGE_LISTTALK, "message") + ); + LT_Value arguments = LT_Object_slot_ref( + object, + LT_Symbol_new_in(LT_PACKAGE_LISTTALK, "args") + ); + + fputs(" ", stdout); + if (LT_String_p(message)){ + fputs(LT_String_value_cstr(LT_String_from_value(message)), stdout); + } else { + LT_Value_debugPrintOn(message, stdout); + } + fputc('\n', stdout); + + while (LT_Pair_p(arguments)){ + LT_Value name = LT_car(arguments); + + arguments = LT_cdr(arguments); + if (!LT_Pair_p(arguments)){ + break; + } + fputs(" ", stdout); + debugger_print_condition_argument_name(name); + fputs(": ", stdout); + LT_Value_debugPrintOn(LT_car(arguments), stdout); + fputc('\n', stdout); + arguments = LT_cdr(arguments); + } + } +} + +static void debugger_set_prompt(DebuggerContext* context){ + LT_REPL_State_set_prompt( + context->repl, + LT_sprintf("debug[%u]> ", context->level) + ); +} + +static void debugger_print_banner(DebuggerContext* context){ + debugger_print_entered_on(context->condition); + fputc('\n', stdout); + if (LT_stack_trace_depth() <= 1){ + fputs("Backtrace:\n (empty)\n", stdout); + } else { + LT_stack_trace_print_skipping(stdout, 1); + } + fputc('\n', stdout); + debugger_print_restarts(context->restarts); +} + +static LT_Value debugger_restart_selected(LT_Value input, LT_Value restarts){ + LT_Value cursor; + + if (LT_SmallInteger_p(input)){ + return list_at_1_based(restarts, LT_SmallInteger_value(input)); + } + if (!LT_Symbol_p(input) + || LT_Symbol_package(LT_Symbol_from_value(input)) != LT_PACKAGE_KEYWORD){ + return LT_INVALID; + } + + cursor = restarts; + while (LT_Pair_p(cursor)){ + LT_Value restart_value = LT_car(cursor); + const char* name = debugger_name_cstr( + LT_Restart_name(LT_Restart_from_value(restart_value)) + ); + + if (name != NULL + && strcmp(name, LT_Symbol_name(LT_Symbol_from_value(input))) == 0){ + return restart_value; + } + cursor = LT_cdr(cursor); + } + return LT_INVALID; +} + +static int debugger_restart_shorthand_p(LT_Value input){ + return LT_Pair_p(input) + && LT_Symbol_p(LT_car(input)) + && LT_Symbol_package(LT_Symbol_from_value(LT_car(input))) + == LT_PACKAGE_KEYWORD; +} + +static LT_Value debugger_prompt_restart_arguments( + DebuggerContext* context, + LT_Restart* restart +){ + LT_ListBuilder* builder = LT_ListBuilder_new(); + LT_Value cursor = LT_Restart_argument_list(restart); + + while (LT_Pair_p(cursor)){ + LT_String* printed_argument = LT_Value_asString(LT_car(cursor)); + LT_Value argument; + + LT_REPL_State_set_prompt( + context->repl, + LT_sprintf( + "debug[%u] %s> ", + context->level, + LT_String_value_cstr(printed_argument) + ) + ); + argument = LT_REPL_State_read(context->repl); + if (argument == LT_INVALID){ + debugger_set_prompt(context); + return LT_INVALID; + } + LT_ListBuilder_append(builder, argument); + cursor = LT_cdr(cursor); + } + debugger_set_prompt(context); + return LT_ListBuilder_value(builder); +} + +static LT_Value debugger_eval_argument_list( + LT_Value expressions, + LT_Environment* environment +){ + LT_ListBuilder* builder = LT_ListBuilder_new(); + LT_Value cursor = expressions; + + while (cursor != LT_NIL){ + if (!LT_Pair_p(cursor)){ + LT_error("Debugger restart shorthand expects proper argument list"); + } + LT_ListBuilder_append(builder, LT_eval(LT_car(cursor), environment, NULL)); + cursor = LT_cdr(cursor); + } + return LT_ListBuilder_value(builder); +} + +static int debugger_eval_restart_arguments( + DebuggerContext* context, + LT_Value expressions, + LT_Value* arguments_out +){ + LT_Value returned_to_debugger = LT_NIL; + + LT_CATCH(return_to_debugger_tag_value(), returned_to_debugger, { + LT_RESTART_BIND(LT_Restart_from_static(&return_to_debugger_restart), { + LT_WITH_DEBUGGER_HOOK(context->debugger_hook, { + *arguments_out = debugger_eval_argument_list( + expressions, + context->environment + ); + }); + }); + }); + if (returned_to_debugger != LT_NIL){ + debugger_print_banner(context); + debugger_set_prompt(context); + } + return returned_to_debugger == LT_NIL; +} + +static int debugger_keyword_selected(LT_Value input, const char* name){ + return LT_Symbol_p(input) + && LT_Symbol_package(LT_Symbol_from_value(input)) == LT_PACKAGE_KEYWORD + && strcmp( + LT_Symbol_name(LT_Symbol_from_value(input)), + name + ) == 0; +} + +static void debugger_repl_object(LT_Value object, void* opaque){ + DebuggerContext* context = opaque; + int restart_shorthand = debugger_restart_shorthand_p(object); + LT_Value restart_designator = restart_shorthand ? LT_car(object) : object; + LT_Value restart_value = debugger_restart_selected( + restart_designator, + context->restarts + ); + LT_Value returned_to_debugger = LT_NIL; + + if (debugger_keyword_selected(object, "inspect-condition")){ + LT_Debugger_inspect(context->condition); + return; + } + if (debugger_keyword_selected(object, "inspect-backtrace")){ + LT_Debugger_inspect(context->backtrace); + return; + } + if (debugger_keyword_selected(object, "show")){ + debugger_print_banner(context); + return; + } + + if (restart_value != LT_INVALID){ + LT_Restart* restart = LT_Restart_from_value(restart_value); + LT_Value restart_arguments = LT_NIL; + + if (restart_shorthand){ + if (!debugger_eval_restart_arguments( + context, + LT_cdr(object), + &restart_arguments + )){ + return; + } + } else if (LT_Restart_argument_list(restart) != LT_NIL){ + restart_arguments = debugger_prompt_restart_arguments( + context, + restart + ); + if (restart_arguments == LT_INVALID){ + return; + } + } + LT_apply( + LT_Restart_callable(restart), + restart_arguments, + LT_NIL, + LT_NIL, + NULL + ); + return; + } + + if (restart_shorthand + || LT_SmallInteger_p(object) + || (LT_Symbol_p(object) + && LT_Symbol_package(LT_Symbol_from_value(object)) + == LT_PACKAGE_KEYWORD)){ + fputs("No such restart.\n", stdout); + return; + } + + LT_CATCH(return_to_debugger_tag_value(), returned_to_debugger, { + LT_RESTART_BIND(LT_Restart_from_static(&return_to_debugger_restart), { + LT_WITH_DEBUGGER_HOOK(context->debugger_hook, { + object = LT_eval(object, context->environment, NULL); + }); + }); + }); + if (returned_to_debugger != LT_NIL){ + debugger_print_banner(context); + debugger_set_prompt(context); + return; + } + LT_Value_debugPrintOn(object, stdout); + fputc('\n', stdout); +} + +void LT_Debugger_break(LT_Value condition, LT_Value debugger_hook){ + LT_REPL_State* repl = LT_REPL_State_new(); + LT_Value backtrace = LT_stack_trace_capture(); + DebuggerContext context = { + .condition = condition, + .backtrace = LT_Pair_p(backtrace) ? LT_cdr(backtrace) : LT_NIL, + .restarts = LT_current_restarts(), + .environment = LT_new_base_environment(), + .debugger_hook = debugger_hook, + .repl = repl, + .level = debugger_level + 1 + }; + + LT_Environment_bind( + context.environment, + LT_Symbol_new_in(LT_PACKAGE_LISTTALK_DEBUG, "condition"), + condition, + LT_ENV_BINDING_FLAG_CONSTANT + ); + LT_Environment_bind( + context.environment, + LT_Symbol_new_in(LT_PACKAGE_LISTTALK_DEBUG, "inspect"), + LT_Primitive_from_static(&inspect_primitive), + LT_ENV_BINDING_FLAG_CONSTANT + ); + LT_Environment_bind( + context.environment, + LT_Symbol_new_in(LT_PACKAGE_LISTTALK_DEBUG, "backtrace"), + context.backtrace, + LT_ENV_BINDING_FLAG_CONSTANT + ); + + debugger_level++; + LT_UNWIND_PROTECT({ + debugger_print_banner(&context); + debugger_set_prompt(&context); + LT_WITH_PACKAGE(LT_PACKAGE_LISTTALK_DEBUG, { + LT_REPL_State_loop(repl, debugger_repl_object, &context); + }); + }, { + debugger_level--; + }); +} + +static void inspector_print(InspectorContext* context){ + LT_Value cursor; + unsigned int index = 1; + + fputs("Object: ", stdout); + LT_Value_debugPrintOn(context->object, stdout); + fputs("\n\n", stdout); + + context->list_p = LT_List_proper_p(context->object); + context->slots = context->list_p + ? context->object + : LT_Class_slots(LT_Value_class(context->object)); + cursor = context->slots; + if (cursor == LT_NIL){ + fprintf( + stdout, + "%s: (none)\n\n", + context->list_p ? "Elements" : "Slots" + ); + return; + } + + fprintf(stdout, "%s:\n", context->list_p ? "Elements" : "Slots"); + while (LT_Pair_p(cursor)){ + LT_Value entry = LT_car(cursor); + + fprintf(stdout, " %u: ", index++); + if (context->list_p){ + LT_Value_debugPrintOn(entry, stdout); + } else { + LT_Value_debugPrintOn(entry, stdout); + fputs(" = ", stdout); + LT_Value_debugPrintOn( + LT_Object_slot_ref(context->object, entry), + stdout + ); + } + fputc('\n', stdout); + cursor = LT_cdr(cursor); + } + fputc('\n', stdout); +} + +static LT_Value inspector_selected_slot(LT_Value input, LT_Value slots){ + LT_Value cursor; + + if (LT_SmallInteger_p(input)){ + return list_at_1_based(slots, LT_SmallInteger_value(input)); + } + if (!LT_Symbol_p(input)){ + return LT_INVALID; + } + + cursor = slots; + while (LT_Pair_p(cursor)){ + LT_Value slot_name = LT_car(cursor); + + if (LT_Symbol_p(slot_name) + && strcmp( + LT_Symbol_name(LT_Symbol_from_value(input)), + LT_Symbol_name(LT_Symbol_from_value(slot_name)) + ) == 0){ + return slot_name; + } + cursor = LT_cdr(cursor); + } + return LT_INVALID; +} + +static void inspector_repl_object(LT_Value input, void* opaque){ + InspectorContext* context = opaque; + LT_Value slot_name = context->list_p && !LT_SmallInteger_p(input) + ? LT_INVALID + : inspector_selected_slot(input, context->slots); + LT_Value selected_object; + + if (slot_name == LT_INVALID){ + fprintf( + stdout, + "No such %s.\n", + context->list_p ? "element" : "slot" + ); + return; + } + selected_object = context->list_p + ? slot_name + : LT_Object_slot_ref(context->object, slot_name); + LT_Debugger_inspect(selected_object); + inspector_print(context); +} + +void LT_Debugger_inspect(LT_Value object){ + LT_REPL_State* repl = LT_REPL_State_new(); + InspectorContext context = { + .object = object, + .slots = LT_NIL, + .list_p = 0 + }; + + inspector_print(&context); + LT_REPL_State_set_prompt(repl, "inspect> "); + LT_REPL_State_loop(repl, inspector_repl_object, &context); +} diff --git a/src/vm/conditions.c b/src/vm/conditions.c index fd60e28..d4593f6 100644 --- a/src/vm/conditions.c +++ b/src/vm/conditions.c @@ -16,6 +16,23 @@ void LT_signal(LT_Value condition){ } } +void LT_set_debugger_hook(LT_Value hook){ + LT_thread_state()->debugger_hook = hook; +} + +void LT_invoke_debugger(LT_Value condition){ + LT_ThreadState* state = LT_thread_state(); + LT_Value hook = state->debugger_hook; + + if (hook == LT_NIL){ + return; + } + + LT_WITH_DEBUGGER_HOOK(LT_NIL, { + (void)LT_applyv(hook, condition, hook, LT_INVALID); + }); +} + LT_Value LT_current_restarts(void){ LT_ListBuilder* builder = LT_ListBuilder_new(); LT_RestartFrame* frame = LT__restart_stack; diff --git a/src/vm/error.c b/src/vm/error.c index 9c3931c..6fdc9fd 100644 --- a/src/vm/error.c +++ b/src/vm/error.c @@ -4,10 +4,14 @@ */ #include +#include +#include +#include #include #include #include #include +#include #include #include @@ -15,6 +19,28 @@ #include #include +static LT_Value cerror_continue_tag(void){ + return LT_Symbol_new_in( + LT_PACKAGE_LISTTALK_IMPLEMENTATION, + "cerror-continue" + ); +} + +LT_DEFINE_PRIMITIVE_RESTART( + cerror_continue_restart, + "continue", + "()", + "Continue from the correctable error." +){ + LT_Value cursor = arguments; + (void)invocation_context_kind; + (void)invocation_context_data; + (void)tail_call_unwind_marker; + + LT_ARG_END(cursor); + LT_throw(cerror_continue_tag(), LT_TRUE); +} + void LT_print_backtrace(FILE* stream){ LT_stack_trace_print(stream); } @@ -27,6 +53,7 @@ void _Noreturn LT_error_impl(const char* message, ...) { condition = LT_Condition_vnew(<_Error_class, message, args); va_end(args); LT_signal(condition); + LT_invoke_debugger(condition); fprintf(stderr, "Unrecoverable error: %s\n", message); LT_print_backtrace(stderr); #ifdef __APPLE__ @@ -36,10 +63,36 @@ void _Noreturn LT_error_impl(const char* message, ...) { #endif } +void LT_cerror_impl(const char* message, ...){ + LT_Value condition; + LT_Value continued = LT_NIL; + va_list args; + + va_start(args, message); + condition = LT_Condition_vnew(<_Error_class, message, args); + va_end(args); + + LT_CATCH(cerror_continue_tag(), continued, { + LT_RESTART_BIND(LT_Restart_from_static(&cerror_continue_restart), { + LT_signal(condition); + LT_invoke_debugger(condition); + fprintf(stderr, "Unrecoverable error: %s\n", message); + LT_print_backtrace(stderr); +#ifdef __APPLE__ + _exit(1); /* Use _exit on macOS to avoid Crash Reporter */ +#else + abort(); +#endif + }); + }); + (void)continued; +} + void _Noreturn LT_system_error(const char* message, int errnum){ LT_Value condition = LT_SystemError_new(message, errnum, LT_NIL); LT_signal(condition); + LT_invoke_debugger(condition); fprintf( stderr, "Unrecoverable system error: %s: %s\n", @@ -59,6 +112,7 @@ void _Noreturn LT_subclass_responsibility_error(void){ LT_Value condition = LT_SubclassResponsibilityError(message); LT_signal(condition); + LT_invoke_debugger(condition); fprintf(stderr, "Unrecoverable subclass responsibility error: %s\n", message); LT_print_backtrace(stderr); #ifdef __APPLE__ diff --git a/src/vm/eval.c b/src/vm/eval.c index 2294443..8b1fafc 100644 --- a/src/vm/eval.c +++ b/src/vm/eval.c @@ -9,6 +9,7 @@ #include #include #include +#include #include #include #include @@ -16,8 +17,10 @@ #include #include #include +#include #include #include +#include #include #include @@ -49,6 +52,63 @@ static LT_Value send_does_not_understand( ); static LT_Value copy_message_arguments(LT_Value arguments); +static LT_Value unbound_symbol_use_value_tag(void){ + return LT_Symbol_new_in( + LT_PACKAGE_LISTTALK_IMPLEMENTATION, + "unbound-symbol-use-value" + ); +} + +static LT_Value unbound_symbol_define_variable_tag(void){ + return LT_Symbol_new_in( + LT_PACKAGE_LISTTALK_IMPLEMENTATION, + "unbound-symbol-define-variable" + ); +} + +static LT_Environment* top_level_environment(LT_Environment* environment){ + LT_Environment* parent; + + while ((parent = LT_Environment_parent(environment)) != NULL){ + environment = parent; + } + return environment; +} + +LT_DEFINE_PRIMITIVE_RESTART( + unbound_symbol_use_value_restart, + "use-value", + "(value)", + "Use a supplied value for the unbound symbol." +){ + LT_Value cursor = arguments; + LT_Value value; + (void)invocation_context_kind; + (void)invocation_context_data; + (void)tail_call_unwind_marker; + + LT_OBJECT_ARG(cursor, value); + LT_ARG_END(cursor); + LT_throw(unbound_symbol_use_value_tag(), value); +} + +LT_DEFINE_PRIMITIVE_RESTART( + unbound_symbol_define_variable_restart, + "define-variable", + "(value)", + "Define the unbound symbol in its top-level environment using a supplied value." +){ + LT_Value cursor = arguments; + LT_Value value; + (void)invocation_context_kind; + (void)invocation_context_data; + (void)tail_call_unwind_marker; + + LT_OBJECT_ARG(cursor, value); + LT_ARG_END(cursor); + LT_throw(unbound_symbol_define_variable_tag(), value); +} + static void check_pending_signal(void){ LT_ThreadState* state = LT__thread_state; LT_Value signal; @@ -813,19 +873,43 @@ static LT_Value eval_symbol(LT_Value symbol, LT_Environment* environment){ if (!LT_Environment_lookup(environment, symbol, &value, NULL)){ LT_String* printed_symbol; + LT_Value replacement = LT_INVALID; + LT_Value definition = LT_INVALID; if (LT_Symbol_package(LT_Symbol_from_value(symbol)) == LT_PACKAGE_KEYWORD){ return symbol; } printed_symbol = LT_Value_asString(symbol); - LT_error( - LT_sprintf( - "Unbound symbol: %s", - LT_String_value_cstr(printed_symbol) - ), - "symbol", symbol - ); + LT_CATCH(unbound_symbol_use_value_tag(), replacement, { + LT_CATCH(unbound_symbol_define_variable_tag(), definition, { + LT_RESTART_BIND( + LT_Restart_from_static( + &unbound_symbol_define_variable_restart + ), { + LT_RESTART_BIND( + LT_Restart_from_static(&unbound_symbol_use_value_restart), { + LT_error( + LT_sprintf( + "Unbound symbol: %s", + LT_String_value_cstr(printed_symbol) + ), + "symbol", symbol + ); + }); + }); + }); + if (definition != LT_INVALID){ + LT_Environment_bind( + top_level_environment(environment), + symbol, + definition, + 0 + ); + replacement = definition; + } + }); + return replacement; } return value; } diff --git a/src/vm/reader.c b/src/vm/reader.c index 5e4cdcd..a420a6d 100644 --- a/src/vm/reader.c +++ b/src/vm/reader.c @@ -267,6 +267,7 @@ static void _Noreturn reader_signal_error( ); LT_signal(condition); + LT_invoke_debugger(condition); fprintf(stderr, "Unrecoverable error: %s\n", message); LT_print_backtrace(stderr); #ifdef __APPLE__ diff --git a/src/vm/stack_trace.c b/src/vm/stack_trace.c index 70da42e..0600682 100644 --- a/src/vm/stack_trace.c +++ b/src/vm/stack_trace.c @@ -145,12 +145,17 @@ LT_Value LT_stack_trace_capture(void){ return LT_ListBuilder_value(builder); } -void LT_stack_trace_print(FILE* stream){ +void LT_stack_trace_print_skipping(FILE* stream, unsigned int skip){ LT_Value snapshot = LT_stack_trace_capture(); LT_Value cursor = snapshot; unsigned int index = 0; - if (snapshot == LT_NIL){ + while (skip > 0 && LT_Pair_p(cursor)){ + cursor = LT_cdr(cursor); + skip--; + } + + if (cursor == LT_NIL){ return; } @@ -188,3 +193,7 @@ void LT_stack_trace_print(FILE* stream){ cursor = LT_cdr(cursor); } } + +void LT_stack_trace_print(FILE* stream){ + LT_stack_trace_print_skipping(stream, 0); +} diff --git a/src/vm/thread_state.c b/src/vm/thread_state.c index c3ff954..f50565e 100644 --- a/src/vm/thread_state.c +++ b/src/vm/thread_state.c @@ -145,6 +145,7 @@ LT_ThreadState* LT_thread_state_slow(void) if (state == NULL){ state = GC_MALLOC_UNCOLLECTABLE(sizeof(LT_ThreadState)); memset(state, 0, sizeof(LT_ThreadState)); + state->debugger_hook = LT_NIL; atomic_init(&state->pending_signal, LT_INVALID); pthread_setspecific(LT_thread_state_key, state); } diff --git a/tests/c_api_test.c b/tests/c_api_test.c index 92e33c2..c25c88a 100644 --- a/tests/c_api_test.c +++ b/tests/c_api_test.c @@ -642,6 +642,24 @@ static int test_environment_invocation_context_lookup_walks_parent_frames(void){ ); } +static int test_environment_parent_slot_maps_null_to_nil(void){ + LT_Environment* root = LT_Environment_new(NULL, LT_NIL, LT_NIL); + LT_Environment* child = LT_Environment_new(root, LT_NIL, LT_NIL); + LT_Value parent_slot = LT_Symbol_new("parent"); + + if (expect( + LT_Object_slot_ref((LT_Value)(uintptr_t)root, parent_slot) == LT_NIL, + "root environment parent slot exposes null as nil" + )){ + return 1; + } + return expect( + LT_Object_slot_ref((LT_Value)(uintptr_t)child, parent_slot) + == (LT_Value)(uintptr_t)root, + "child environment parent slot exposes its parent object" + ); +} + static int test_send_passes_invocation_context_kind_to_primitive_method(void){ LT_Value selector = LT_Symbol_new_in(LT_PACKAGE_KEYWORD, "invocation-context-kind"); LT_Value result; @@ -2053,13 +2071,16 @@ static int test_static_primitive_restart_macro(void){ LT_Value argument_list = LT_Restart_argument_list(restart_object); LT_Value callable = LT_Restart_callable(restart_object); LT_Value applied; + LT_Value invoked = LT_NIL; int failed = 0; failed += expect( - LT_String_p(name) - && strcmp(LT_String_value_cstr(LT_String_from_value(name)), + LT_Symbol_p(name) + && LT_Symbol_package(LT_Symbol_from_value(name)) + == LT_PACKAGE_KEYWORD + && strcmp(LT_Symbol_name(LT_Symbol_from_value(name)), "test-restart") == 0, - "static Restart name comes from primitive metadata" + "static Restart name is a keyword from primitive metadata" ); failed += expect( LT_String_p(description) @@ -2089,6 +2110,22 @@ static int test_static_primitive_restart_macro(void){ LT_Value_is_fixnum(applied) && LT_SmallInteger_value(applied) == 42, "static Restart callable invokes primitive implementation" ); + LT_RESTART_BIND(restart, { + failed += expect( + LT_find_restart( + LT_Symbol_new_in(LT_PACKAGE_KEYWORD, "test-restart") + ) == restart, + "static Restart is found by its keyword name" + ); + invoked = LT_invoke_restart( + LT_Symbol_new_in(LT_PACKAGE_KEYWORD, "test-restart"), + LT_cons(LT_SmallInteger_new(43), LT_NIL) + ); + }); + failed += expect( + LT_Value_is_fixnum(invoked) && LT_SmallInteger_value(invoked) == 43, + "static Restart is invoked by its keyword name" + ); return failed; } @@ -4328,6 +4365,7 @@ int main(void){ RUN_TEST(test_register_posix_signal_schedules_pending_signal); RUN_TEST(test_send_primitive_uses_precedence_lookup_and_cache); RUN_TEST(test_environment_invocation_context_lookup_walks_parent_frames); + RUN_TEST(test_environment_parent_slot_maps_null_to_nil); RUN_TEST(test_send_passes_invocation_context_kind_to_primitive_method); RUN_TEST(test_send_passes_next_precedence_tail_as_invocation_context_data); RUN_TEST(test_super_send_c_api_uses_explicit_precedence_list); diff --git a/tests/conditions_test.c b/tests/conditions_test.c index a7c067e..951a6d6 100644 --- a/tests/conditions_test.c +++ b/tests/conditions_test.c @@ -47,6 +47,30 @@ static LT_Value g_error_test_tag = LT_NIL; static LT_Value g_backtrace_test_tag = LT_NIL; static char* g_backtrace_output = NULL; static size_t g_backtrace_output_length = 0; +static int g_debugger_hook_calls = 0; +static LT_Value g_debugger_hook_condition = LT_NIL; +static LT_Value g_debugger_hook_original = LT_NIL; + +static LT_Value debugger_hook_impl( + LT_Value arguments, + LT_Value invocation_context_kind, + LT_Value invocation_context_data, + LT_TailCallUnwindMarker* tail_call_unwind_marker +){ + LT_Value cursor = arguments; + (void)invocation_context_kind; + (void)invocation_context_data; + (void)tail_call_unwind_marker; + + LT_OBJECT_ARG(cursor, g_debugger_hook_condition); + LT_OBJECT_ARG(cursor, g_debugger_hook_original); + LT_ARG_END(cursor); + g_debugger_hook_calls++; + + /* The hook must already be disabled while it is running. */ + LT_invoke_debugger(g_debugger_hook_condition); + return LT_NIL; +} static LT_Value read_one_with_source_file(const char* source, const char* source_file){ LT_Reader* reader = LT_Reader_new( @@ -194,6 +218,73 @@ static LT_Value make_test_restart(LT_Value name){ ); } +static LT_Value use_value_for_unbound_symbol_handler_impl( + LT_Value arguments, + LT_Value invocation_context_kind, + LT_Value invocation_context_data, + LT_TailCallUnwindMarker* tail_call_unwind_marker +){ + LT_Value cursor = arguments; + LT_Value condition; + (void)invocation_context_kind; + (void)invocation_context_data; + (void)tail_call_unwind_marker; + + LT_OBJECT_ARG(cursor, condition); + LT_ARG_END(cursor); + (void)condition; + return LT_invoke_restart( + LT_Symbol_new_in(LT_PACKAGE_KEYWORD, "use-value"), + LT_cons(LT_SmallInteger_new(41), LT_NIL) + ); +} + +static LT_Value define_variable_for_unbound_symbol_handler_impl( + LT_Value arguments, + LT_Value invocation_context_kind, + LT_Value invocation_context_data, + LT_TailCallUnwindMarker* tail_call_unwind_marker +){ + LT_Value cursor = arguments; + LT_Value condition; + (void)invocation_context_kind; + (void)invocation_context_data; + (void)tail_call_unwind_marker; + + LT_OBJECT_ARG(cursor, condition); + LT_ARG_END(cursor); + (void)condition; + return LT_invoke_restart( + LT_Symbol_new_in(LT_PACKAGE_KEYWORD, "define-variable"), + LT_cons(LT_SmallInteger_new(41), LT_NIL) + ); +} + +static LT_Value g_cerror_condition = LT_NIL; +static int g_cerror_continue_restart_seen = 0; + +static LT_Value continue_cerror_handler_impl( + LT_Value arguments, + LT_Value invocation_context_kind, + LT_Value invocation_context_data, + LT_TailCallUnwindMarker* tail_call_unwind_marker +){ + LT_Value cursor = arguments; + (void)invocation_context_kind; + (void)invocation_context_data; + (void)tail_call_unwind_marker; + + LT_OBJECT_ARG(cursor, g_cerror_condition); + LT_ARG_END(cursor); + g_cerror_continue_restart_seen = + LT_find_restart(LT_Symbol_new_in(LT_PACKAGE_KEYWORD, "continue")) + != LT_NIL; + return LT_invoke_restart( + LT_Symbol_new_in(LT_PACKAGE_KEYWORD, "continue"), + LT_NIL + ); +} + static int test_signal_invokes_bound_handler_with_condition_value(void){ LT_Value condition = LT_Symbol_new("condition-a"); LT_Value inner_handler = LT_Primitive_new( @@ -563,6 +654,146 @@ static int test_unbound_symbol_error_identifies_symbol(void){ ); } +static int test_unbound_symbol_use_value_restart_resumes_evaluation(void){ + LT_Environment* env = LT_new_base_environment(); + LT_Value handler = LT_Primitive_new( + "use-value-for-unbound-symbol-handler", + "(condition)", + "invokes the unbound symbol use-value restart", + use_value_for_unbound_symbol_handler_impl + ); + LT_Value result = LT_NIL; + + LT_HANDLER_BIND(handler, { + result = LT_eval( + read_one_with_source_file("(+ missing-name 1)", "fixtures/unbound.lt"), + env, + NULL + ); + }); + + if (expect( + LT_Value_is_fixnum(result) && LT_SmallInteger_value(result) == 42, + "unbound symbol :use-value restart resumes surrounding evaluation" + )){ + return 1; + } + return expect( + LT_find_restart(LT_Symbol_new_in(LT_PACKAGE_KEYWORD, "use-value")) + == LT_NIL, + "unbound symbol :use-value restart is removed after evaluation" + ); +} + +static int test_unbound_symbol_define_variable_restart_defines_at_top_level(void){ + LT_Environment* env = LT_new_base_environment(); + LT_Value handler = LT_Primitive_new( + "define-variable-for-unbound-symbol-handler", + "(condition)", + "invokes the unbound symbol define-variable restart", + define_variable_for_unbound_symbol_handler_impl + ); + LT_Value result = LT_NIL; + LT_Value defined = LT_NIL; + + LT_HANDLER_BIND(handler, { + result = LT_eval( + read_one_with_source_file( + "((lambda () (+ missing-name 1)))", + "fixtures/unbound.lt" + ), + env, + NULL + ); + }); + + if (expect( + LT_Value_is_fixnum(result) && LT_SmallInteger_value(result) == 42, + ":define-variable restart resumes surrounding evaluation" + )){ + return 1; + } + if (expect( + LT_Environment_lookup(env, LT_Symbol_new("missing-name"), &defined, NULL), + ":define-variable restart creates a top-level binding" + )){ + return 1; + } + return expect( + LT_Value_is_fixnum(defined) && LT_SmallInteger_value(defined) == 41, + ":define-variable top-level binding has the supplied value" + ); +} + +static int test_cerror_continue_restart_resumes_call(void){ + LT_Value handler = LT_Primitive_new( + "continue-cerror-handler", + "(condition)", + "invokes the cerror continue restart", + continue_cerror_handler_impl + ); + LT_Value message; + LT_Value args; + int resumed = 0; + + g_cerror_condition = LT_NIL; + g_cerror_continue_restart_seen = 0; + LT_HANDLER_BIND(handler, { + LT_cerror("Correctable error", "value", LT_SmallInteger_new(17)); + resumed = 1; + }); + + if (expect(resumed, "LT_cerror returns after :continue restart")){ + return 1; + } + if (expect( + g_cerror_continue_restart_seen, + "LT_cerror establishes :continue while signaling" + )){ + return 1; + } + if (expect( + LT_Value_class(g_cerror_condition) == <_Error_class, + "LT_cerror emits Error condition" + )){ + return 1; + } + message = LT_Object_slot_ref( + g_cerror_condition, + LT_Symbol_new("message") + ); + if (expect( + strcmp( + LT_String_value_cstr(LT_String_from_value(message)), + "Correctable error" + ) == 0, + "LT_cerror preserves condition message" + )){ + return 1; + } + args = LT_Object_slot_ref(g_cerror_condition, LT_Symbol_new("args")); + if (expect( + LT_Pair_p(args) + && LT_car(args) == LT_Symbol_new("value") + && LT_Pair_p(LT_cdr(args)), + "LT_cerror preserves condition argument plist" + )){ + return 1; + } + if (expect( + LT_Value_is_fixnum(LT_car(LT_cdr(args))) + && LT_SmallInteger_value(LT_car(LT_cdr(args))) == 17, + "LT_cerror preserves condition argument value" + )){ + return 1; + } + return expect( + LT_find_restart(LT_Symbol_new_in(LT_PACKAGE_KEYWORD, "continue")) + == LT_NIL, + "LT_cerror removes :continue after resuming" + ); +} + static int test_backtrace_prints_source_locations_and_expansion_chain(void){ LT_Environment* env = LT_new_base_environment(); LT_Value caught = LT_NIL; @@ -980,6 +1211,50 @@ static int test_filestream_open_failure_signals_system_error(void){ ); } +static int test_debugger_hook_is_scoped_and_disabled_during_invocation(void){ + LT_Value condition = LT_Condition("debugger hook test"); + LT_Value hook = LT_Primitive_new( + "test-debugger-hook", + "(condition original-hook)", + "Record debugger hook invocation.", + debugger_hook_impl + ); + + g_debugger_hook_calls = 0; + g_debugger_hook_condition = LT_NIL; + g_debugger_hook_original = LT_NIL; + + LT_WITH_DEBUGGER_HOOK(hook, { + LT_invoke_debugger(condition); + LT_invoke_debugger(condition); + }); + + if (expect( + g_debugger_hook_calls == 2, + "debugger hook is restored after each invocation" + )){ + return 1; + } + if (expect( + g_debugger_hook_condition == condition, + "debugger hook receives condition" + )){ + return 1; + } + if (expect( + g_debugger_hook_original == hook, + "debugger hook receives its original value" + )){ + return 1; + } + + LT_invoke_debugger(condition); + return expect( + g_debugger_hook_calls == 2, + "debugger hook scope restores the previous nil hook" + ); +} + int main(void){ int failures = 0; @@ -995,6 +1270,9 @@ int main(void){ failures += test_find_and_invoke_restart_use_eq_name_matching(); failures += test_lt_error_signals_condition_to_handlers(); failures += test_unbound_symbol_error_identifies_symbol(); + failures += test_unbound_symbol_use_value_restart_resumes_evaluation(); + failures += test_unbound_symbol_define_variable_restart_defines_at_top_level(); + failures += test_cerror_continue_restart_resumes_call(); failures += test_backtrace_prints_source_locations_and_expansion_chain(); failures += test_error_builder_collects_named_arguments(); failures += test_subclass_responsibility_error_builder(); @@ -1008,6 +1286,7 @@ int main(void){ failures += test_stream_abstract_methods_signal_specific_error(); failures += test_system_error_preserves_errno_and_strerror_message(); failures += test_filestream_open_failure_signals_system_error(); + failures += test_debugger_hook_is_scoped_and_disabled_during_invocation(); if (failures == 0){ puts("conditions tests passed"); diff --git a/tests/listtalk_cli_test.py b/tests/listtalk_cli_test.py index 049f299..cb66d50 100644 --- a/tests/listtalk_cli_test.py +++ b/tests/listtalk_cli_test.py @@ -2,8 +2,12 @@ # SPDX-License-Identifier: MIT # Copyright (c) 2023 - 2026 Ales Hakl +import os +import pty +import select import subprocess import sys +import time def run_case(exe, args, expected_stdout): @@ -54,11 +58,178 @@ def run_failure_case(exe, args): return 0 +def run_interactive_syntax_error_case(exe): + completed = subprocess.run( + [exe], + input=")\n(+ 4 5)\n", + check=False, + stdout=subprocess.PIPE, + stderr=subprocess.PIPE, + text=True, + ) + if completed.returncode != 0: + sys.stderr.write( + "FAIL: interactive syntax recovery exited with {0}\n{1}".format( + completed.returncode, + completed.stderr, + ) + ) + return 1 + if "Debugger entered on:" in completed.stdout or "debug> " in completed.stdout: + sys.stderr.write( + "FAIL: syntax error unexpectedly entered debugger\n{0}".format( + completed.stdout + ) + ) + return 1 + if "Error: # ")) + os.write(master, b"missing-name\r") + transcript.extend(read_pty_until(master, b"debug[1]> ")) + os.write(master, b'(error "nested")\r') + transcript.extend(read_pty_until(master, b"debug[2]> ")) + os.write(master, b":return-to-debugger\r") + transcript.extend(read_pty_until(master, b"debug[1]> ")) + os.write(master, b"(:use-value 1)\r") + transcript.extend(read_pty_until(master, b"listtalk> ")) + os.write(master, b"\x04") + transcript.extend(drain_pty(master)) + process.wait(timeout=5) + except (OSError, subprocess.TimeoutExpired): + process.kill() + process.wait() + finally: + os.close(master) + + required = (b"debug[1]> ", b"debug[2]> ") + if any(item not in transcript for item in required): + sys.stderr.write( + "FAIL: nested debugger prompts\n{0}".format( + transcript.decode(errors="replace") + ) + ) + return 1 + return 0 + + def main(): exe, build_dir, fixture_dir = sys.argv[1:4] failures = 0 failures += run_case(exe, ["-E", "(+ 1 2)"], "3\n") + failures += run_case(exe, ["-d", "-E", "(+ 2 3)"], "5\n") + failures += run_case(exe, ["--debug", "-E", "(+ 3 4)"], "7\n") failures += run_case( exe, ["-e", "(define cli-side-effect 41)", "-E", "(+ cli-side-effect 1)"], @@ -83,6 +254,38 @@ def main(): exe, ["--no-std-lib", "-r", "test-module-foo", "-L", fixture_dir], ) + failures += run_interactive_syntax_error_case(exe) + failures += run_debugger_restart_case( + exe, + "missing-name\n(:use-value (+ 20 21))\n", + "41", + "debugger restart shorthand", + ) + failures += run_debugger_restart_case( + exe, + "missing-name\n:use-value\n(+ 20 21)\n", + "(+ 20 21)", + "interactive debugger restart arguments", + ) + failures += run_debugger_restart_case( + exe, + "missing-name\n1\n(+ 20 21)\n", + "(+ 20 21)", + "numbered debugger restart arguments", + ) + failures += run_debugger_banner_case( + exe, + "missing-name\n:show\n(:use-value 1)\n", + 2, + "debugger :show command", + ) + failures += run_debugger_banner_case( + exe, + 'missing-name\n(error "nested")\n:return-to-debugger\n(:use-value 1)\n', + 3, + "parent debugger banner redisplay", + ) + failures += run_debugger_prompt_depth_case(exe) if failures: return 1