#| -*-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
(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).
(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)
;;; -*-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
;;;
(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
;;; -*-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
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))
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
;;; -*-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
;;;
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.")
;;; -*-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
;;;
(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))))
;;; -*-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
;;;
(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)
#| -*-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
keyboard-read-char
message
message-args->string
+ message-wrapper
reset-command-prompt!
set-command-prompt!
temporary-message))
;;; -*-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
(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)
(define (append-command-prompt! string)
(if (not (string-null? string))
(set-command-prompt! (string-append (command-prompt) string))))
-
+\f
(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))
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))))
(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!)))))
\f
(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)))
;;; -*-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
(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))))))))))
\f
(define (print-region/default region print-headers? title buffer)
(shell-command region false false false
;;; -*-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
;;;
'("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))))))
\f
;;;; Dired customization
#| -*-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
(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)))))
projects / mit-scheme.git / commitdiff