115 lines
3.5 KiB
Scheme
115 lines
3.5 KiB
Scheme
;; (list-of (list string (list-of (weak-box TST))))
|
|
(send-sexp-to-mred '(define mem-boxes null))
|
|
|
|
(define mem-count 10)
|
|
|
|
(define (test-allocate tag open close)
|
|
(send-sexp-to-mred
|
|
`(let ([new-boxes
|
|
(let loop ([n ,mem-count])
|
|
(cond
|
|
[(zero? n) null]
|
|
[else
|
|
(let* ([o (,open)]
|
|
[b (make-weak-box o)])
|
|
(,close o)
|
|
(cons b (loop (- n 1))))]))])
|
|
(collect-garbage)
|
|
(set! mem-boxes (cons (list ,tag new-boxes) mem-boxes)))))
|
|
|
|
(define (done)
|
|
(send-sexp-to-mred
|
|
`(begin
|
|
(collect-garbage)
|
|
(collect-garbage)
|
|
(collect-garbage)
|
|
(collect-garbage)
|
|
(let ([f (make-object dialog% "Results")]
|
|
[anything? #f])
|
|
(for-each
|
|
(lambda (boxl)
|
|
(let* ([tag (first boxl)]
|
|
[boxes (second boxl)]
|
|
[calc-results
|
|
(lambda ()
|
|
(foldl (lambda (b n) (if (weak-box-value b) (+ n 1) n))
|
|
0
|
|
boxes))])
|
|
(let loop ([tries 4])
|
|
(unless (zero? tries)
|
|
(when (> (calc-results) 0)
|
|
(collect-garbage)
|
|
(loop (- tries 1)))))
|
|
(let ([res (calc-results)])
|
|
(when (> res 0)
|
|
(set! anything? #t)
|
|
(make-object message% (format "~a: ~a of ~a~n" tag res ,mem-count) f)))))
|
|
(reverse mem-boxes))
|
|
(cond
|
|
[anything? (make-object button% "Close" f (lambda x (send f show #f)))]
|
|
[else (make-object button% "NOTHING!" f (lambda x (send f show #f)))])
|
|
(send f show #t)))))
|
|
|
|
(define (test-frame-allocate %)
|
|
(let ([name (symbol->string %)])
|
|
(send-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #f))
|
|
(test-allocate name
|
|
`(lambda () (let ([f (make-object ,% ,name)])
|
|
(send f show #t)
|
|
(yield) (yield)
|
|
f))
|
|
`(lambda (f)
|
|
(yield) (yield)
|
|
(send f close)
|
|
(yield) (yield)))
|
|
(send-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #t))))
|
|
|
|
(test-allocate "frame%"
|
|
'(lambda () (let ([f (make-object frame% "test frame")])
|
|
(send f show #t)
|
|
f))
|
|
'(lambda (f) (send f show #f)))
|
|
|
|
|
|
(define (test-editor-allocate object-name)
|
|
(test-allocate (symbol->string object-name)
|
|
`(lambda () (make-object ,object-name))
|
|
'(lambda (e) (send e on-close))))
|
|
|
|
(test-editor-allocate 'text:basic%)
|
|
(test-editor-allocate 'text:keymap%)
|
|
(test-editor-allocate 'text:autowrap%)
|
|
(test-editor-allocate 'text:file%)
|
|
(test-editor-allocate 'text:clever-file-format%)
|
|
(test-editor-allocate 'text:backup-autosave%)
|
|
(test-editor-allocate 'text:searching%)
|
|
(test-editor-allocate 'text:info%)
|
|
|
|
(test-editor-allocate 'pasteboard:basic%)
|
|
(test-editor-allocate 'pasteboard:keymap%)
|
|
(test-editor-allocate 'pasteboard:file%)
|
|
(test-editor-allocate 'pasteboard:backup-autosave%)
|
|
(test-editor-allocate 'pasteboard:info%)
|
|
|
|
(test-editor-allocate 'scheme:text%)
|
|
|
|
(test-allocate "text:return%"
|
|
'(lambda () (make-object text:return% void))
|
|
'(lambda (t) (void)))
|
|
|
|
|
|
(test-frame-allocate 'frame:basic%)
|
|
(test-frame-allocate 'frame:info%)
|
|
(test-frame-allocate 'frame:text-info%)
|
|
(test-frame-allocate 'frame:pasteboard-info%)
|
|
(test-frame-allocate 'frame:standard-menus%)
|
|
|
|
(test-frame-allocate 'frame:text%)
|
|
(test-frame-allocate 'frame:text-info-file%)
|
|
(test-frame-allocate 'frame:searchable%)
|
|
|
|
(test-frame-allocate 'frame:pasteboard%)
|
|
(test-frame-allocate 'frame:pasteboard-info-file%)
|
|
(done)
|
|
|