diff --git a/ListTalk/ListTalk.h b/ListTalk/ListTalk.h index 1ecacca..d63b575 100644 --- a/ListTalk/ListTalk.h +++ b/ListTalk/ListTalk.h @@ -43,6 +43,7 @@ #include #include #include +#include #include #include #include diff --git a/ListTalk/classes/Object.h b/ListTalk/classes/Object.h index f1f6a2e..1993dd7 100644 --- a/ListTalk/classes/Object.h +++ b/ListTalk/classes/Object.h @@ -20,6 +20,10 @@ extern LT_Class LT_Object_class_class; LT_Value LT_Object_slot_ref(LT_Value object, LT_Value slot_name); LT_Value LT_Object_slot_set(LT_Value object, LT_Value slot_name, LT_Value value); +LT_Value LT_Object_inspection(LT_Value object); +LT_Value LT_Object_inspection_with_contents(LT_Value object, + char* contents_label, + LT_Value contents); LT__END_DECLS diff --git a/ListTalk/classes/ObjectInspection.h b/ListTalk/classes/ObjectInspection.h new file mode 100644 index 0000000..2d22c10 --- /dev/null +++ b/ListTalk/classes/ObjectInspection.h @@ -0,0 +1,40 @@ +/* + * SPDX-License-Identifier: MIT + * Copyright (c) 2023 - 2026 Ales Hakl + */ + +#ifndef H__ListTalk__ObjectInspection__ +#define H__ListTalk__ObjectInspection__ + +#include + +#include +#include + +LT__BEGIN_DECLS + +LT_DECLARE_CLASS(LT_ObjectInspection); + +struct LT_ObjectInspection_s { + LT_Object base; + LT_Value name; + LT_Value description; + LT_Value slots; + LT_Value contents_label; + LT_Value contents; +}; + +LT_Value LT_ObjectInspection_new(LT_Value name, + LT_Value description, + LT_Value slots, + LT_Value contents_label, + LT_Value contents); +LT_Value LT_ObjectInspection_name(LT_ObjectInspection* inspection); +LT_Value LT_ObjectInspection_description(LT_ObjectInspection* inspection); +LT_Value LT_ObjectInspection_slots(LT_ObjectInspection* inspection); +LT_Value LT_ObjectInspection_contents_label(LT_ObjectInspection* inspection); +LT_Value LT_ObjectInspection_contents(LT_ObjectInspection* inspection); + +LT__END_DECLS + +#endif diff --git a/ListTalk/debugger/debugger.h b/ListTalk/debugger/debugger.h index 48a634b..1a3b808 100644 --- a/ListTalk/debugger/debugger.h +++ b/ListTalk/debugger/debugger.h @@ -7,6 +7,7 @@ #define H__ListTalk__debugger__debugger__ #include +#include #include LT__BEGIN_DECLS @@ -23,6 +24,9 @@ LT_Value LT_Debugger_get_hook(void); /* Install LT_Debugger_get_hook() as the current thread's debugger hook. */ void LT_Debugger_enable(void); +/* Bind the interactive inspector primitive as ListTalk:inspect. */ +void LT_Debugger_define_inspect(LT_Environment* environment); + /* Interactively display OBJECT and descend through its named slots. */ void LT_Debugger_inspect(LT_Value object); diff --git a/meson.build b/meson.build index c7605e2..999f175 100644 --- a/meson.build +++ b/meson.build @@ -191,6 +191,7 @@ vm_lib = library( 'src/classes/ImmutableList.c', 'src/classes/Pair.c', 'src/classes/StackFrame.c', + 'src/classes/ObjectInspection.c', 'src/classes/BindingDescriptor.c', 'src/classes/MethodDescriptor.c', 'src/classes/Message.c', diff --git a/src/bin/listtalk/main.c b/src/bin/listtalk/main.c index 151fcb2..68664b7 100644 --- a/src/bin/listtalk/main.c +++ b/src/bin/listtalk/main.c @@ -431,6 +431,7 @@ int main(int argc, char**argv){ command_action_ensure_standard_resolvers(&command_action); LT_enable_KeyboardInterrupt(); LT_Debugger_enable(); + LT_Debugger_define_inspect(base_environment); { LT_REPL_State* repl = LT_REPL_State_new(); diff --git a/src/classes/Class.c b/src/classes/Class.c index b7c8f99..d79f107 100644 --- a/src/classes/Class.c +++ b/src/classes/Class.c @@ -186,6 +186,12 @@ LT_DECLARE_PRIMITIVE( "(self)", "Return direct method descriptors as a list." ); +LT_DECLARE_PRIMITIVE( + class_method_inspection, + "Class>>inspection", + "(self)", + "Return an inspection whose contents are direct methods." +); LT_DECLARE_PRIMITIVE( class_method_all_methods_do, "Class>>allMethodsDo:", @@ -223,6 +229,7 @@ static LT_Method_Descriptor Class_methods[] = { {"allSelectorsAsList", &class_method_all_selectors_as_list}, {"methodsDo:", &class_method_methods_do}, {"methodsAsList", &class_method_methods_as_list}, + {"inspection", &class_method_inspection}, {"allMethodsDo:", &class_method_all_methods_do}, {"allMethodsAsList", &class_method_all_methods_as_list}, {"addMethod:withSelector:", &class_method_add_method_with_selector}, @@ -1300,6 +1307,32 @@ static LT_Value class_direct_methods_as_list(LT_Class* klass){ return LT_ListBuilder_value(builder); } +LT_PRIMITIVE_HEAD(class_method_inspection){ + LT_Value cursor = arguments; + LT_Value self; + LT_Value methods; + LT_ListBuilder* contents = LT_ListBuilder_new(); + (void)tail_call_unwind_marker; + + LT_OBJECT_ARG(cursor, self); + LT_ARG_END(cursor); + methods = class_direct_methods_as_list(LT_Class_from_object(self)); + while (methods != LT_NIL){ + LT_Value method = LT_car(methods); + LT_ListBuilder_append( + contents, + LT_MethodDescriptor_selector(LT_MethodDescriptor_from_value(method)) + ); + LT_ListBuilder_append(contents, method); + methods = LT_cdr(methods); + } + return LT_Object_inspection_with_contents( + self, + "Methods:", + LT_ListBuilder_value(contents) + ); +} + static void class_all_methods_do(LT_Class* klass, LT_Value callable){ LT_Value precedence_cursor = LT_Class_precedence_list(klass); LT_IdentitySet* seen = LT_IdentitySet_new(); diff --git a/src/classes/Environment.c b/src/classes/Environment.c index cd98162..c283b19 100644 --- a/src/classes/Environment.c +++ b/src/classes/Environment.c @@ -115,6 +115,12 @@ LT_DECLARE_PRIMITIVE( "(self)", "Return direct binding reflections as a list." ); +LT_DECLARE_PRIMITIVE( + environment_method_inspection, + "Environment>>inspection", + "(self)", + "Return an inspection whose contents are direct bindings." +); static LT_Method_Descriptor Environment_methods[] = { {"contains?:", &environment_method_contains}, @@ -124,6 +130,7 @@ static LT_Method_Descriptor Environment_methods[] = { {"constant?:", &environment_method_constant}, {"bindingsDo:", &environment_method_bindings_do}, {"bindingsAsList", &environment_method_bindings_as_list}, + {"inspection", &environment_method_inspection}, LT_NULL_NATIVE_CLASS_METHOD_DESCRIPTOR }; @@ -439,6 +446,31 @@ static LT_Value Environment_bindings_as_list(LT_Environment* environment){ return LT_ListBuilder_value(builder); } +LT_PRIMITIVE_HEAD(environment_method_inspection){ + LT_Value cursor = arguments; + LT_Value self; + LT_Value bindings; + LT_ListBuilder* contents = LT_ListBuilder_new(); + (void)tail_call_unwind_marker; + + LT_OBJECT_ARG(cursor, self); + LT_ARG_END(cursor); + bindings = Environment_bindings_as_list(LT_Environment_from_value(self)); + while (bindings != LT_NIL){ + LT_BindingDescriptor* binding = LT_BindingDescriptor_from_value( + LT_car(bindings) + ); + LT_ListBuilder_append(contents, LT_BindingDescriptor_symbol(binding)); + LT_ListBuilder_append(contents, LT_BindingDescriptor_value(binding)); + bindings = LT_cdr(bindings); + } + return LT_Object_inspection_with_contents( + self, + "Bindings:", + LT_ListBuilder_value(contents) + ); +} + LT_PRIMITIVE_HEAD(environment_method_bindings_do){ LT_Value cursor = arguments; LT_Value self; diff --git a/src/classes/List.c b/src/classes/List.c index 953a978..93d9294 100644 --- a/src/classes/List.c +++ b/src/classes/List.c @@ -919,7 +919,40 @@ LT_DEFINE_PRIMITIVE( return (LT_Value)(uintptr_t)vector; } +LT_DEFINE_PRIMITIVE( + list_method_inspection, + "List>>inspection", + "(self)", + "Return an inspection whose contents are the list elements." +){ + LT_Value cursor = arguments; + LT_Value self; + LT_Value list; + LT_ListBuilder* contents = LT_ListBuilder_new(); + int64_t index = 0; + (void)tail_call_unwind_marker; + + LT_OBJECT_ARG(cursor, self); + LT_ARG_END(cursor); + list = self; + while (LT_Pair_p(list)){ + LT_ListBuilder_append(contents, LT_SmallInteger_new(index++)); + LT_ListBuilder_append(contents, LT_car(list)); + list = LT_cdr(list); + } + if (list != LT_NIL){ + LT_ListBuilder_append(contents, LT_SmallInteger_new(index)); + LT_ListBuilder_append(contents, list); + } + return LT_Object_inspection_with_contents( + self, + "Elements:", + LT_ListBuilder_value(contents) + ); +} + static LT_Method_Descriptor List_methods[] = { + {"inspection", &list_method_inspection}, {"length", &list_method_length}, {"at:", &list_method_at}, {"map:", &list_method_map}, diff --git a/src/classes/Object.c b/src/classes/Object.c index a8ede8b..fe36c36 100644 --- a/src/classes/Object.c +++ b/src/classes/Object.c @@ -4,13 +4,19 @@ */ #include +#include #include #include +#include +#include +#include #include #include #include #include +#include + LT_DEFINE_PRIMITIVE( object_method_class, "Object>>class", @@ -78,6 +84,21 @@ LT_DEFINE_PRIMITIVE_FLAGS( return (LT_Value)(uintptr_t)LT_Value_asString(self); } +LT_DEFINE_PRIMITIVE( + object_method_inspection, + "Object>>inspection", + "(self)", + "Return a presentation-independent inspection of receiver." +){ + LT_Value cursor = arguments; + LT_Value self; + (void)tail_call_unwind_marker; + + LT_OBJECT_ARG(cursor, self); + LT_ARG_END(cursor); + return LT_Object_inspection(self); +} + LT_DEFINE_PRIMITIVE_FLAGS( object_method_identity_equal, "Object>>==", @@ -179,6 +200,7 @@ static LT_Method_Descriptor Object_methods[] = { {"slot:", &object_method_slot}, {"slot:put:", &object_method_slot_put}, {"asString", &object_method_as_string}, + {"inspection", &object_method_inspection}, {"==", &object_method_identity_equal}, {"=", &object_method_equal}, {"subclassResponsibility", &object_method_subclass_responsibility}, @@ -197,6 +219,46 @@ LT_DEFINE_CLASS(LT_Object) { .methods = Object_methods, }; +LT_Value LT_Object_inspection(LT_Value object){ + return LT_Object_inspection_with_contents(object, "Contents:", LT_NIL); +} + +LT_Value LT_Object_inspection_with_contents(LT_Value object, + char* contents_label, + LT_Value contents){ + LT_Class* klass = LT_Value_class(object); + LT_ListBuilder* slots = LT_ListBuilder_new(); + char* name_text; + LT_Value name; + LT_Value description; + size_t i; + + name_text = LT_sprintf( + "%s at 0x%" PRIxPTR, + LT_Symbol_name(LT_Symbol_from_value(klass->name)), + (uintptr_t)object + ); + name = (LT_Value)(uintptr_t)LT_String_new_cstr(name_text); + description = klass->documentation == LT_NIL + ? (LT_Value)(uintptr_t)LT_String_new_cstr("") + : klass->documentation; + for (i = 0; i < klass->slot_count; i++){ + LT_ListBuilder_append(slots, klass->slots[i].name); + LT_ListBuilder_append( + slots, + klass->slots[i].type->ref(&klass->slots[i], object) + ); + } + + return LT_ObjectInspection_new( + name, + description, + LT_ListBuilder_value(slots), + (LT_Value)(uintptr_t)LT_String_new_cstr(contents_label), + contents + ); +} + LT_Value LT_Object_slot_ref(LT_Value object, LT_Value slot_name){ LT_Class* klass = LT_Value_class(object); LT_Class_Slot* slot = LT_Class_lookup_slot(klass, slot_name); diff --git a/src/classes/ObjectInspection.c b/src/classes/ObjectInspection.c new file mode 100644 index 0000000..ea1baf6 --- /dev/null +++ b/src/classes/ObjectInspection.c @@ -0,0 +1,213 @@ +/* + * SPDX-License-Identifier: MIT + * Copyright (c) 2023 - 2026 Ales Hakl + */ + +#include +#include +#include +#include +#include +#include +#include + +#include +#include + +static LT_Slot_Descriptor ObjectInspection_slots[] = { + {"name", offsetof(LT_ObjectInspection, name), <_SlotType_ReadonlyObject}, + {"description", offsetof(LT_ObjectInspection, description), <_SlotType_ReadonlyObject}, + {"slots", offsetof(LT_ObjectInspection, slots), <_SlotType_ReadonlyObject}, + {"contents-label", offsetof(LT_ObjectInspection, contents_label), <_SlotType_ReadonlyObject}, + {"contents", offsetof(LT_ObjectInspection, contents), <_SlotType_ReadonlyObject}, + LT_NULL_NATIVE_CLASS_SLOT_DESCRIPTOR +}; + +static int plist_p(LT_Value value){ + while (value != LT_NIL){ + if (!LT_Pair_p(value)){ + return 0; + } + value = LT_cdr(value); + if (!LT_Pair_p(value)){ + return 0; + } + value = LT_cdr(value); + } + return 1; +} + +static void ObjectInspection_debugPrintOn(LT_Value object, FILE* stream){ + LT_ObjectInspection* inspection = LT_ObjectInspection_from_value(object); + + fputs("#name, stream); + fputc('>', stream); +} + +#define DEFINE_OBJECT_INSPECTION_ACCESSOR(method_name, selector, accessor, text) \ + LT_DEFINE_PRIMITIVE( \ + method_name, \ + "ObjectInspection>>" selector, \ + "(self)", \ + text \ + ){ \ + LT_Value cursor = arguments; \ + LT_Value self; \ + (void)tail_call_unwind_marker; \ + LT_OBJECT_ARG(cursor, self); \ + LT_ARG_END(cursor); \ + return accessor(LT_ObjectInspection_from_value(self)); \ + } + +DEFINE_OBJECT_INSPECTION_ACCESSOR( + object_inspection_method_name, + "name", + LT_ObjectInspection_name, + "Return inspection name." +) +DEFINE_OBJECT_INSPECTION_ACCESSOR( + object_inspection_method_description, + "description", + LT_ObjectInspection_description, + "Return inspection description." +) +DEFINE_OBJECT_INSPECTION_ACCESSOR( + object_inspection_method_slots, + "slots", + LT_ObjectInspection_slots, + "Return inspection slot property list." +) +DEFINE_OBJECT_INSPECTION_ACCESSOR( + object_inspection_method_contents_label, + "contents-label", + LT_ObjectInspection_contents_label, + "Return inspection contents heading." +) +DEFINE_OBJECT_INSPECTION_ACCESSOR( + object_inspection_method_contents, + "contents", + LT_ObjectInspection_contents, + "Return inspection contents property list." +) + +#undef DEFINE_OBJECT_INSPECTION_ACCESSOR + +LT_DEFINE_PRIMITIVE( + object_inspection_class_method_new, + "ObjectInspection class>>newName:description:slots:contentsLabel:contents:", + "(self name description slots contents-label contents)", + "Return an object inspection with the supplied fields." +){ + LT_Value cursor = arguments; + LT_Value self; + LT_Value name; + LT_Value description; + LT_Value slots; + LT_Value contents_label; + LT_Value contents; + (void)tail_call_unwind_marker; + + LT_OBJECT_ARG(cursor, self); + LT_OBJECT_ARG(cursor, name); + LT_OBJECT_ARG(cursor, description); + LT_OBJECT_ARG(cursor, slots); + LT_OBJECT_ARG(cursor, contents_label); + LT_OBJECT_ARG(cursor, contents); + LT_ARG_END(cursor); + if (self != (LT_Value)(uintptr_t)<_ObjectInspection_class){ + LT_error( + "newName:description:slots:contentsLabel:contents: class method " + "is only supported on ObjectInspection" + ); + } + return LT_ObjectInspection_new( + name, + description, + slots, + contents_label, + contents + ); +} + +static LT_Method_Descriptor ObjectInspection_methods[] = { + {"name", &object_inspection_method_name}, + {"description", &object_inspection_method_description}, + {"slots", &object_inspection_method_slots}, + {"contents-label", &object_inspection_method_contents_label}, + {"contents", &object_inspection_method_contents}, + LT_NULL_NATIVE_CLASS_METHOD_DESCRIPTOR +}; + +static LT_Method_Descriptor ObjectInspection_class_methods[] = { + { + "newName:description:slots:contentsLabel:contents:", + &object_inspection_class_method_new + }, + LT_NULL_NATIVE_CLASS_METHOD_DESCRIPTOR +}; + +LT_DEFINE_CLASS(LT_ObjectInspection) { + .superclass = <_Object_class, + .metaclass_superclass = <_Class_class, + .name = "ObjectInspection", + .documentation = "Immutable, presentation-independent description of an object.", + .instance_size = sizeof(LT_ObjectInspection), + .class_flags = LT_CLASS_FLAG_FINAL | LT_CLASS_FLAG_IMMUTABLE, + .debugPrintOn = ObjectInspection_debugPrintOn, + .slots = ObjectInspection_slots, + .methods = ObjectInspection_methods, + .class_methods = ObjectInspection_class_methods, +}; + +LT_Value LT_ObjectInspection_new(LT_Value name, + LT_Value description, + LT_Value slots, + LT_Value contents_label, + LT_Value contents){ + LT_ObjectInspection* inspection; + + if (!LT_String_p(name)){ + LT_type_error(name, <_String_class); + } + if (!LT_String_p(description)){ + LT_type_error(description, <_String_class); + } + if (!plist_p(slots)){ + LT_error("ObjectInspection slots must be a property list"); + } + if (!LT_String_p(contents_label)){ + LT_type_error(contents_label, <_String_class); + } + if (!plist_p(contents)){ + LT_error("ObjectInspection contents must be a property list"); + } + + inspection = LT_Class_ALLOC(LT_ObjectInspection); + inspection->name = name; + inspection->description = description; + inspection->slots = slots; + inspection->contents_label = contents_label; + inspection->contents = contents; + return (LT_Value)(uintptr_t)inspection; +} + +LT_Value LT_ObjectInspection_name(LT_ObjectInspection* inspection){ + return inspection->name; +} + +LT_Value LT_ObjectInspection_description(LT_ObjectInspection* inspection){ + return inspection->description; +} + +LT_Value LT_ObjectInspection_slots(LT_ObjectInspection* inspection){ + return inspection->slots; +} + +LT_Value LT_ObjectInspection_contents_label(LT_ObjectInspection* inspection){ + return inspection->contents_label; +} + +LT_Value LT_ObjectInspection_contents(LT_ObjectInspection* inspection){ + return inspection->contents; +} diff --git a/src/debugger/debugger.c b/src/debugger/debugger.c index 2eeefc6..bcd86e4 100644 --- a/src/debugger/debugger.c +++ b/src/debugger/debugger.c @@ -34,7 +34,7 @@ typedef struct { typedef struct { LT_Value object; LT_Value slots; - int list_p; + LT_Value contents; } InspectorContext; static _Thread_local unsigned int debugger_level = 0; @@ -89,7 +89,7 @@ LT_DEFINE_PRIMITIVE_RESTART( LT_DEFINE_PRIMITIVE( inspect_primitive, - "ListTalk-debug:inspect", + "ListTalk:inspect", "(object)", "Interactively inspect an object." ){ @@ -105,6 +105,15 @@ LT_DEFINE_PRIMITIVE( return object; } +void LT_Debugger_define_inspect(LT_Environment* environment){ + LT_Environment_bind( + environment, + LT_Symbol_new_in(LT_PACKAGE_LISTTALK, "inspect"), + LT_Primitive_from_static(&inspect_primitive), + LT_ENV_BINDING_FLAG_CONSTANT + ); +} + LT_Value LT_Debugger_get_hook(void){ return LT_Primitive_from_static(&debugger_hook_primitive); } @@ -482,93 +491,113 @@ void LT_Debugger_break(LT_Value condition, LT_Value debugger_hook){ }); } -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); +static void inspector_print_plist(const char* label, + LT_Value plist){ + LT_Value cursor = plist; - 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" - ); + fprintf(stdout, "%s (none)\n\n", label); return; } + fprintf(stdout, "%s\n", label); + while (cursor != LT_NIL){ + LT_Value key = LT_car(cursor); + LT_Value value = LT_car(LT_cdr(cursor)); - 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 - ); - } + fputs(" ", stdout); + LT_Value_debugPrintOn(key, stdout); + fputs(" = ", stdout); + LT_Value_debugPrintOn(value, stdout); fputc('\n', stdout); - cursor = LT_cdr(cursor); + cursor = LT_cdr(LT_cdr(cursor)); } fputc('\n', stdout); } -static LT_Value inspector_selected_slot(LT_Value input, LT_Value slots){ - LT_Value cursor; +static void inspector_print(InspectorContext* context){ + LT_Value inspection_value = LT_SEND(context->object, "inspection"); + LT_ObjectInspection* inspection = LT_ObjectInspection_from_value( + inspection_value + ); + context->slots = LT_ObjectInspection_slots(inspection); + context->contents = LT_ObjectInspection_contents(inspection); - if (LT_SmallInteger_p(input)){ - return list_at_1_based(slots, LT_SmallInteger_value(input)); - } - if (!LT_Symbol_p(input)){ - return LT_INVALID; + fputs("Object: ", stdout); + fputs( + LT_String_value_cstr( + LT_String_from_value(LT_ObjectInspection_name(inspection)) + ), + stdout + ); + fputc('\n', stdout); + fputs( + LT_String_value_cstr( + LT_String_from_value(LT_ObjectInspection_description(inspection)) + ), + stdout + ); + fputs("\n\n", stdout); + + inspector_print_plist("Slots:", context->slots); + if (context->contents != LT_NIL){ + inspector_print_plist( + LT_String_value_cstr( + LT_String_from_value( + LT_ObjectInspection_contents_label(inspection) + ) + ), + context->contents + ); } +} - cursor = slots; - while (LT_Pair_p(cursor)){ - LT_Value slot_name = LT_car(cursor); +static LT_Value inspector_selected_from_plist(LT_Value input, + LT_Value plist){ + LT_Value cursor; + + cursor = plist; + while (cursor != LT_NIL){ + LT_Value key = LT_car(cursor); + LT_Value value = LT_car(LT_cdr(cursor)); - if (LT_Symbol_p(slot_name) + if (LT_Value_equal_p(input, key) + || (LT_Symbol_p(input) + && LT_Symbol_p(key) && strcmp( LT_Symbol_name(LT_Symbol_from_value(input)), - LT_Symbol_name(LT_Symbol_from_value(slot_name)) - ) == 0){ - return slot_name; + LT_Symbol_name(LT_Symbol_from_value(key)) + ) == 0)){ + return value; } - cursor = LT_cdr(cursor); + cursor = LT_cdr(LT_cdr(cursor)); } return LT_INVALID; } +static LT_Value inspector_selected_entry(LT_Value input, + LT_Value slots, + LT_Value contents){ + LT_Value selected; + + selected = inspector_selected_from_plist(input, slots); + if (selected != LT_INVALID){ + return selected; + } + return inspector_selected_from_plist(input, contents); +} + 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" - ); + LT_Value selected_object = inspector_selected_entry( + input, + context->slots, + context->contents + ); + + if (selected_object == LT_INVALID){ + fputs("No such entry.\n", stdout); return; } - selected_object = context->list_p - ? slot_name - : LT_Object_slot_ref(context->object, slot_name); LT_Debugger_inspect(selected_object); inspector_print(context); } @@ -578,7 +607,7 @@ void LT_Debugger_inspect(LT_Value object){ InspectorContext context = { .object = object, .slots = LT_NIL, - .list_p = 0 + .contents = LT_NIL }; inspector_print(&context); diff --git a/tests/c_api_test.c b/tests/c_api_test.c index c25c88a..4847e75 100644 --- a/tests/c_api_test.c +++ b/tests/c_api_test.c @@ -15,6 +15,7 @@ #include #include +#include #include #include #include @@ -465,6 +466,175 @@ static int test_eval_runs_pending_signal_closure(void){ return failed; } +static int test_object_inspection_contains_slots(void){ + LT_Value object = LT_BindingDescriptor_new( + LT_Symbol_new("example"), + LT_SmallInteger_new(1), + 0 + ); + LT_Value value = LT_SEND(object, "inspection"); + LT_ObjectInspection* inspection; + LT_Value slots; + LT_Value constructed; + char* expected_name; + + if (expect( + LT_ObjectInspection_p(value), + "Object>>inspection returns ObjectInspection" + )){ + return 1; + } + inspection = LT_ObjectInspection_from_value(value); + expected_name = LT_sprintf( + "%s at 0x%" PRIxPTR, + LT_Symbol_name(LT_Symbol_from_value(LT_Value_class(object)->name)), + (uintptr_t)object + ); + if (expect( + strcmp( + LT_String_value_cstr( + LT_String_from_value(LT_ObjectInspection_name(inspection)) + ), + expected_name + ) == 0, + "Object>>inspection names the receiver class and identity" + )){ + return 1; + } + if (expect( + LT_ObjectInspection_description(inspection) + == LT_Value_class(object)->documentation, + "Object>>inspection uses the receiver class documentation" + )){ + return 1; + } + if (expect( + LT_ObjectInspection_contents(inspection) == LT_NIL, + "Object>>inspection has empty contents" + )){ + return 1; + } + if (expect( + strcmp( + LT_String_value_cstr( + LT_String_from_value( + LT_ObjectInspection_contents_label(inspection) + ) + ), + "Contents:" + ) == 0, + "Object>>inspection uses the default contents label" + )){ + return 1; + } + + slots = LT_ObjectInspection_slots(inspection); + while (slots != LT_NIL){ + LT_Value slot_name = LT_car(slots); + LT_Value slot_value = LT_car(LT_cdr(slots)); + + if (expect( + slot_value == LT_Object_slot_ref(object, slot_name), + "Object>>inspection pairs each slot name with its value" + )){ + return 1; + } + slots = LT_cdr(LT_cdr(slots)); + } + + if (expect( + LT_SEND(value, "name") == LT_ObjectInspection_name(inspection) + && LT_SEND(value, "description") + == LT_ObjectInspection_description(inspection) + && LT_SEND(value, "slots") == LT_ObjectInspection_slots(inspection) + && LT_SEND(value, "contents-label") + == LT_ObjectInspection_contents_label(inspection) + && LT_SEND(value, "contents") + == LT_ObjectInspection_contents(inspection), + "ObjectInspection accessor methods return stored fields" + )){ + return 1; + } + constructed = LT_SEND( + (LT_Value)(uintptr_t)<_ObjectInspection_class, + "newName:description:slots:contentsLabel:contents:", + LT_ObjectInspection_name(inspection), + LT_ObjectInspection_description(inspection), + LT_ObjectInspection_slots(inspection), + LT_ObjectInspection_contents_label(inspection), + LT_ObjectInspection_contents(inspection) + ); + return expect( + LT_ObjectInspection_p(constructed) + && LT_SEND(constructed, "name") + == LT_ObjectInspection_name(inspection) + && LT_SEND(constructed, "contents") == LT_NIL, + "ObjectInspection class constructor stores supplied fields" + ); +} + +static LT_Value inspection_contents_at(LT_Value inspection_value, LT_Value key){ + LT_Value contents = LT_ObjectInspection_contents( + LT_ObjectInspection_from_value(inspection_value) + ); + + while (contents != LT_NIL){ + if (LT_Value_equal_p(LT_car(contents), key)){ + return LT_car(LT_cdr(contents)); + } + contents = LT_cdr(LT_cdr(contents)); + } + return LT_INVALID; +} + +static int test_specialized_object_inspection_contents(void){ + LT_Value list = LT_listn( + 2, + LT_SmallInteger_new(10), + LT_SmallInteger_new(20) + ); + LT_Value list_inspection = LT_SEND(list, "inspection"); + LT_Environment* environment = LT_new_base_environment(); + LT_Value binding_name = LT_Symbol_new("inspected-binding"); + LT_Value environment_inspection; + LT_Value class_inspection; + LT_Value class_contents; + + if (expect( + inspection_contents_at(list_inspection, LT_SmallInteger_new(0)) + == LT_SmallInteger_new(10) + && inspection_contents_at(list_inspection, LT_SmallInteger_new(1)) + == LT_SmallInteger_new(20), + "List inspection exposes indexed elements" + )){ + return 1; + } + LT_Environment_bind(environment, binding_name, LT_SmallInteger_new(42), 0); + environment_inspection = LT_SEND( + (LT_Value)(uintptr_t)environment, + "inspection" + ); + if (expect( + inspection_contents_at(environment_inspection, binding_name) + == LT_SmallInteger_new(42), + "Environment inspection exposes direct bindings" + )){ + return 1; + } + class_inspection = LT_SEND( + (LT_Value)(uintptr_t)<_Pair_class, + "inspection" + ); + class_contents = LT_ObjectInspection_contents( + LT_ObjectInspection_from_value(class_inspection) + ); + return expect( + class_contents != LT_NIL + && LT_MethodDescriptor_p(LT_car(LT_cdr(class_contents))), + "Class inspection exposes direct method descriptors" + ); +} + static int test_register_posix_signal_schedules_pending_signal(void){ LT_Environment* env = LT_new_base_environment(); LT_Value signal; @@ -4361,6 +4531,8 @@ int main(void){ RUN_TEST(test_send_site_macros_c_api); RUN_TEST(test_apply_varargs_c_api); RUN_TEST(test_value_asString_c_api_uses_debug_print); + RUN_TEST(test_object_inspection_contains_slots); + RUN_TEST(test_specialized_object_inspection_contents); RUN_TEST(test_eval_runs_pending_signal_closure); RUN_TEST(test_register_posix_signal_schedules_pending_signal); RUN_TEST(test_send_primitive_uses_precedence_lookup_and_cache); diff --git a/tests/listtalk_cli_test.py b/tests/listtalk_cli_test.py index cb66d50..a507ad8 100644 --- a/tests/listtalk_cli_test.py +++ b/tests/listtalk_cli_test.py @@ -99,6 +99,26 @@ def run_interactive_syntax_error_case(exe): return 0 +def run_interactive_inspect_binding_case(exe): + completed = subprocess.run( + [exe], + input="(primitive? inspect)\n", + check=False, + stdout=subprocess.PIPE, + stderr=subprocess.PIPE, + text=True, + ) + if completed.returncode != 0 or not completed.stdout.rstrip().endswith("#true"): + sys.stderr.write( + "FAIL: interactive REPL did not bind ListTalk:inspect\n{0}{1}".format( + completed.stdout, + completed.stderr, + ) + ) + return 1 + return 0 + + def run_debugger_restart_case(exe, input_text, expected_result, description): completed = subprocess.run( [exe], @@ -255,6 +275,7 @@ def main(): ["--no-std-lib", "-r", "test-module-foo", "-L", fixture_dir], ) failures += run_interactive_syntax_error_case(exe) + failures += run_interactive_inspect_binding_case(exe) failures += run_debugger_restart_case( exe, "missing-name\n(:use-value (+ 20 21))\n",