mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Fix GOOPS `class-of' for nameless structs.

Browse source 
* libguile/goops.c (scm_class_of): Fix second argument for
  `scm_make_extended_class_from_symbol ()' for nameless structs.

* test-suite/tests/goops.test ("classes for built-in types")["struct
  vtable"]: New test case.
This commit is contained in:
Ludovic Courtès 2009-10-25 22:49:28 +01:00
parent 9a8eb5fb46
commit 288bbc44cf
2 changed files with 15 additions and 6 deletions
Download patch file Download diff file Expand all files Collapse all files

14
libguile/goops.c
View file

@ -282,11 +282,15 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle));
else
{
SCM name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle));
SCM class = scm_make_extended_class_from_symbol (scm_is_true (name)
? name
: scm_nullstr,
SCM_I_OPERATORP (x));
SCM class, name;
name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle));
if (!scm_is_symbol (name))
name = scm_string_to_symbol (scm_nullstr);
class =
scm_make_extended_class_from_symbol (name,
SCM_I_OPERATORP (x));
SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class);
return class;
}

7
test-suite/tests/goops.test
View file

@ -139,7 +139,12 @@
(eq? (class-of "foo") <string>))
(pass-if "port"
(is-a? (%make-void-port "w") <port>)))
(is-a? (%make-void-port "w") <port>))
(pass-if "struct vtable"
;; Previously, `class-of' would fail for nameless structs, i.e., structs
;; for which `struct-vtable-name' is #f.
(is-a? (class-of (make-vtable-vtable "prprpr" 0)) <class>)))
(with-test-prefix "defining classes"