From: Chris Hanson Date: Sun, 30 Apr 2000 22:17:19 +0000 (+0000) Subject: Create new procedure MESSAGE-WRAPPER to capture standard pattern of X-Git-Tag: 20090517-FFI~3960 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b1a51c6e44ccf92750f7a9ee9677e23baaf5fa02;p=mit-scheme.git Create new procedure MESSAGE-WRAPPER to capture standard pattern of "..." followed by "...done". This eliminates error-prone uses of APPEND-MESSAGE. --- diff --git a/v7/src/6001/edextra.scm b/v7/src/6001/edextra.scm index fb1d39955..671c00383 100644 --- a/v7/src/6001/edextra.scm +++ b/v7/src/6001/edextra.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: edextra.scm,v 1.30 2000/03/23 22:35:30 cph Exp $ +$Id: edextra.scm,v 1.31 2000/04/30 22:17:19 cph Exp $ Copyright (c) 1992-2000 Massachusetts Institute of Technology @@ -125,29 +125,28 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (editor-error "Not a window object!")))))) (define (print-given-x-window x-window-id) - (message "Spooling...") - (shell-command - false false false false - (string-append (->namestring - (merge-pathnames "bin/print-given-x-window" - student-root-directory)) - " 0x" - (number->string x-window-id 16) - " " - (print/assemble-switches "Scheme Picture" '()))) - (append-message "done")) + ((message-wrapper #f "Spooling") + (lambda () + (shell-command + false false false false + (string-append (->namestring + (merge-pathnames "bin/print-given-x-window" + student-root-directory)) + " 0x" + (number->string x-window-id 16) + " " + (print/assemble-switches "Scheme Picture" '())))))) (define (print-pointed-x-window) - (message "Click desired window...") - (shell-command - false false false false - (string-append (->namestring - (merge-pathnames "bin/print-pointed-x-window" - student-root-directory)) - " " - (print/assemble-switches "Scheme Picture" '()))) - (append-message "done")) - + ((message-wrapper #f "Click desired window") + (lambda () + (shell-command + false false false false + (string-append (->namestring + (merge-pathnames "bin/print-pointed-x-window" + student-root-directory)) + " " + (print/assemble-switches "Scheme Picture" '())))))) #| ;;; If using pointer (mouse). @@ -273,15 +272,19 @@ Now, there is formatting stuff to be considered here, in print-pgm.sh. (groups/files-to-reference groups)) (for-each (lambda (file) (let ((filename (merge-pathnames file pset-path))) - (message "Evaluating file " (->namestring filename)) - (load-quietly filename '(STUDENT)) - (append-message " -- done"))) + ((message-wrapper #f + "Evaluating file " + (->namestring filename)) + (lambda () + (load-quietly filename '(STUDENT)))))) (groups/files-to-load groups)) (for-each (lambda (file) (let ((filename (merge-pathnames file pset-path))) - (message "Evaluating file " (->namestring filename)) - (load-quietly filename '(STUDENT)) - (append-message " -- done") + ((message-wrapper #f + "Evaluating file " + (->namestring filename)) + (lambda () + (load-quietly filename '(STUDENT)))) (find-file-noselect filename #t))) (groups/files-to-load&reference groups)) (for-each (lambda (file) diff --git a/v7/src/edwin/abbrev.scm b/v7/src/edwin/abbrev.scm index 14cedc691..d35792dd6 100644 --- a/v7/src/edwin/abbrev.scm +++ b/v7/src/edwin/abbrev.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: abbrev.scm,v 1.3 2000/04/04 16:53:05 cph Exp $ +;;; $Id: abbrev.scm,v 1.4 2000/04/30 22:16:57 cph Exp $ ;;; ;;; Copyright (c) 2000 Massachusetts Institute of Technology ;;; @@ -569,9 +569,9 @@ it defaults to the value of `abbrev-file-name'." (list (ref-variable abbrev-file-name #f))))) (lambda (filename) (let ((filename (abbrev-file/filename filename))) - (message "Loading " filename "...") - (quietly-read-abbrev-file filename) - (append-message "done")))) + ((message-wrapper #f "Loading " filename) + (lambda () + (quietly-read-abbrev-file filename)))))) (define (quietly-read-abbrev-file #!optional filename) (let ((filename diff --git a/v7/src/edwin/autold.scm b/v7/src/edwin/autold.scm index c2549858f..6b77f7c43 100644 --- a/v7/src/edwin/autold.scm +++ b/v7/src/edwin/autold.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;;$Id: autold.scm,v 1.55 1999/02/02 19:50:11 cph Exp $ +;;;$Id: autold.scm,v 1.56 2000/04/30 22:16:58 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-2000 Massachusetts Institute of Technology ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU General Public License as @@ -194,9 +194,9 @@ Second arg is prefix arg when called interactively." evaluation-error-handler (lambda () (fluid-let ((load/suppress-loading-message? #t)) - (message "Loading " (car library) "...") - (do-it library) - (append-message "done")))))) + ((message-wrapper #f "Loading " (car library)) + (lambda () + (do-it library)))))))) (do-it library)))))) (cond ((not (library-loaded? name)) (do-it)) @@ -211,9 +211,9 @@ Second arg PURIFY? means purify the file's contents after loading; this is the prefix arg when called interactively." "fLoad file\nP" (lambda (filename purify?) - (temporary-message "Loading " filename "...") - (load-edwin-file filename '(EDWIN) purify?) - (append-message "done"))) + ((message-wrapper #f "Loading " filename) + (lambda () + (load-edwin-file filename '(EDWIN) purify?))))) (define (load-edwin-file filename environment purify?) (with-output-to-transcript-buffer diff --git a/v7/src/edwin/debug.scm b/v7/src/edwin/debug.scm index b656ca27c..8a0208d1c 100644 --- a/v7/src/edwin/debug.scm +++ b/v7/src/edwin/debug.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: debug.scm,v 1.49 2000/03/23 03:19:04 cph Exp $ +;;; $Id: debug.scm,v 1.50 2000/04/30 22:17:00 cph Exp $ ;;; ;;; Copyright (c) 1992-2000 Massachusetts Institute of Technology ;;; @@ -327,31 +327,32 @@ buffer (let ((write-description (bline-type/write-description (bline/type bline)))) - (temporary-message "Computing, please wait...") - (and write-description - (let ((buffer (browser/new-buffer (bline/browser bline) #f))) - (call-with-output-mark (buffer-start buffer) - (lambda (port) - (write-description bline port) - (if env-exists? - (begin - (debugger-newline port) - (write-string evaluation-line-marker port) - (debugger-newline port))))) - (set-buffer-point! buffer (buffer-start buffer)) - (1d-table/put! (bline/properties bline) - 'DESCRIPTION-BUFFER - buffer) - (read-only-between (buffer-start buffer) (buffer-end buffer)) - (buffer-not-modified! buffer) - (if env-exists? - (start-inferior-repl! - buffer - environment - (evaluation-syntax-table buffer environment) - #f)) - (append-message "done") - buffer)))))) + ((message-wrapper #t "Computing, please wait") + (lambda () + (and write-description + (let ((buffer (browser/new-buffer (bline/browser bline) #f))) + (call-with-output-mark (buffer-start buffer) + (lambda (port) + (write-description bline port) + (if env-exists? + (begin + (debugger-newline port) + (write-string evaluation-line-marker port) + (debugger-newline port))))) + (set-buffer-point! buffer (buffer-start buffer)) + (1d-table/put! (bline/properties bline) + 'DESCRIPTION-BUFFER + buffer) + (read-only-between (buffer-start buffer) + (buffer-end buffer)) + (buffer-not-modified! buffer) + (if env-exists? + (start-inferior-repl! + buffer + environment + (evaluation-syntax-table buffer environment) + #f)) + buffer)))))))) (define evaluation-line-marker ";EVALUATION may occur below in the environment of the selected frame.") diff --git a/v7/src/edwin/dired.scm b/v7/src/edwin/dired.scm index 35e8a3cd6..03c6e1ebe 100644 --- a/v7/src/edwin/dired.scm +++ b/v7/src/edwin/dired.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: dired.scm,v 1.181 2000/04/01 05:18:55 cph Exp $ +;;; $Id: dired.scm,v 1.182 2000/04/30 22:17:01 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-2000 Massachusetts Institute of Technology ;;; @@ -204,13 +204,12 @@ Type `h' after entering dired for more info." (file-list (cdr directory-spec))) (set-buffer-writeable! buffer) (region-delete! (buffer-region buffer)) - (temporary-message - (string-append "Reading directory " (->namestring pathname) "...")) - (read-directory pathname - file-list - (ref-variable dired-listing-switches buffer) - (buffer-point buffer)) - (append-message "done") + ((message-wrapper #t "Reading directory " (->namestring pathname)) + (lambda () + (read-directory pathname + file-list + (ref-variable dired-listing-switches buffer) + (buffer-point buffer)))) (let ((point (mark-left-inserting-copy (buffer-point buffer))) (group (buffer-group buffer))) (let ((index (mark-index (buffer-start buffer)))) diff --git a/v7/src/edwin/dosfile.scm b/v7/src/edwin/dosfile.scm index 9f0cde69a..aaca53fc0 100644 --- a/v7/src/edwin/dosfile.scm +++ b/v7/src/edwin/dosfile.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: dosfile.scm,v 1.36 2000/02/28 04:23:08 cph Exp $ +;;; $Id: dosfile.scm,v 1.37 2000/04/30 22:17:03 cph Exp $ ;;; ;;; Copyright (c) 1994-2000 Massachusetts Institute of Technology ;;; @@ -534,51 +534,49 @@ filename suffix \".gz\"." (equal? "gz" (pathname-type pathname)))) (define (read-compressed-file program arguments pathname mark) - (message "Uncompressing file " (->namestring pathname) "...") - (let ((value - (call-with-temporary-file-pathname - (lambda (temporary) - (if (not (equal? '(EXITED . 0) - (shell-command #f #f - (directory-pathname pathname) - #f - (string-append - (quote-program program arguments) - " < " - (file-namestring pathname) - " > " - (->namestring temporary))))) - (error:file-operation pathname - program - "file" - "[unknown]" - read-compressed-file - (list pathname mark))) - (group-insert-file! (mark-group mark) - (mark-index mark) - temporary - (pathname-newline-translation pathname)))))) - (append-message "done") - value)) + ((message-wrapper #f "Uncompressing file " (->namestring pathname)) + (lambda () + (call-with-temporary-file-pathname + (lambda (temporary) + (if (not (equal? '(EXITED . 0) + (shell-command #f #f + (directory-pathname pathname) + #f + (string-append + (quote-program program arguments) + " < " + (file-namestring pathname) + " > " + (->namestring temporary))))) + (error:file-operation pathname + program + "file" + "[unknown]" + read-compressed-file + (list pathname mark))) + (group-insert-file! (mark-group mark) + (mark-index mark) + temporary + (pathname-newline-translation pathname))))))) (define (write-compressed-file program arguments region pathname) - (message "Compressing file " (->namestring pathname) "...") - (if (not (equal? '(EXITED . 0) - (shell-command region - #f - (directory-pathname pathname) - #f - (string-append (quote-program program - arguments) - " > " - (file-namestring pathname))))) - (error:file-operation pathname - program - "file" - "[unknown]" - write-compressed-file - (list region pathname))) - (append-message "done")) + ((message-wrapper #f "Compressing file " (->namestring pathname)) + (lambda () + (if (not (equal? + '(EXITED . 0) + (shell-command region + #f + (directory-pathname pathname) + #f + (string-append (quote-program program arguments) + " > " + (file-namestring pathname))))) + (error:file-operation pathname + program + "file" + "[unknown]" + write-compressed-file + (list region pathname)))))) (define (quote-program program arguments) (string-append (if (eq? 'NT microcode-id/operating-system) diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index 13b6b0b25..701bd41b8 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: edwin.pkg,v 1.253 2000/04/30 21:52:50 cph Exp $ +$Id: edwin.pkg,v 1.254 2000/04/30 22:17:04 cph Exp $ Copyright (c) 1989-2000 Massachusetts Institute of Technology @@ -442,6 +442,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. keyboard-read-char message message-args->string + message-wrapper reset-command-prompt! set-command-prompt! temporary-message)) diff --git a/v7/src/edwin/input.scm b/v7/src/edwin/input.scm index e39e632d9..4af2806fb 100644 --- a/v7/src/edwin/input.scm +++ b/v7/src/edwin/input.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: input.scm,v 1.100 1999/01/02 06:11:34 cph Exp $ +;;; $Id: input.scm,v 1.101 2000/04/30 22:17:05 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-2000 Massachusetts Institute of Technology ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU General Public License as @@ -83,23 +83,23 @@ B 3BAB8C (define auto-save-keystroke-count) (define (initialize-typeout!) - (set! command-prompt-string false) - (set! command-prompt-displayed? false) - (set! message-string false) - (set! message-should-be-erased? false) + (set! command-prompt-string #f) + (set! command-prompt-displayed? #f) + (set! message-string #f) + (set! message-should-be-erased? #f) (set! auto-save-keystroke-count 0) unspecific) (define (reset-command-prompt!) ;; Should only be called by the command reader. This prevents ;; carryover from one command to the next. - (set! command-prompt-string false) + (set! command-prompt-string #f) (if command-prompt-displayed? ;; To make it more visible, the command prompt is erased after ;; timeout instead of right away. (begin - (set! command-prompt-displayed? false) - (set! message-should-be-erased? true))) + (set! command-prompt-displayed? #f) + (set! message-should-be-erased? #t))) unspecific) (define-integrable (command-prompt) @@ -115,18 +115,26 @@ B 3BAB8C (define (append-command-prompt! string) (if (not (string-null? string)) (set-command-prompt! (string-append (command-prompt) string)))) - + (define (message . args) - (%message (message-args->string args) false)) + (%message (message-args->string args) #f)) (define (temporary-message . args) - (%message (message-args->string args) true)) + (%message (message-args->string args) #t)) + +(define (message-wrapper temporary? . args) + (let ((msg (message-args->string args))) + (lambda (thunk) + (%message (string-append msg "...") temporary?) + (let ((value (thunk))) + (%message (string-append msg "...done") temporary?) + value)))) (define (%message string temporary?) (if command-prompt-displayed? (begin - (set! command-prompt-string false) - (set! command-prompt-displayed? false))) + (set! command-prompt-string #f) + (set! command-prompt-displayed? #f))) (set! message-string string) (set! message-should-be-erased? temporary?) (set-current-message! string)) @@ -137,6 +145,7 @@ B 3BAB8C args))) (define (append-message . args) + ;; Deprecated. Don't use this. (if (not message-string) (error "Attempt to append to nonexistent message")) (let ((string (string-append message-string (message-args->string args)))) @@ -146,8 +155,8 @@ B 3BAB8C (define (clear-message) (if message-string (begin - (set! message-string false) - (set! message-should-be-erased? false) + (set! message-string #f) + (set! message-should-be-erased? #f) (if (not command-prompt-displayed?) (clear-current-message!))))) @@ -219,31 +228,31 @@ B 3BAB8C (begin (do-auto-save) (set! auto-save-keystroke-count 0))) - (update-screens! false))) + (update-screens! #f))) (let ((wait (lambda (timeout) (let ((t (+ (real-time-clock) timeout))) (let loop () - (cond ((peek-no-hang) false) - ((>= (real-time-clock) t) true) + (cond ((peek-no-hang) #f) + ((>= (real-time-clock) t) #t) (else (loop)))))))) ;; Perform the appropriate juggling of the minibuffer message. (cond ((within-typein-edit?) (if message-string (begin (wait read-key-timeout/slow) - (set! message-string false) - (set! message-should-be-erased? false) + (set! message-string #f) + (set! message-should-be-erased? #f) (clear-current-message!)))) ((and (or message-should-be-erased? (and command-prompt-string (not command-prompt-displayed?))) (wait read-key-timeout/fast)) - (set! message-string false) - (set! message-should-be-erased? false) + (set! message-string #f) + (set! message-should-be-erased? #f) (if command-prompt-string (begin - (set! command-prompt-displayed? true) + (set! command-prompt-displayed? #t) (set-current-message! command-prompt-string)) (clear-current-message!))))) (reader))) diff --git a/v7/src/edwin/print.scm b/v7/src/edwin/print.scm index ccb9528de..c1f83c443 100644 --- a/v7/src/edwin/print.scm +++ b/v7/src/edwin/print.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: print.scm,v 1.18 1999/01/28 03:59:55 cph Exp $ +;;; $Id: print.scm,v 1.19 2000/04/30 22:17:07 cph Exp $ ;;; -;;; Copyright (c) 1991-1999 Massachusetts Institute of Technology +;;; Copyright (c) 1991-2000 Massachusetts Institute of Technology ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU General Public License as @@ -51,32 +51,32 @@ Variable LPR-SWITCHES is a list of extra switches (strings) to pass to lpr." (print-region/internal region true))) (define (print-region/internal region print-headers?) - (message "Spooling...") - (let ((buffer (mark-buffer (region-start region))) - (print-headers? (and print-headers? (not lpr-print-not-special?))) - (title (print-region-title-string region))) - (let ((call-printer - (lambda (region) - ((or (ref-variable lpr-procedure buffer) - (case microcode-id/operating-system - ((NT) print-region/nt) - (else print-region/default))) - region print-headers? title buffer))) - (width (ref-variable tab-width buffer))) - (if (= width 8) - (call-printer region) - (call-with-temporary-buffer " *spool temp*" - (lambda (temp-buffer) - (insert-region (region-start region) - (region-end region) - (buffer-point temp-buffer)) - (define-variable-local-value! temp-buffer - (ref-variable-object tab-width) - width) - (untabify-region (buffer-start temp-buffer) - (buffer-end temp-buffer)) - (call-printer (buffer-region temp-buffer))))))) - (append-message "done")) + ((message-wrapper #f "Spooling") + (lambda () + (let ((buffer (mark-buffer (region-start region))) + (print-headers? (and print-headers? (not lpr-print-not-special?))) + (title (print-region-title-string region))) + (let ((call-printer + (lambda (region) + ((or (ref-variable lpr-procedure buffer) + (case microcode-id/operating-system + ((NT) print-region/nt) + (else print-region/default))) + region print-headers? title buffer))) + (width (ref-variable tab-width buffer))) + (if (= width 8) + (call-printer region) + (call-with-temporary-buffer " *spool temp*" + (lambda (temp-buffer) + (insert-region (region-start region) + (region-end region) + (buffer-point temp-buffer)) + (define-variable-local-value! temp-buffer + (ref-variable-object tab-width) + width) + (untabify-region (buffer-start temp-buffer) + (buffer-end temp-buffer)) + (call-printer (buffer-region temp-buffer)))))))))) (define (print-region/default region print-headers? title buffer) (shell-command region false false false diff --git a/v7/src/edwin/unix.scm b/v7/src/edwin/unix.scm index e32cc1633..7859128db 100644 --- a/v7/src/edwin/unix.scm +++ b/v7/src/edwin/unix.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: unix.scm,v 1.107 2000/03/23 03:19:24 cph Exp $ +;;; $Id: unix.scm,v 1.108 2000/04/30 22:17:08 cph Exp $ ;;; ;;; Copyright (c) 1989-2000 Massachusetts Institute of Technology ;;; @@ -398,50 +398,49 @@ of the filename suffixes \".gz\", \".bz2\", or \".Z\"." '("gz" "bz2" "Z")) (define (read-compressed-file program pathname mark) - (message "Uncompressing file " (->namestring pathname) "...") - (let ((value - (call-with-temporary-file-pathname - (lambda (temporary) - (if (not (equal? '(EXITED . 0) - (shell-command #f #f - (directory-pathname pathname) - #f - (string-append - program - " < " - (file-namestring pathname) - " > " - (->namestring temporary))))) - (error:file-operation pathname - program - "file" - "[unknown]" - read-compressed-file - (list pathname mark))) - (group-insert-file! (mark-group mark) - (mark-index mark) - temporary - (pathname-newline-translation pathname)))))) - (append-message "done") - value)) + ((message-wrapper #f "Uncompressing file " (->namestring pathname)) + (lambda () + (call-with-temporary-file-pathname + (lambda (temporary) + (if (not (equal? '(EXITED . 0) + (shell-command #f #f + (directory-pathname pathname) + #f + (string-append + program + " < " + (file-namestring pathname) + " > " + (->namestring temporary))))) + (error:file-operation pathname + program + "file" + "[unknown]" + read-compressed-file + (list pathname mark))) + (group-insert-file! (mark-group mark) + (mark-index mark) + temporary + (pathname-newline-translation pathname))))))) (define (write-compressed-file program region pathname) - (message "Compressing file " (->namestring pathname) "...") - (if (not (equal? '(EXITED . 0) - (shell-command region - #f - (directory-pathname pathname) - #f - (string-append program - " > " - (file-namestring pathname))))) - (error:file-operation pathname - program - "file" - "[unknown]" - write-compressed-file - (list region pathname))) - (append-message "done")) + ((message-wrapper #f "Compressing file " (->namestring pathname)) + (lambda () + (if (not (equal? + '(EXITED . 0) + (shell-command region + #f + (directory-pathname pathname) + #f + (string-append program + " > " + (file-namestring pathname))))) + (error:file-operation pathname + program + "file" + "[unknown]" + write-compressed-file + (list region pathname)))))) ;;;; Dired customization diff --git a/v7/src/edwin/webster.scm b/v7/src/edwin/webster.scm index a9da70b3f..d0872e9b2 100644 --- a/v7/src/edwin/webster.scm +++ b/v7/src/edwin/webster.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: webster.scm,v 1.3 1999/01/02 06:11:34 cph Exp $ +$Id: webster.scm,v 1.4 2000/04/30 22:17:10 cph Exp $ -Copyright (c) 1998-1999 Massachusetts Institute of Technology +Copyright (c) 1998-2000 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -75,12 +75,12 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (let ((server (or (ref-variable webster-server buffer) (editor-error "Variable webster-server not set.")))) - (message "Opening webster connection to " server "...") - (set! webster-server-port - (open-tcp-stream-socket server - (ref-variable webster-port buffer) - 4096)) - (append-message "done") + ((message-wrapper #f "Opening webster connection to " server) + (lambda () + (set! webster-server-port + (open-tcp-stream-socket server + (ref-variable webster-port buffer) + 4096)))) (global-window-modeline-event! (lambda (window) window 'WEBSTER-CONNECTION-STATUS)))))