diff options
| -rw-r--r-- | gdb/guile/scm-gsmob.c | 29 | ||||
| -rw-r--r-- | gdb/testsuite/gdb.guile/scm-gsmob.exp | 28 |
2 files changed, 56 insertions, 1 deletions
diff --git a/gdb/guile/scm-gsmob.c b/gdb/guile/scm-gsmob.c index c623b07..72a96a7 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 90c32df..e309fd2 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" +} |