suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

...

Browse Source 
original commit: 043cc4c839b6b142ec48f8309579eeb676b3b4ea
This commit is contained in:
Robby Findler 2000-01-23 18:06:36 +00:00
parent db48a823e6
commit 0d3b83b22a
2 changed files with 38 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
collects/framework/editor.ss
View File

@ -236,9 +236,11 @@
get-top-level-window)
(rename [super-after-save-file after-save-file]
[super-after-load-file after-load-file]
[super-get-keymaps get-keymaps])
[super-get-keymaps get-keymaps]
[super-set-filename set-filename])
(override [editing-this-file? (lambda () #t)])
(override
[editing-this-file? (lambda () #t)])
(inherit get-canvases)
(private
@ -253,28 +255,37 @@
filename))))])
(lock lock?)))]
[update-filename
(lambda ()
(for-each (lambda (canvas)
(let ([tlw (send canvas get-top-level-window)])
(when (is-a? tlw frame:editor<%>)
(let ([filename (mzlib:file:normalize-path (get-filename))])
(let-values ([(base name dir) (split-path filename)])
(send tlw set-label name))))))
(get-canvases)))])
(lambda (name)
(let ([filename (if name
(let-values ([(base name dir) (split-path (mzlib:file:normalize-path name))])
name)
"")])
(for-each (lambda (canvas)
(let ([tlw (send canvas get-top-level-window)])
(when (is-a? tlw frame:editor<%>)
(send tlw set-label name))))
(get-canvases))))])
(override
[after-save-file
(lambda (success)
(when success
(check-lock)
(update-filename))
(check-lock))
(super-after-save-file success))]
[after-load-file
(lambda (sucessful?)
(when sucessful?
(check-lock)
(update-filename))
(check-lock))
(super-after-load-file sucessful?))]
[set-filename
(case-lambda
[(name) (set-filename name #f)]
[(name temp?)
(super-set-filename name temp?)
(unless temp?
(update-filename name))])]
[get-keymaps
(lambda ()
(cons (keymap:get-file) (super-get-keymaps)))])

22
collects/framework/splash.ss
View File

@ -96,6 +96,11 @@
(send frame show #t)
(flush-display) (yield) (sleep)
(flush-display) (yield) (sleep))]
[(inc-splash)
(lambda ()
(set! splash-current-width (+ splash-current-width 1))
(when (<= splash-current-width splash-max-width)
(send gauge set-value splash-current-width)))]
[(splash-load-handler)
(let ([depth 0])
(lambda (old-load f)
@ -104,9 +109,7 @@
(dynamic-wind
(lambda () (void))
(lambda ()
(set! splash-current-width (+ splash-current-width 1))
(when (<= splash-current-width splash-max-width)
(send gauge set-value splash-current-width))
(inc-splash)
(set! depth (+ depth 1))
(begin0 (old-load f)
(set! error? #f)))
@ -116,16 +119,17 @@
(begin (set! depth (- depth 1))
#t)))))))]
[(_4) (current-load
(let ([old-load (current-load)])
(lambda (f)
(splash-load-handler old-load f))))]
(let ([old-load (current-load)])
(lambda (f)
(splash-load-handler old-load f))))]
[(shutdown-splash)
(lambda ()
(set! splash-load-handler (lambda (old-load f) (old-load f)))
(unless (= splash-max-width splash-current-width)
(set-resource splash-width-resource (max 1 splash-current-width))))]
(set! splash-load-handler (lambda (old-load f) (old-load f))))]
[(close-splash)
(lambda ()
(inc-splash)
(unless (= splash-max-width splash-current-width)
(set-resource splash-width-resource (max 1 splash-current-width)))
(set! quit-on-close? #f)
(send frame show #f))])
(values