reformat
svn: r9737
This commit is contained in:
parent
68a266599d
commit
fc3115d6bc
|
@ -1,173 +1,174 @@
|
|||
(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)
|
||||
#lang mzscheme
|
||||
(require "test-suite-utils.ss")
|
||||
|
||||
;; 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)
|
||||
; 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)
|
||||
(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)
|
||||
(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)
|
||||
(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))
|
||||
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)
|
||||
|
|
Loading…
Reference in New Issue
Block a user