[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: possible goops class redefinition bug
From: |
Mikael Djurfeldt |
Subject: |
Re: possible goops class redefinition bug |
Date: |
Sun, 20 Apr 2003 13:35:57 +0200 |
"Neil W. Van Dyke" <address@hidden> writes:
> Unless I'm making a stupid late-night error, there appears to be a bug
> related to Goops class redefinition in Guile 1.5.6 from CVS...
>
> Under some circumstances of class redefinition, some slot accessors
> subsequently work incorrectly both for instances instantiated *before*
> the class redefinition and also for those instantiated *after* the
> redefinition.
This bug has been fixed. Since there has passed over a year since you
committed the bug post, I include the rest of your report below.
Thank you!
> The following scenario shows class <c> with slot s1 being redefined to
> have slots s0 and s1 (in that order):
>
> (define <c> #f)
> (define o1 #f)
> (define o2 #f)
>
> (define-class <c> ()
> (s1 #:init-value 'c1-s1 #:getter a-s1))
>
> (set! o1 (make <c>))
>
> (slot-ref o1 's1) => c1-s1
> (a-s1 o1) => c1-s1
>
> (define-class <c> ()
> (s0 #:init-value 'c2-s0 #:getter a-s0)
> (s1 #:init-value 'c2-s1 #:getter a-s1))
>
> (slot-ref o1 's1) => c1-s1 ;; Correct.
> (a-s1 o1) => c2-s0 ;; *ERROR* Should be: c1-s1
>
> (set! o2 (make <c>))
>
> (slot-ref o2 's1) => c2-s1 ;; Correct.
> (a-s1 o2) => c2-s0 ;; *ERROR* Should be: c2-s1
>
> The following test program reproduces this behavior (along with
> debugging information).
>
> (use-modules (oop goops)
> (oop goops describe))
>
> (define (dump-gf gf . args)
> (newline)
> (format #t "DUMP OF GENERIC ~S FOR ARGS ~S:\n" gf args)
> (let ((methods (compute-applicable-methods gf args)))
> (format #t " Applicable: ~S\n" methods)
> (format #t " Sorted: ~S\n"
> (sort-applicable-methods gf methods args))))
>
> (define <c> #f)
> (define o1 #f)
> (define o2 #f)
>
> (newline)
> (display "(define-class <c> ...)\n")
> (define-class <c> ()
> (s1 #:init-value 'c1-s1 #:getter a-s1))
> (format #t "<c> => ~S\n" <c>)
>
> (newline)
> (format #t "(class-slots <c>)\n=> ~S\n"
> (class-slots <c>))
>
> (newline)
> (format #t "(class-direct-methods <c>)\n=> ~S\n"
> (class-direct-methods <c>))
>
> (newline)
> (format #t "a-s1 => ~S\n"
> a-s1)
>
> (newline)
> (format #t "(generic-function-methods a-s1)\n=> ~S\n"
> (generic-function-methods a-s1))
>
> (newline)
> (map (lambda (m) (format #t "(method-source ~S)\n=> ~S\n"
> m (method-source m)))
> (generic-function-methods a-s1))
>
> (newline)
> (display "(set! o1 (make <c>))\n")
> (set! o1 (make <c>))
>
> (newline)
> (format #t "o1 => ~S\n"
> o1)
> (format #t "(class-of o1) => ~S\n"
> (class-of o1))
> (format #t "(slot-ref o1 's1) => ~S ; c1-s1 [OK]\n"
> (slot-ref o1 's1))
> (format #t "(a-s1 o1) => ~S ; c1-s1 [OK]\n"
> (a-s1 o1))
> ; (display "(describe o1) :-\n")
> ; (describe o1)
>
> (dump-gf a-s1 o1)
>
> (newline)
> (display "(define-class <c> ...)\n")
> (define-class <c> ()
> (s0 #:init-value 'c2-s0 #:getter a-s0)
> (s1 #:init-value 'c2-s1 #:getter a-s1))
> (format #t "<c> => ~S\n" <c>)
>
> (newline)
> (format #t "(class-slots <c>)\n=> ~S\n"
> (class-slots <c>))
>
> (newline)
> (format #t "(class-direct-methods <c>)\n=> ~S\n"
> (class-direct-methods <c>))
>
> (newline)
> ; (format #t "a-s0 => ~S\n"
> ; a-s0)
> (format #t "a-s1 => ~S\n"
> a-s1)
>
> (newline)
> (format #t "(generic-function-methods a-s1)\n=> ~S\n"
> (generic-function-methods a-s1))
>
> (newline)
> (map (lambda (m) (format #t "(method-source ~S)\n=> ~S\n"
> m (method-source m)))
> (generic-function-methods a-s1))
>
> (newline)
> (display "(set! o2 (make <c>))\n")
> (set! o2 (make <c>))
>
> (newline)
> (format #t "o1 => ~S\n"
> o1)
> (format #t "(class-of o1) => ~S\n"
> (class-of o1))
> ; (format #t "(slot-ref o1 's0) => ~S ; c2-s0 [OK]\n"
> ; (slot-ref o1 's0))
> (format #t "(slot-ref o1 's1) => ~S ; c1-s1 [OK]\n"
> (slot-ref o1 's1))
> ; (format #t "(a-s0 o1) => ~S ; c2-s0 [OK]\n"
> ; (a-s0 o1))
> (format #t "(a-s1 o1) => ~S ; c1-s1 ***ERROR***\n"
> (a-s1 o1))
> ; (display "(describe o1) :-\n")
> ; (describe o1)
>
> (newline)
> (format #t "o2 => ~S\n"
> o2)
> (format #t "(class-of o2) => ~S\n"
> (class-of o2))
> ; (format #t "(slot-ref o2 's0) => ~S ; c2-s0 [OK]\n"
> ; (slot-ref o2 's0))
> (format #t "(slot-ref o2 's1) => ~S ; c2-s1 [OK]\n"
> (slot-ref o2 's1))
> ; (format #t "(a-s0 o2) => ~S ; c2-s0 [OK]\n"
> ; (a-s0 o2))
> (format #t "(a-s1 o2) => ~S ; c2-s1 ***ERROR***\n"
> (a-s1 o2))
> ; (display "(describe o2) :-\n")
> ; (describe o2)
>
> (dump-gf a-s1 o1)
> (dump-gf a-s1 o2)
>
> --
> Neil W. Van Dyke
> http://www.neilvandyke.org/
>
> _______________________________________________
> Bug-guile mailing list
> address@hidden
> http://mail.gnu.org/mailman/listinfo/bug-guile
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- Re: possible goops class redefinition bug,
Mikael Djurfeldt <=