[PING**2] [PATCH v2] guile: fix smob exports

[George Barrett <bob@bob131.so>]

On Thu, Jul 29, 2021 at 09:23:21 +1000, George Barrett wrote:
> Pinging for review. If it looks okay, I'd appreciate if someone could push it
> on my behalf.
>
> On Mon, Jun 07, 2021 at 04:49:58AM +1000, George Barrett wrote:
>> Before Guile v2.1[1], calls to `scm_make_smob_type' implicitly
>> added the created class to the exports list of (oop goops); v2.1+ does
>> not implicitly create bindings in any modules. This means that the GDB
>> manual subsection documenting exported types is not quite right when
>> GDB is linked against Guile <v2.1 (types are exported from (oop
>> goops)) instead of (gdb)) and incorrect when linked against Guile
>> v2.1+ (types are not bound to any variables at all!).
>> 
>> This commit makes a small change to GDB's smob registration machinery
>> to make sure registered smobs get exported from the current
>> module. This will likely cause warnings to the user about conflicting
>> exports if they load both (gdb) and (oop goops) from a GDB linked
>> against Guile v2.0, but it shouldn't impact functionality (and seemed
>> preferable to trying to un-export bindings from (oop goops) if v2.0
>> was detected).
>> 
>> [1]: This changed with Guile commit
>>      28d0871b553a3959a6c59e2e4caec1c1509f8595
>> 
>> gdb/ChangeLog:
>> 
>> 2021-06-07  George Barrett  <bob@bob131.so>
>> 
>> 	* guile/scm-gsmob.c (gdbscm_make_smob_type): Export registered
>> 	smob type from the current module.
>> 
>> gdb/testsuite/ChangeLog:
>> 
>> 2021-06-07  George Barrett  <bob@bob131.so>
>> 
>> 	* gdb.guile/scm-gsmob.exp (test exports): Add tests to make
>> 	sure the smob types currently listed in the GDB manual get
>> 	exported from the (gdb) module.
>> ---
>>  gdb/guile/scm-gsmob.c                 | 29 ++++++++++++++++++++++++++-
>>  gdb/testsuite/gdb.guile/scm-gsmob.exp | 28 ++++++++++++++++++++++++++
>>  2 files changed, 56 insertions(+), 1 deletion(-)
>> 
>> diff --git a/gdb/guile/scm-gsmob.c b/gdb/guile/scm-gsmob.c
>> index c623b07d26c..72a96a781c1 100644
>> --- a/gdb/guile/scm-gsmob.c
>> +++ b/gdb/guile/scm-gsmob.c
>> @@ -96,7 +96,8 @@ gdbscm_is_gsmob (SCM scm)
>>    return slot != NULL;
>>  }
>>  
>> -/* Call this to register a smob, instead of scm_make_smob_type.  */
>> +/* Call this to register a smob, instead of scm_make_smob_type.
>> +   Exports the created smob type from the current module.  */
>>  
>>  scm_t_bits
>>  gdbscm_make_smob_type (const char *name, size_t size)
>> @@ -104,6 +105,32 @@ gdbscm_make_smob_type (const char *name, size_t size)
>>    scm_t_bits result = scm_make_smob_type (name, size);
>>  
>>    register_gsmob (result);
>> +
>> +#if SCM_MAJOR_VERSION == 2 && SCM_MINOR_VERSION == 0
>> +  /* Prior to Guile 2.1.0, smob classes were only exposed via exports
>> +     from the (oop goops) module.  */
>> +  SCM bound_name = scm_string_append (scm_list_3 (scm_from_latin1_string ("<"),
>> +						  scm_from_latin1_string (name),
>> +						  scm_from_latin1_string (">")));
>> +  bound_name = scm_string_to_symbol (bound_name);
>> +  SCM smob_type = scm_public_ref (scm_list_2 (scm_from_latin1_symbol ("oop"),
>> +					      scm_from_latin1_symbol ("goops")),
>> +				  bound_name);
>> +#elif SCM_MAJOR_VERSION == 2 && SCM_MINOR_VERSION == 1 && SCM_MICRO_VERSION == 0
>> +  /* Guile 2.1.0 doesn't provide any API for looking up smob classes.
>> +     We could try allocating a fake instance and using scm_class_of,
>> +     but it's probably not worth the trouble for the sake of a single
>> +     development release.  */
>> +#  error "Unsupported Guile version"
>> +#else
>> +  /* Guile 2.1.1 and above provides scm_smob_type_class.  */
>> +  SCM smob_type = scm_smob_type_class (result);
>> +#endif
>> +
>> +  SCM smob_type_name = scm_class_name (smob_type);
>> +  scm_define (smob_type_name, smob_type);
>> +  scm_module_export (scm_current_module (), scm_list_1 (smob_type_name));
>> +
>>    return result;
>>  }
>>  
>> diff --git a/gdb/testsuite/gdb.guile/scm-gsmob.exp b/gdb/testsuite/gdb.guile/scm-gsmob.exp
>> index 90c32df7dda..e309fd2888d 100644
>> --- a/gdb/testsuite/gdb.guile/scm-gsmob.exp
>> +++ b/gdb/testsuite/gdb.guile/scm-gsmob.exp
>> @@ -66,3 +66,31 @@ set prop_list [lsort $prop_list]
>>  verbose -log "prop_list: $prop_list"
>>  gdb_test "gu (print (sort (map car (object-properties arch)) (lambda (a b) (string<? (symbol->string a) (symbol->string b)))))" \
>>      "= \\($prop_list\\)" "object-properties"
>> +
>> +# Check that smob classes are exported properly
>> +with_test_prefix "test exports" {
>> +    # Import (oop goops) for is-a? and <class>
>> +    gdb_scm_test_silent_cmd "gu (use-modules (oop goops))" "import goops"
>> +    gdb_test_no_output "gu (define-syntax-rule (gdb-exports-class? x) (is-a? (@ (gdb) x) <class>))"
>> +
>> +    gdb_test "gu (print (gdb-exports-class? <gdb:arch>))" "= #t"
>> +    gdb_test "gu (print (gdb-exports-class? <gdb:block>))" "= #t"
>> +    gdb_test "gu (print (gdb-exports-class? <gdb:block-symbols-iterator>))" "= #t"
>> +    gdb_test "gu (print (gdb-exports-class? <gdb:breakpoint>))" "= #t"
>> +    gdb_test "gu (print (gdb-exports-class? <gdb:command>))" "= #t"
>> +    gdb_test "gu (print (gdb-exports-class? <gdb:exception>))" "= #t"
>> +    gdb_test "gu (print (gdb-exports-class? <gdb:frame>))" "= #t"
>> +    gdb_test "gu (print (gdb-exports-class? <gdb:iterator>))" "= #t"
>> +    gdb_test "gu (print (gdb-exports-class? <gdb:lazy-string>))" "= #t"
>> +    gdb_test "gu (print (gdb-exports-class? <gdb:objfile>))" "= #t"
>> +    gdb_test "gu (print (gdb-exports-class? <gdb:parameter>))" "= #t"
>> +    gdb_test "gu (print (gdb-exports-class? <gdb:pretty-printer>))" "= #t"
>> +    gdb_test "gu (print (gdb-exports-class? <gdb:pretty-printer-worker>))" "= #t"
>> +    gdb_test "gu (print (gdb-exports-class? <gdb:progspace>))" "= #t"
>> +    gdb_test "gu (print (gdb-exports-class? <gdb:symbol>))" "= #t"
>> +    gdb_test "gu (print (gdb-exports-class? <gdb:symtab>))" "= #t"
>> +    gdb_test "gu (print (gdb-exports-class? <gdb:sal>))" "= #t"
>> +    gdb_test "gu (print (gdb-exports-class? <gdb:type>))" "= #t"
>> +    gdb_test "gu (print (gdb-exports-class? <gdb:field>))" "= #t"
>> +    gdb_test "gu (print (gdb-exports-class? <gdb:value>))" "= #t"
>> +}
>> -- 
>> 2.31.1