From: Chris Hanson Date: Sun, 8 Mar 1998 07:14:11 +0000 (+0000) Subject: Add argument to callers of POP-UP-TEMPORARY-BUFFER so that they can X-Git-Tag: 20090517-FFI~4833 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b4dd149db044e83e398f7ec813daeb175fe8aca0;p=mit-scheme.git Add argument to callers of POP-UP-TEMPORARY-BUFFER so that they can pass properties through. --- diff --git a/v7/src/edwin/bufcom.scm b/v7/src/edwin/bufcom.scm index 6f9768957..2e94c7e05 100644 --- a/v7/src/edwin/bufcom.scm +++ b/v7/src/edwin/bufcom.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: bufcom.scm,v 1.103 1997/05/18 07:50:30 cph Exp $ +;;; $Id: bufcom.scm,v 1.104 1998/03/08 07:10:12 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989-97 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-98 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -277,20 +277,20 @@ When locked, the buffer's major mode may not be changed." (kill-pop-up-buffer #f)))) (clear-message)))))) -(define (string->temporary-buffer string name) - (pop-up-temporary-buffer name '() +(define (string->temporary-buffer string name properties) + (pop-up-temporary-buffer name properties (lambda (buffer window) window (insert-string string (buffer-point buffer))))) -(define (call-with-output-to-temporary-buffer name procedure) - (pop-up-temporary-buffer name '() +(define (call-with-output-to-temporary-buffer name properties procedure) + (pop-up-temporary-buffer name properties (lambda (buffer window) window (call-with-output-mark (buffer-point buffer) procedure)))) -(define (with-output-to-temporary-buffer name thunk) - (call-with-output-to-temporary-buffer name +(define (with-output-to-temporary-buffer name properties thunk) + (call-with-output-to-temporary-buffer name properties (lambda (port) (with-output-to-port port thunk)))) diff --git a/v7/src/edwin/debuge.scm b/v7/src/edwin/debuge.scm index 1543fc450..e70e8177a 100644 --- a/v7/src/edwin/debuge.scm +++ b/v7/src/edwin/debuge.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: debuge.scm,v 1.51 1995/09/13 03:57:22 cph Exp $ +;;; $Id: debuge.scm,v 1.52 1998/03/08 07:13:55 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989-95 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-98 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -116,7 +116,7 @@ "" () (lambda () - (with-output-to-temporary-buffer "*standard-marks*" + (with-output-to-temporary-buffer "*standard-marks*" '() (lambda () (let ((buffer-frame (current-window))) (let ((window (car (instance-ref buffer-frame 'text-inferior))) diff --git a/v7/src/edwin/hlpcom.scm b/v7/src/edwin/hlpcom.scm index a4cbba53a..58f21a697 100644 --- a/v7/src/edwin/hlpcom.scm +++ b/v7/src/edwin/hlpcom.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: hlpcom.scm,v 1.107 1993/10/14 22:43:35 cph Exp $ +;;; $Id: hlpcom.scm,v 1.108 1998/03/08 07:13:47 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-98 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -323,7 +323,7 @@ If you want VALUE to be a string, you must surround it with doublequotes." (buffer-not-modified! buffer))))))) (define (with-output-to-help-display thunk) - (with-output-to-temporary-buffer "*Help*" thunk)) + (with-output-to-temporary-buffer "*Help*" '() thunk)) (define (write-description description) (write-string (substitute-command-keys description))) diff --git a/v7/src/edwin/info.scm b/v7/src/edwin/info.scm index fc6603683..e6126b01e 100644 --- a/v7/src/edwin/info.scm +++ b/v7/src/edwin/info.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: info.scm,v 1.128 1998/01/23 05:26:51 cph Exp $ +;;; $Id: info.scm,v 1.129 1998/03/08 07:13:33 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-98 Massachusetts Institute of Technology ;;; @@ -689,7 +689,7 @@ The name may be an abbreviation of the reference name." (define (report-losers losers) (if (null? losers) (message "File appears valid") - (with-output-to-temporary-buffer " *problems in info file*" + (with-output-to-temporary-buffer " *problems in info file*" '() (lambda () (for-each (lambda (loser) (write-string diff --git a/v7/src/edwin/prompt.scm b/v7/src/edwin/prompt.scm index fd1904a22..f2e4469b1 100644 --- a/v7/src/edwin/prompt.scm +++ b/v7/src/edwin/prompt.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: prompt.scm,v 1.169 1997/07/21 04:37:33 cph Exp $ +;;; $Id: prompt.scm,v 1.170 1998/03/08 07:13:11 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989-97 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-98 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -636,22 +636,11 @@ a repetition of this command will exit." (begin (editor-beep) (completion-message "No completions")) - (begin - (pop-up-completions-list completions) - (if (not (typein-window? (current-window))) - (begin - (message "Hit space to flush.") - (reset-command-prompt!) - (let ((char (keyboard-peek))) - (if (and (char? char) - (char=? #\space char)) - (begin - (keyboard-read) - (kill-pop-up-buffer false)))) - (clear-message))))))))) + (pop-up-completions-list completions)))))) (define (pop-up-completions-list strings) (with-output-to-temporary-buffer " *Completions*" + '(SHRINK-WINDOW FLUSH-ON-SPACE) (lambda () (write-completions-list strings)))) diff --git a/v7/src/edwin/regcom.scm b/v7/src/edwin/regcom.scm index 8c85f3c8b..94d3c575c 100644 --- a/v7/src/edwin/regcom.scm +++ b/v7/src/edwin/regcom.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/regcom.scm,v 1.20 1991/08/06 15:39:38 arthur Exp $ +;;; $Id: regcom.scm,v 1.21 1998/03/08 07:10:44 cph Exp $ ;;; -;;; Copyright (c) 1987, 1989 Massachusetts Institute of Technology +;;; Copyright (c) 1987-98 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -149,7 +149,7 @@ With prefix arg, delete as well." (let ((value (get-register register))) (if (not value) (message "Register " (key-name register) " is empty") - (with-output-to-temporary-buffer "*Output*" + (with-output-to-temporary-buffer "*Output*" '() (lambda () (write-string "Register ") (write-string (key-name register)) diff --git a/v7/src/edwin/vc.scm b/v7/src/edwin/vc.scm index 59577b6c1..c2a972b71 100644 --- a/v7/src/edwin/vc.scm +++ b/v7/src/edwin/vc.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: vc.scm,v 1.28 1998/02/13 19:40:56 cph Exp $ +;;; $Id: vc.scm,v 1.29 1998/03/08 07:14:11 cph Exp $ ;;; ;;; Copyright (c) 1994-98 Massachusetts Institute of Technology ;;; @@ -911,6 +911,7 @@ the value of vc-log-mode-hook." (cleanup-pop-up-buffers (lambda () (call-with-output-to-temporary-buffer " *VC-types*" + '(SHRINK-WINDOW) (lambda (port) (for-each (lambda (entry) (write-string (car entry) port)