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

fixed let-values

Browse Source 
original commit: 9e85d7cf11580b2be03787a28178bcb8038a1bd2
This commit is contained in:
Robby Findler 1996-09-12 21:56:37 +00:00
parent 8e82ccef96
commit 26c56232f7
1 changed files with 44 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
collects/mred/keys.ss
View File

@ -69,50 +69,50 @@
(k (wx:message-box "no file associated with this edit"))) (k (wx:message-box "no file associated with this edit")))
(let-values ([(my-out my-in my-pid my-err) (let-values ([(my-out my-in my-pid my-err)
(apply values (process* (build-path rcs-pathname "rlog") (apply values (process* (build-path rcs-pathname "rlog")
"-L" "-R" (string-append "-l" username) filename))] "-L" "-R" (string-append "-l" username) filename))])
[(their-out their-in their-pid their-err) (let-values ([(their-out their-in their-pid their-err)
(apply values (process* (build-path rcs-pathname "rlog") (apply values (process* (build-path rcs-pathname "rlog")
"-L" "-R" "-l" filename))]) "-L" "-R" "-l" filename))])
(let ([my-lock? (not (eof-object? (read my-out)))] (let ([my-lock? (not (eof-object? (read my-out)))]
[locked? (not (eof-object? (read their-out)))]) [locked? (not (eof-object? (read their-out)))])
(for-each close-input-port (list my-out my-err their-out their-err)) (for-each close-input-port (list my-out my-err their-out their-err))
(for-each close-output-port (list my-in their-in)) (for-each close-output-port (list my-in their-in))
(cond (cond
[(not (system* (build-path rcs-pathname "rlog") "-h" "-q" filename)) [(not (system* (build-path rcs-pathname "rlog") "-h" "-q" filename))
(system* (build-path rcs-pathname "ci") "-t-" filename) (system* (build-path rcs-pathname "ci") "-t-" filename)
(wx:message-box "Initial Checkin Completed")] (wx:message-box "Initial Checkin Completed")]
[my-lock? [my-lock?
(when (send edit modified?) (when (send edit modified?)
(case (mred:gui-utils:unsaved-warning (send edit get-filename) "Checkin" #t) (case (mred:gui-utils:unsaved-warning (send edit get-filename) "Checkin" #t)
[(save) (send edit save-file (send edit get-filename) [(save) (send edit save-file (send edit get-filename)
(send edit get-file-format))] (send edit get-file-format))]
[(cancel) (k (void))] [(cancel) (k (void))]
[else (void)])) [else (void)]))
(let* ([msg (wx:get-text-from-user "Please Enter Log Message" (let* ([msg (wx:get-text-from-user "Please Enter Log Message"
"Check In" "Check In"
last-checkin-string)] last-checkin-string)]
[result (system* (build-path rcs-pathname "ci") [result (system* (build-path rcs-pathname "ci")
"-u" (string-append "-m" msg) filename)]) "-u" (string-append "-m" msg) filename)])
(set! last-checkin-string msg) (set! last-checkin-string msg)
(if result (if result
(send edit load-file (send edit load-file
(send edit get-filename) (send edit get-filename)
(send edit get-file-format)) (send edit get-file-format))
(wx:message-box "Checkin Unsucessful")))] (wx:message-box "Checkin Unsucessful")))]
[locked? (wx:message-box "Someone else has the lock")] [locked? (wx:message-box "Someone else has the lock")]
[else [else
(let ([current-dir (current-directory)]) (let ([current-dir (current-directory)])
(let-values ([(base name _) (split-path filename)]) (let-values ([(base name _) (split-path filename)])
(unless (eq? 'relative base) (unless (eq? 'relative base)
(current-directory base)) (current-directory base))
(let ([res (system* (build-path rcs-pathname "co") (let ([res (system* (build-path rcs-pathname "co")
"-q" "-l" name)]) "-q" "-l" name)])
(current-directory current-dir) (current-directory current-dir)
(if res (if res
(send edit load-file (send edit load-file
(send edit get-filename) (send edit get-filename)
(send edit get-file-format)) (send edit get-file-format))
(wx:message-box "Checkout Failed")))))])))))))] (wx:message-box "Checkout Failed")))))]))))))))]
[ring-bell [ring-bell
(lambda (edit event) (lambda (edit event)