174 lines
6.6 KiB
Scheme
174 lines
6.6 KiB
Scheme
(module mem mzscheme
|
|
(require "test-suite-utils.ss")
|
|
|
|
; mem-boxes : (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)
|
|
|
|
;; break at least that link.
|
|
(set! o #f)
|
|
|
|
;; flush pending events
|
|
(let ([s (make-semaphore 0)])
|
|
(queue-callback (lambda () (semaphore-post s)) #f)
|
|
(yield s))
|
|
|
|
(cons b (loop (- n 1))))]))])
|
|
(sleep/yield 1/10) (collect-garbage)
|
|
(sleep/yield 1/10) (collect-garbage)
|
|
(sleep/yield 1/10) (collect-garbage)
|
|
(set! mem-boxes (cons (list ,tag new-boxes) mem-boxes)))))
|
|
|
|
(define (done)
|
|
(send-sexp-to-mred
|
|
`(begin
|
|
(yield) (collect-garbage)
|
|
(yield) (collect-garbage)
|
|
(yield) (collect-garbage)
|
|
(yield) (collect-garbage)
|
|
(yield) (collect-garbage)
|
|
(yield) (collect-garbage)
|
|
(let* ([f (make-object dialog% "Results" #f 300 500)]
|
|
[text (make-object text%)]
|
|
[ec (make-object editor-canvas% f text)]
|
|
[hp (instantiate horizontal-panel% ()
|
|
(parent f)
|
|
(stretchable-width #f)
|
|
(stretchable-height #f))]
|
|
[vp (instantiate vertical-panel% ()
|
|
(parent hp)
|
|
(stretchable-width #f)
|
|
(stretchable-height #f))]
|
|
[gc-canvas (make-object canvas% hp '(border))]
|
|
[anything? #f])
|
|
|
|
(define (update-gui)
|
|
(send text erase)
|
|
(let ([anything? #f])
|
|
(send text begin-edit-sequence)
|
|
(for-each
|
|
(lambda (boxl)
|
|
(let* ([tag (car boxl)]
|
|
[boxes (cadr boxl)]
|
|
[calc-results
|
|
(lambda ()
|
|
(let loop ([boxes boxes]
|
|
[n 0])
|
|
(cond
|
|
[(null? boxes) n]
|
|
[else (if (weak-box-value (car boxes))
|
|
(loop (cdr boxes) (+ n 1))
|
|
(loop (cdr boxes) n))])))])
|
|
(let ([res (calc-results)])
|
|
(when (> res 0)
|
|
(set! anything? #t)
|
|
(send text insert (format "~a: ~a of ~a\n" tag res ,mem-count))))))
|
|
(reverse mem-boxes))
|
|
(unless anything?
|
|
(send text insert "Nothing!\n"))
|
|
(send text end-edit-sequence)))
|
|
|
|
(update-gui)
|
|
|
|
(let ([onb (icon:get-gc-on-bitmap)]
|
|
[offb (icon:get-gc-off-bitmap)])
|
|
(when (and (send onb ok?)
|
|
(send offb ok?))
|
|
(send* gc-canvas
|
|
(min-client-width (max (send gc-canvas min-width) (send onb get-width)))
|
|
(min-client-height (max (send gc-canvas min-height) (send onb get-height)))
|
|
(stretchable-width #f)
|
|
(stretchable-height #f))
|
|
(register-collecting-blit gc-canvas
|
|
0 0
|
|
(send onb get-width)
|
|
(send onb get-height)
|
|
onb offb)))
|
|
|
|
(make-object button%
|
|
"Collect"
|
|
vp
|
|
(lambda (x y)
|
|
(send text erase)
|
|
(send text insert "Collecting Garbage\n")
|
|
(collect-garbage)(collect-garbage)(collect-garbage)
|
|
(collect-garbage)(collect-garbage)(collect-garbage)
|
|
(collect-garbage)(collect-garbage)(collect-garbage)
|
|
(update-gui)))
|
|
(make-object button% "Close" vp (lambda (x y) (send f show #f)))
|
|
(send f show #t)))))
|
|
|
|
(define (test-frame-allocate %)
|
|
(let ([name (format "~s" %)])
|
|
(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)
|
|
(when (send f is-shown?)
|
|
(error 'test-frame-allocate "~a instance didn't 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 '(class frame% (inherit show) (define/public (close) (show #f)) (super-new)))
|
|
(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:searchable%)
|
|
|
|
(test-frame-allocate 'frame:pasteboard%)
|
|
(done))
|