Debugger

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

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 (&LT_Package_LISTTALK)
 #define LT_PACKAGE_LISTTALK_IMPLEMENTATION (&LT_Package_LISTTALK_IMPLEMENTATION)
 #define LT_PACKAGE_LISTTALK_USER (&LT_Package_LISTTALK_USER)
+#define LT_PACKAGE_LISTTALK_DEBUG (&LT_Package_LISTTALK_DEBUG)
 #define LT_PACKAGE_KEYWORD (&LT_Package_KEYWORD)
 
 LT__END_DECLS

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)
 

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 <ListTalk/macros/env_macros.h>
+#include <ListTalk/vm/value.h>
+
+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

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; \

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);

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
 

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;
 };

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),

src/bin/listtalk/main.c

@@ -8,6 +8,7 @@
 #include <ListTalk/classes/Pair.h>
 #include <ListTalk/classes/Printer.h>
 #include <ListTalk/classes/Primitive.h>
+#include <ListTalk/classes/Restart.h>
 #include <ListTalk/vm/reader.h>
 #include <ListTalk/classes/String.h>
 #include <ListTalk/classes/Symbol.h>
@@ -17,11 +18,28 @@
 #include <ListTalk/vm/loader.h>
 #include <ListTalk/vm/throw_catch.h>
 #include <ListTalk/repl/repl.h>
+#include <ListTalk/debugger/debugger.h>
 #include <ctype.h>
 #include <stdio.h>
 #include <string.h>
 
 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) == &LT_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;

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();

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), &LT_SlotType_ReadonlyObject},
+    {
+        "parent",
+        offsetof(LT_Environment, parent),
+        &LT_SlotType_ReadonlyNativeObjectPointer
+    },
     LT_NULL_NATIVE_CLASS_SLOT_DESCRIPTOR
 };