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

.

Browse Source 
original commit: dbc683d4dc362e7361960eca3398064b69af53b6
This commit is contained in:
Matthew Flatt 2002-07-03 23:05:02 +00:00
parent 7b40de8849
commit b50ad4b637
2 changed files with 8 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
collects/mred/mred.ss
View File

@ -5191,7 +5191,7 @@
(cons (read-string n s) (cons (read-string n s)
(loop)))))))) (loop))))))))
(define (mk-file-selector who put? multi? dir?) (define (mk-file-selector who put? multi? dir? force-unix?)
(lambda (message parent directory filename extension style filters) (lambda (message parent directory filename extension style filters)
;; Calls from C++ have wrong kind of window: ;; Calls from C++ have wrong kind of window:
(when (is-a? parent wx:window%) (when (is-a? parent wx:window%)
@ -5209,7 +5209,8 @@
(string? (cadr p)))) (string? (cadr p))))
filters)) filters))
(raise-type-error who "list of 2-string lists" filters)) (raise-type-error who "list of 2-string lists" filters))
(if (not (eq? (system-type) 'unix)) (if (not (or (eq? (system-type) 'unix)
force-unix?))
(let ([s (wx:file-selector message directory filename extension (let ([s (wx:file-selector message directory filename extension
(apply string-append (apply string-append
(map (lambda (s) (format "~a|~a|" (car s) (cadr s))) (map (lambda (s) (format "~a|~a|" (car s) (cadr s)))
@ -5406,7 +5407,7 @@
[(message parent directory filename extension style) [(message parent directory filename extension style)
(get-file message parent directory filename extension style default-filters)] (get-file message parent directory filename extension style default-filters)]
[(message parent directory filename extension style filters) [(message parent directory filename extension style filters)
((mk-file-selector 'get-file #f #f #f) message parent directory filename extension style filters)])) ((mk-file-selector 'get-file #f #f #f #f) message parent directory filename extension style filters)]))
(define get-file-list (define get-file-list
(case-lambda (case-lambda
@ -5419,7 +5420,7 @@
[(message parent directory filename extension style) [(message parent directory filename extension style)
(get-file-list message parent directory filename extension style default-filters)] (get-file-list message parent directory filename extension style default-filters)]
[(message parent directory filename extension style filters) [(message parent directory filename extension style filters)
((mk-file-selector 'get-file-list #f #t #f) message parent directory filename extension style filters)])) ((mk-file-selector 'get-file-list #f #t #f #f) message parent directory filename extension style filters)]))
(define put-file (define put-file
(case-lambda (case-lambda
@ -5432,7 +5433,7 @@
[(message parent directory filename extension style) [(message parent directory filename extension style)
(put-file message parent directory filename extension style default-filters)] (put-file message parent directory filename extension style default-filters)]
[(message parent directory filename extension style filters) [(message parent directory filename extension style filters)
((mk-file-selector 'put-file #t #f #f) message parent directory filename extension style filters)])) ((mk-file-selector 'put-file #t #f #f #f) message parent directory filename extension style filters)]))
(define get-directory (define get-directory
(case-lambda (case-lambda
@ -5452,7 +5453,7 @@
message directory #f #f #f message directory #f #f #f
'dir 'dir
(and parent (mred->wx parent))) (and parent (mred->wx parent)))
((mk-file-selector 'get-directory #f #f #t) message parent directory #f #f style null))])) ((mk-file-selector 'get-directory #f #f #t #t) message parent directory #f #f style null))]))
(define get-color-from-user (define get-color-from-user
(case-lambda (case-lambda

1
collects/mred/private/kernel.ss
View File

@ -908,6 +908,7 @@
set-clipboard-client) set-clipboard-client)
(define-function get-the-clipboard) (define-function get-the-clipboard)
(define-class clipboard-client% object% () (define-class clipboard-client% object% ()
queue-callback
get-types get-types
add-type add-type
get-data get-data