← Back to branch summary

~peter-pearse/ubuntu/natty/guile-1.8/prop001

« back to all changes in this revision

Viewing changes to test-suite/tests/goops.test

  • Committer: Bazaar Package Importer
  • Author(s): Steve Langasek
  • Date: 2009-06-04 19:01:38 UTC
  • mfrom: (8.1.1 sid)
  • Revision ID: james.westby@ubuntu.com-20090604190138-1ao3t6sj31cqvcfe
Tags: 1.8.6+1-1ubuntu1
* Merge from Debian unstable, remaining changes:
  - Build with -Wno-error.
  - Build with thread support. Some guile-using programs like autogen need it.
  - Add debian/guile-1.8-libs.shlibs: Thread support breaks ABI, bump the soname.
* Dropped changes:
  - libltdl3-dev -> libltdl7-dev: current libltdl-dev Provides: both.
  - debian/patches/libtool-ftbfs.diff: integrated upstream.

Show diffs side-by-side

added added

removed removed

Lines of Context:
test-suite/tests/goops.test
18
18
;;;; Boston, MA 02110-1301 USA
19
19
 
20
20
(define-module (test-suite test-goops)
21
 
  #:use-module (test-suite lib))
 
21
  #:use-module (test-suite lib)
 
22
  #:autoload   (srfi srfi-1)    (unfold))
22
23
 
23
24
(pass-if "GOOPS loads"
24
25
         (false-if-exception
277
278
             (y #:accessor y #:init-value 456)
278
279
             (z #:accessor z #:init-value 789))
279
280
          (current-module))
280
 
    (eval '(and (= (y foo) 456) (= (z foo) 789)) (current-module))))
 
281
    (eval '(and (= (y foo) 456) (= (z foo) 789)) (current-module)))
 
282
 
 
283
  (pass-if "changing class"
 
284
    (let* ((c1 (class () (the-slot #:init-keyword #:value)))
 
285
           (c2 (class () (the-slot #:init-keyword #:value)
 
286
                         (the-other-slot #:init-value 888)))
 
287
           (o1 (make c1 #:value 777)))
 
288
      (and (is-a? o1 c1)
 
289
           (not (is-a? o1 c2))
 
290
           (equal? (slot-ref o1 'the-slot) 777)
 
291
           (let ((o2 (change-class o1 c2)))
 
292
             (and (eq? o1 o2)
 
293
                  (is-a? o2 c2)
 
294
                  (not (is-a? o2 c1))
 
295
                  (equal? (slot-ref o2 'the-slot) 777))))))
 
296
 
 
297
  (pass-if "`hell' in `goops.c' grows as expected"
 
298
    ;; This snippet yielded a segfault prior to the 2008-08-19 `goops.c'
 
299
    ;; fix (i.e., Guile 1.8.5 and earlier).  The root of the problem was
 
300
    ;; that `go_to_hell ()' would not reallocate enough room for the `hell'
 
301
    ;; array, leading to out-of-bounds accesses.
 
302
 
 
303
    (let* ((parent-class (class ()
 
304
                           #:name '<class-that-will-be-redefined>))
 
305
           (classes
 
306
            (unfold (lambda (i) (>= i 20))
 
307
                    (lambda (i)
 
308
                      (make-class (list parent-class)
 
309
                                  '((the-slot #:init-value #:value)
 
310
                                    (the-other-slot))
 
311
                                  #:name (string->symbol
 
312
                                          (string-append "<foo-to-redefine-"
 
313
                                                         (number->string i)
 
314
                                                         ">"))))
 
315
                    (lambda (i)
 
316
                      (+ 1 i))
 
317
                    0))
 
318
           (objects
 
319
            (map (lambda (class)
 
320
                   (make class #:value 777))
 
321
                 classes)))
 
322
 
 
323
      (define-method (change-class (foo parent-class)
 
324
                                   (new <class>))
 
325
        ;; Called by `scm_change_object_class ()', via `purgatory ()'.
 
326
        (if (null? classes)
 
327
            (next-method)
 
328
            (let ((class  (car classes))
 
329
                  (object (car objects)))
 
330
              (set! classes (cdr classes))
 
331
              (set! objects (cdr objects))
 
332
 
 
333
              ;; Redefine the class so that its instances are eventually
 
334
              ;; passed to `scm_change_object_class ()'.  This leads to
 
335
              ;; nested `scm_change_object_class ()' calls, which increases
 
336
              ;; the size of HELL and increments N_HELL.
 
337
              (class-redefinition class
 
338
                                  (make-class '() (class-slots class)
 
339
                                              #:name (class-name class)))
 
340
 
 
341
              ;; Use `slot-ref' to trigger the `scm_change_object_class ()'
 
342
              ;; and `go_to_hell ()' calls.
 
343
              (slot-ref object 'the-slot)
 
344
 
 
345
              (next-method))))
 
346
 
 
347
 
 
348
      ;; Initiate the whole `change-class' chain.
 
349
      (let* ((class  (car classes))
 
350
             (object (change-class (car objects) class)))
 
351
        (is-a? object class)))))
281
352
 
282
353
(with-test-prefix "object comparison"
283
354
  (pass-if "default method"