From c5566269fa2ecdf4b5c211a221142b85717035e9 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 28 Jan 1999 04:00:18 +0000 Subject: [PATCH] Revamp of prompting code. New design supports keyword arguments to most prompting procedures, to support options in an extensible way. The new keyword options are used to implement a general history mechanism, like that previously implemented by repeat-complex-command (which is now implemented using the new mechanism). This edit has made incompatible changes to the calling conventions of the following procedures: prompt-for-buffer-name prompt-for-expression prompt-for-pathname prompt-for-pathname* prompt-for-string prompt-for-completed-string prompt-for-string-table-name prompt-for-string-table-value --- v7/src/edwin/bufcom.scm | 35 +-- v7/src/edwin/compile.scm | 6 +- v7/src/edwin/comred.scm | 6 +- v7/src/edwin/dired.scm | 7 +- v7/src/edwin/edwin.pkg | 5 +- v7/src/edwin/evlcom.scm | 83 +++--- v7/src/edwin/filcom.scm | 73 +++--- v7/src/edwin/kmacro.scm | 9 +- v7/src/edwin/make.scm | 4 +- v7/src/edwin/print.scm | 4 +- v7/src/edwin/prompt.scm | 538 ++++++++++++++++++++++----------------- v7/src/edwin/replaz.scm | 8 +- v7/src/edwin/rmail.scm | 10 +- v7/src/edwin/snr.scm | 6 +- v7/src/edwin/tagutl.scm | 8 +- 15 files changed, 431 insertions(+), 371 deletions(-) diff --git a/v7/src/edwin/bufcom.scm b/v7/src/edwin/bufcom.scm index 7b0e2d142..3230f0921 100644 --- a/v7/src/edwin/bufcom.scm +++ b/v7/src/edwin/bufcom.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: bufcom.scm,v 1.105 1999/01/02 06:11:34 cph Exp $ +;;; $Id: bufcom.scm,v 1.106 1999/01/28 03:59:44 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology ;;; @@ -286,11 +286,11 @@ When locked, the buffer's major mode may not be changed." (buffer-reset! buffer) buffer)) -(define (prompt-for-buffer prompt default-buffer) +(define (prompt-for-buffer prompt default-buffer . options) (let ((name - (prompt-for-buffer-name prompt - default-buffer - (not (ref-variable select-buffer-create))))) + (apply prompt-for-buffer-name prompt default-buffer + 'REQUIRE-MATCH? (not (ref-variable select-buffer-create)) + options))) (or (find-buffer name) (let loop ((hooks (ref-variable select-buffer-not-found-hooks))) (cond ((null? hooks) @@ -317,15 +317,16 @@ This variable has no effect if select-buffer-create is false." '() list?) -(define (prompt-for-existing-buffer prompt default-buffer) - (find-buffer (prompt-for-buffer-name prompt default-buffer true) #t)) - -(define (prompt-for-buffer-name prompt default-buffer require-match?) - (prompt-for-string-table-name prompt - (and default-buffer - (buffer-name default-buffer)) - (if default-buffer - 'VISIBLE-DEFAULT - 'NO-DEFAULT) - (buffer-names) - require-match?)) \ No newline at end of file +(define (prompt-for-existing-buffer prompt default-buffer . options) + (find-buffer (apply prompt-for-buffer-name prompt default-buffer + 'REQUIRE-MATCH? #t + options) + #t)) + +(define (prompt-for-buffer-name prompt default-buffer . options) + (apply prompt-for-string-table-name + prompt + (and default-buffer (buffer-name default-buffer)) + (buffer-names) + 'DEFAULT-TYPE (if default-buffer 'VISIBLE-DEFAULT 'NO-DEFAULT) + options)) \ No newline at end of file diff --git a/v7/src/edwin/compile.scm b/v7/src/edwin/compile.scm index 12fe17dfc..4b1eee638 100644 --- a/v7/src/edwin/compile.scm +++ b/v7/src/edwin/compile.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: compile.scm,v 1.5 1999/01/02 06:11:34 cph Exp $ +;;; $Id: compile.scm,v 1.6 1999/01/28 03:59:45 cph Exp $ ;;; ;;; Copyright (c) 1992-1999 Massachusetts Institute of Technology ;;; @@ -33,7 +33,7 @@ with output going to the buffer *compilation*." (lambda () (list (prompt-for-string "Compile command" (ref-variable compile-command) - 'INSERTED-DEFAULT))) + 'DEFAULT-TYPE 'INSERTED-DEFAULT))) (lambda (command) (set-variable! compile-command command) (run-compilation command))) @@ -43,7 +43,7 @@ with output going to the buffer *compilation*." (lambda () (list (prompt-for-string "Run grep (with args): " previous-grep-arguments - 'INSERTED-DEFAULT))) + 'DEFAULT-TYPE 'INSERTED-DEFAULT))) (lambda (command) (set! previous-grep-arguments command) (run-compilation (string-append "grep -n " command " /dev/null")))) diff --git a/v7/src/edwin/comred.scm b/v7/src/edwin/comred.scm index c9b33e508..75d6ac116 100644 --- a/v7/src/edwin/comred.scm +++ b/v7/src/edwin/comred.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: comred.scm,v 1.113 1999/01/02 06:11:34 cph Exp $ +;;; $Id: comred.scm,v 1.114 1999/01/28 03:59:45 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology ;;; @@ -436,7 +436,9 @@ ((#\r) (varies (current-region) '(CURRENT-REGION))) ((#\s) - (prompting (or (prompt-for-string prompt false 'NULL-DEFAULT) ""))) + (prompting + (or (prompt-for-string prompt #f 'DEFAULT-TYPE 'NULL-DEFAULT) + ""))) ((#\v) (prompting (variable-name (prompt-for-variable prompt)))) ((#\x) diff --git a/v7/src/edwin/dired.scm b/v7/src/edwin/dired.scm index f2d589012..1ab1f5e05 100644 --- a/v7/src/edwin/dired.scm +++ b/v7/src/edwin/dired.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: dired.scm,v 1.168 1999/01/02 06:11:34 cph Exp $ +;;; $Id: dired.scm,v 1.169 1999/01/28 03:59:47 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology ;;; @@ -498,7 +498,7 @@ With a prefix argument you can edit the current listing switches instead." (lambda (switches) (prompt-for-string "Listing switches (must contain -l)" switches - 'INSERTED-DEFAULT))) + 'DEFAULT-TYPE 'INSERTED-DEFAULT))) (dired-toggle-switch #\t)))) (define (dired-toggle-switch switch) @@ -616,8 +616,7 @@ When renaming multiple or marked files, you specify a directory." " " (file-namestring from) " to") - from - #f))) + from))) (let ((condition (operation lstart from (if (file-directory? to) diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index 80c3081ad..adb704881 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: edwin.pkg,v 1.232 1999/01/14 21:38:02 cph Exp $ +$Id: edwin.pkg,v 1.233 1999/01/28 03:59:49 cph Exp $ Copyright (c) 1989-1999 Massachusetts Institute of Technology @@ -453,14 +453,11 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. edwin-command$minibuffer-complete-word edwin-command$minibuffer-completion-help edwin-command$minibuffer-yank-default - edwin-command$next-complex-command - edwin-command$previous-complex-command edwin-command$repeat-complex-command edwin-mode$minibuffer-local edwin-mode$minibuffer-local-completion edwin-mode$minibuffer-local-must-match edwin-mode$minibuffer-local-yes-or-no - edwin-mode$repeat-complex-command edwin-variable$enable-recursive-minibuffers edwin-variable$completion-auto-help initialize-typein! diff --git a/v7/src/edwin/evlcom.scm b/v7/src/edwin/evlcom.scm index c54b57d63..6670ad4f2 100644 --- a/v7/src/edwin/evlcom.scm +++ b/v7/src/edwin/evlcom.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: evlcom.scm,v 1.59 1999/01/02 06:11:34 cph Exp $ +;;; $Id: evlcom.scm,v 1.60 1999/01/28 03:59:51 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology ;;; @@ -272,44 +272,40 @@ Has no effect if evaluate-in-inferior-repl is false." ;;;; Expression Prompts -(define (prompt-for-expression-value prompt #!optional default) +(define (prompt-for-expression-value prompt #!optional default . options) (let ((buffer (current-buffer))) - (eval-with-history - buffer - (if (default-object? default) - (prompt-for-expression prompt) - (prompt-for-expression prompt - (if (or (symbol? default) - (pair? default) - (vector? default)) - `',default - default))) - (evaluation-environment buffer)))) - -(define (prompt-for-expression prompt #!optional default-object default-type) - (let ((default-string - (and (not (default-object? default-object)) - (write-to-string default-object))) - (default-type - (if (default-object? default-type) - 'VISIBLE-DEFAULT - default-type))) - (read-from-string - (prompt-for-string - (prompt-for-string/prompt prompt - (and (eq? default-type 'VISIBLE-DEFAULT) - default-string)) - default-string - (if (eq? default-type 'VISIBLE-DEFAULT) - 'INVISIBLE-DEFAULT - default-type) - (let ((environment (ref-variable scheme-environment))) - (lambda (buffer) - (set-buffer-major-mode! buffer - (ref-mode-object prompt-for-expression)) - ;; This sets up the correct environment in the typein buffer - ;; so that completion of variables works right. - (local-set-variable! scheme-environment environment buffer))))))) + (eval-with-history buffer + (apply prompt-for-expression + prompt + (cond ((default-object? default) + default-object-kludge) + ((or (symbol? default) + (pair? default) + (vector? default)) + `',default) + (else default)) + options) + (evaluation-environment buffer)))) + +(define (prompt-for-expression prompt #!optional default-object . options) + (read-from-string + (apply prompt-for-string + prompt + (and (not (or (default-object? default-object) + (eq? default-object-kludge default-object))) + (write-to-string default-object)) + 'MODE + (let ((environment (ref-variable scheme-environment))) + (lambda (buffer) + (set-buffer-major-mode! buffer + (ref-mode-object prompt-for-expression)) + ;; This sets up the correct environment in the typein buffer + ;; so that completion of variables works right. + (local-set-variable! scheme-environment environment buffer))) + options))) + +(define default-object-kludge + (list 'DEFAULT-OBJECT-KLUDGE)) (define (read-from-string string) (bind-condition-handler (list condition-type:error) evaluation-error-handler @@ -317,12 +313,7 @@ Has no effect if evaluate-in-inferior-repl is false." (with-input-from-string string read)))) (define-major-mode prompt-for-expression scheme #f - "Major mode for editing solicited input expressions. -Depending on what is being solicited, either defaulting or completion -may be available. The following commands are special to this mode: - -\\[exit-minibuffer] terminates the input. -\\[minibuffer-yank-default] yanks the default string, if there is one." + (mode-description (ref-mode-object minibuffer-local)) (lambda (buffer) ;; This kludge prevents auto-fill from being turned on. Probably ;; there is a better way to do this, but I can't think of one @@ -331,8 +322,8 @@ may be available. The following commands are special to this mode: (disable-buffer-minor-mode! buffer mode)) (buffer-minor-modes buffer)))) -(define-key 'prompt-for-expression #\return 'exit-minibuffer) -(define-key 'prompt-for-expression #\c-m-y 'minibuffer-yank-default) +(set-car! (mode-comtabs (ref-mode-object prompt-for-expression)) + (car (mode-comtabs (ref-mode-object minibuffer-local)))) ;;;; Evaluation diff --git a/v7/src/edwin/filcom.scm b/v7/src/edwin/filcom.scm index 13580907e..bf23bfbdb 100644 --- a/v7/src/edwin/filcom.scm +++ b/v7/src/edwin/filcom.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: filcom.scm,v 1.198 1999/01/02 06:11:34 cph Exp $ +;;; $Id: filcom.scm,v 1.199 1999/01/28 03:59:53 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology ;;; @@ -401,7 +401,7 @@ If `trim-versions-without-asking' is false, system will query user buffer (prompt-for-pathname (string-append "Write buffer " (buffer-name buffer) " to file") - false false))) + #f))) (if (and (ref-variable enable-emacs-write-file-message) (> (buffer-length buffer) 50000)) (message "Saving file " @@ -673,40 +673,42 @@ Prefix arg means treat the plaintext file as binary data." ;;;; Prompting -(define (prompt-for-file prompt default) +(define (prompt-for-file prompt default . options) (->namestring - (prompt-for-pathname* prompt default file-non-directory? false))) + (prompt-for-pathname* prompt default file-non-directory? options))) -(define (prompt-for-existing-file prompt default) +(define (prompt-for-existing-file prompt default . options) (->namestring - (prompt-for-pathname* prompt default file-non-directory? true))) + (prompt-for-pathname* prompt default file-non-directory? + 'REQUIRE-MATCH? #t + options))) (define (file-non-directory? file) (and (file-exists? file) (not (file-directory? file)))) -(define (prompt-for-directory prompt default) +(define (prompt-for-directory prompt default . options) (->namestring (let ((file-directory? (lambda (pathname) (and (not (pathname-wild? pathname)) (file-directory? pathname))))) (let ((directory - (prompt-for-pathname* prompt default file-directory? false))) + (prompt-for-pathname* prompt default file-directory? options))) (if (file-test-no-errors file-directory? directory) (pathname-as-directory directory) directory))))) -(define (prompt-for-existing-directory prompt default) +(define (prompt-for-existing-directory prompt default . options) (->namestring (pathname-as-directory - (prompt-for-pathname* prompt default file-directory? true)))) + (prompt-for-pathname* prompt default file-directory? + (cons* 'REQUIRE-MATCH? #t options))))) -(define (prompt-for-pathname prompt default require-match?) - (prompt-for-pathname* prompt default file-exists? require-match?)) +(define (prompt-for-pathname prompt default . options) + (prompt-for-pathname* prompt default file-exists? options)) -(define (prompt-for-pathname* prompt default - verify-final-value? require-match?) +(define (prompt-for-pathname* prompt default verify-final-value options) (let* ((directory (if default (directory-pathname @@ -720,28 +722,27 @@ Prefix arg means treat the plaintext file as binary data." (car default) directory)))) (prompt-string->pathname - (prompt-for-completed-string - prompt - insertion - 'INSERTED-DEFAULT - (lambda (string if-unique if-not-unique if-not-found) - (filename-complete-string - (prompt-string->pathname string insertion directory) - (lambda (filename) - (if-unique (os/pathname->display-string filename))) - (lambda (prefix get-completions) - (if-not-unique (os/pathname->display-string prefix) - get-completions)) - if-not-found)) - (lambda (string) - (filename-completions-list - (prompt-string->pathname string insertion directory))) - (lambda (string) - (file-test-no-errors - verify-final-value? - (prompt-string->pathname string insertion directory))) - require-match? - #f) + (apply prompt-for-completed-string + prompt + insertion + (lambda (string if-unique if-not-unique if-not-found) + (filename-complete-string + (prompt-string->pathname string insertion directory) + (lambda (filename) + (if-unique (os/pathname->display-string filename))) + (lambda (prefix get-completions) + (if-not-unique (os/pathname->display-string prefix) + get-completions)) + if-not-found)) + (lambda (string) + (filename-completions-list + (prompt-string->pathname string insertion directory))) + (lambda (string) + (file-test-no-errors + verify-final-value + (prompt-string->pathname string insertion directory))) + 'DEFAULT-TYPE 'INSERTED-DEFAULT + options) insertion directory))) diff --git a/v7/src/edwin/kmacro.scm b/v7/src/edwin/kmacro.scm index 32132d03a..f2241b120 100644 --- a/v7/src/edwin/kmacro.scm +++ b/v7/src/edwin/kmacro.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: kmacro.scm,v 1.41 1999/01/02 06:11:34 cph Exp $ +;;; $Id: kmacro.scm,v 1.42 1999/01/28 03:59:55 cph Exp $ ;;; ;;; Copyright (c) 1985, 1989-1999 Massachusetts Institute of Technology ;;; @@ -168,15 +168,14 @@ With argument, also record the keys it is bound to." (let ((name (prompt-for-string-table-name "Write keyboard macro" false - 'NO-DEFAULT named-keyboard-macros - true))) + 'DEFAULT-TYPE 'NO-DEFAULT + 'REQUIRE-MATCH #t))) (let ((pathname (prompt-for-pathname (string-append "Write keyboard macro " name " to file") - false - false)) + #f)) (buffer (temporary-buffer "*Write-Keyboard-Macro-temp*"))) (call-with-output-mark (buffer-point buffer) (lambda (port) diff --git a/v7/src/edwin/make.scm b/v7/src/edwin/make.scm index ec46d964b..57da1aa4e 100644 --- a/v7/src/edwin/make.scm +++ b/v7/src/edwin/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: make.scm,v 3.95 1999/01/03 05:23:38 cph Exp $ +$Id: make.scm,v 3.96 1999/01/28 04:00:18 cph Exp $ Copyright (c) 1989-1999 Massachusetts Institute of Technology @@ -45,4 +45,4 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ((UNIX) "edwinunx") (else "edwinunk")))))) 'QUERY))))) -(add-identification! "Edwin" 3 95) \ No newline at end of file +(add-identification! "Edwin" 3 96) \ No newline at end of file diff --git a/v7/src/edwin/print.scm b/v7/src/edwin/print.scm index d43cb1611..ccb9528de 100644 --- a/v7/src/edwin/print.scm +++ b/v7/src/edwin/print.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: print.scm,v 1.17 1999/01/02 06:11:34 cph Exp $ +;;; $Id: print.scm,v 1.18 1999/01/28 03:59:55 cph Exp $ ;;; ;;; Copyright (c) 1991-1999 Massachusetts Institute of Technology ;;; @@ -147,7 +147,7 @@ Variable LPR-SWITCHES is a list of extra switches (strings) to pass to lpr." (let ((job-name (prompt-for-string "Name to print on title page" most-recent-name - 'INSERTED-DEFAULT))) + 'DEFAULT-TYPE 'INSERTED-DEFAULT))) (if (string-null? job-name) false (begin diff --git a/v7/src/edwin/prompt.scm b/v7/src/edwin/prompt.scm index e6c0f9d82..7c1b81a14 100644 --- a/v7/src/edwin/prompt.scm +++ b/v7/src/edwin/prompt.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: prompt.scm,v 1.174 1999/01/02 06:11:34 cph Exp $ +;;; $Id: prompt.scm,v 1.175 1999/01/28 03:59:56 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology ;;; @@ -32,7 +32,7 @@ (define map-name/external->internal) (define (initialize-typein!) - (set! typein-edit-continuation false) + (set! typein-edit-continuation #f) (set! typein-edit-depth -1) (set! typein-saved-buffers '()) (set! typein-saved-windows '()) @@ -103,12 +103,12 @@ (define-variable enable-recursive-minibuffers "True means allow minibuffers to invoke commands that use recursive minibuffers." - false + #f boolean?) (define-variable completion-auto-help "True means automatically provide help for invalid completion input." - true + #t boolean?) (define (prompt-for-typein prompt-string check-recursion? thunk) @@ -168,68 +168,60 @@ (define (update-typein!) (if (not *executing-keyboard-macro?*) - (window-direct-update! (typein-window) false))) + (window-direct-update! (typein-window) #f))) ;;;; String Prompt -(define *default-string*) -(define *default-type*) -(define completion-procedure/complete-string) -(define completion-procedure/list-completions) -(define completion-procedure/verify-final-value?) -(define *completion-confirm?*) -(define *completion-case-insensitive?*) - -(define (prompt-for-string prompt default-string #!optional default-type mode) - (fluid-let ((*default-string* default-string) - (*default-type* - (if (default-object? default-type) - 'VISIBLE-DEFAULT - default-type)) - (completion-procedure/complete-string #f) - (completion-procedure/list-completions #f) - (completion-procedure/verify-final-value? #f)) - (%prompt-for-string prompt - (if (default-object? mode) - (ref-mode-object minibuffer-local) - mode)))) +(define (prompt-for-string prompt default-string . options) + (%prompt-for-string + prompt + (parse-prompt-options + (basic-prompt-options (ref-mode-object minibuffer-local) + default-string) + options))) (define (prompt-for-completed-string prompt default-string - default-type complete-string list-completions - verify-final-value? - require-match? - case-insensitive?) - (fluid-let ((*default-string* default-string) - (*default-type* default-type) - (completion-procedure/complete-string complete-string) - (completion-procedure/list-completions list-completions) - (completion-procedure/verify-final-value? verify-final-value?) - (*completion-confirm?* (not (eq? require-match? true))) - (*completion-case-insensitive?* case-insensitive?)) - (%prompt-for-string - prompt - (if require-match? - (ref-mode-object minibuffer-local-must-match) - (ref-mode-object minibuffer-local-completion))))) - -(define (%prompt-for-string prompt mode) - (prompt-for-typein - (prompt-for-string/prompt prompt - (and (eq? *default-type* 'VISIBLE-DEFAULT) - *default-string* - (write-to-string *default-string*))) - true - (let ((thunk (typein-editor-thunk mode))) - (if (and (eq? *default-type* 'INSERTED-DEFAULT) *default-string*) - (let ((string *default-string*)) - (set! *default-string* false) - (lambda () - (insert-string string) - ((thunk)))) - thunk)))) + verify-final-value + . options) + (%prompt-for-string + prompt + (parse-prompt-options + (completion-prompt-options (ref-mode-object minibuffer-local-completion) + default-string + complete-string + list-completions + verify-final-value) + options))) + +(define *options*) + +(define (%prompt-for-string prompt options) + (fluid-let ((*options* options)) + (let ((type (default-type)) + (string (default-string))) + (prompt-for-typein + (prompt-for-string/prompt prompt + (and (eq? 'VISIBLE-DEFAULT type) + string + (write-to-string string))) + #t + (let ((thunk (typein-editor-thunk (options/mode *options*)))) + (if (and (eq? type 'INSERTED-DEFAULT) string) + (begin + (set-options/default-string! options #f) + (lambda () + (insert-string string) + ((thunk)))) + thunk)))))) + +(define (default-type) (options/default-type *options*)) +(define (default-string) (options/default-string *options*)) + +(define (case-insensitive-completion?) + (options/case-insensitive-completion? *options*)) (define (prompt-for-string/prompt prompt default-string) (cond ((string? prompt) @@ -250,49 +242,39 @@ "prompt string" 'PROMPT-FOR-STRING/PROMPT)))) -(define (prompt-for-number prompt default) +(define (prompt-for-number prompt default . options) (let ((string - (let ((default (and default (number->string default)))) - (prompt-for-string - (prompt-for-string/prompt prompt default) - default - 'INVISIBLE-DEFAULT)))) + (apply prompt-for-string + prompt + (and default (number->string default)) + options))) (or (string->number string) (editor-error "Input not a number: " string)))) -(define (prompt-for-string-table-name prompt - default-string - default-type - string-table - require-match?) - (prompt-for-completed-string - prompt - default-string - default-type - (lambda (string if-unique if-not-unique if-not-found) - (string-table-complete string-table - string - if-unique - if-not-unique - if-not-found)) - (lambda (string) - (string-table-completions string-table string)) - (lambda (string) - (string-table-get string-table string)) - require-match? - (string-table-ci? string-table))) - -(define (prompt-for-string-table-value prompt - default-string - default-type - string-table - require-match?) +(define (prompt-for-string-table-name prompt default-string string-table + . options) + (apply prompt-for-completed-string + prompt + default-string + (lambda (string if-unique if-not-unique if-not-found) + (string-table-complete string-table + string + if-unique + if-not-unique + if-not-found)) + (lambda (string) + (string-table-completions string-table string)) + (lambda (string) + (string-table-get string-table string)) + 'CASE-INSENSITIVE-COMPLETION? (string-table-ci? string-table) + options)) + +(define (prompt-for-string-table-value prompt default-string string-table + . options) (string-table-get string-table - (prompt-for-string-table-name prompt - default-string - default-type - string-table - require-match?))) + (apply prompt-for-string-table-name + prompt default-string string-table + options))) (define (prompt-for-alist-value prompt alist #!optional default ci?) (fluid-let ((map-name/external->internal identity-procedure) @@ -300,29 +282,140 @@ (prompt-for-string-table-value prompt (and (not (default-object? default)) default) - 'VISIBLE-DEFAULT (alist->string-table alist (if (default-object? ci?) #t ci?)) - true))) + 'REQUIRE-MATCH? #t))) (define (prompt-for-command prompt) (fluid-let ((map-name/external->internal editor-name/external->internal) (map-name/internal->external editor-name/internal->external)) (prompt-for-string-table-value prompt - false - 'NO-DEFAULT + #f editor-commands - true))) + 'DEFAULT-TYPE 'NO-DEFAULT + 'REQUIRE-MATCH? #t))) (define (prompt-for-variable prompt) (fluid-let ((map-name/external->internal editor-name/external->internal) (map-name/internal->external editor-name/internal->external)) (prompt-for-string-table-value prompt - false - 'NO-DEFAULT + #f editor-variables - true))) + 'DEFAULT-TYPE 'NO-DEFAULT + 'REQUIRE-MATCH? #t))) + +;;;; Prompt Options + +(define-structure + (prompt-options (conc-name options/) + (constructor basic-prompt-options + (mode default-string)) + (constructor completion-prompt-options + (mode default-string + complete-string + list-completions + verify-final-value))) + (seen '()) + (mode #f) + (default-string #f) + (complete-string #f read-only #t) + (list-completions #f read-only #t) + (verify-final-value #f read-only #t) + (default-type 'VISIBLE-DEFAULT) + (confirm-completion? #f) + (case-insensitive-completion? #f) + (history '()) + (history-index 0)) + +(define (parse-prompt-options option-structure options) + (let loop ((options options)) + (cond ((and (pair? options) + (symbol? (car options)) + (pair? (cdr options))) + (let ((entry (assq (car options) prompt-options-table)) + (arg (cadr options))) + (if (not entry) + (error "Unknown prompt option:" (car options))) + (set-options/seen! option-structure + (cons (car options) + (options/seen option-structure))) + (if (not (let ((predicate (cadr entry))) + (if (pair? predicate) + (there-exists? predicate (lambda (p) (p arg))) + (predicate arg)))) + (error "Not a valid option argument:" arg)) + ((cddr entry) option-structure arg) + (loop (cddr options)))) + ((null? options) + option-structure) + (else + (error "Illegal options tail:" options))))) + +(define prompt-options-table + '()) + +(define (define-prompt-option keyword type modifier) + (let ((entry (assq keyword prompt-options-table)) + (body (cons type modifier))) + (if entry + (set-cdr! entry body) + (begin + (set! prompt-options-table + (cons (cons keyword body) + prompt-options-table)) + unspecific)))) + +(define (define-simple-option keyword type) + (define-prompt-option keyword type + (lambda (options value) + ((record-modifier (record-type-descriptor options) keyword) + options + value)))) + +(define-simple-option 'MODE (list major-mode? procedure?)) +(define-simple-option 'DEFAULT-STRING string-or-false?) +(define-simple-option 'CASE-INSENSITIVE-COMPLETION? boolean?) + +(define-simple-option 'DEFAULT-TYPE + (lambda (object) + (memq object + '(VISIBLE-DEFAULT + INVISIBLE-DEFAULT + INSERTED-DEFAULT + NULL-DEFAULT + NO-DEFAULT)))) + +(define-prompt-option 'REQUIRE-MATCH? + (lambda (object) + (or (boolean? object) + (eq? 'CONFIRM object))) + (lambda (options require-match?) + (set-options/mode! options + (if require-match? + (ref-mode-object minibuffer-local-must-match))) + (set-options/confirm-completion?! options (eq? 'CONFIRM require-match?)))) + +(define-prompt-option 'HISTORY list? + (lambda (options history) + (set-options/history! options history) + (history->default-string options))) + +(define-prompt-option 'HISTORY-INDEX exact-nonnegative-integer? + (lambda (options index) + (set-options/history-index! options index) + (history->default-string options))) + +(define (history->default-string options) + (let ((history (options/history options)) + (index (options/history-index options))) + (if (and (pair? history) + (not (< index (length history)))) + (error "History index out of range:" index)) + (if (not (memq 'DEFAULT-STRING (options/seen options))) + (set-options/default-string! + options + (history-entry->string (list-ref history index)))))) ;;;; String Prompt Modes @@ -331,47 +424,34 @@ The following commands are special to this mode: \\[exit-minibuffer] terminates the input. -\\[minibuffer-yank-default] yanks the default string, if there is one.") +\\[minibuffer-yank-default] yanks the default string, if there is one. +\\[next-prompt-history-item] moves to the next item in the history. +\\[previous-prompt-history-item] moves to the previous item in the history.") (define-key 'minibuffer-local #\return 'exit-minibuffer) (define-key 'minibuffer-local #\linefeed 'exit-minibuffer) (define-key 'minibuffer-local #\c-m-y 'minibuffer-yank-default) +(define-key 'minibuffer-local #\M-n 'next-prompt-history-item) +(define-key 'minibuffer-local #\M-p 'previous-prompt-history-item) -(define-major-mode minibuffer-local-completion fundamental #f - "Major mode for editing solicited input strings. -The following commands are special to this mode: - -\\[exit-minibuffer] terminates the input. -\\[minibuffer-yank-default] yanks the default string, if there is one. +(define-major-mode minibuffer-local-completion minibuffer-local #f + (string-append (mode-description (ref-mode-object minibuffer-local)) + " \\[minibuffer-complete] completes as much of the input as possible. -\\[minibuffer-complete-word] completes up to the next space. -\\[minibuffer-completion-help] displays possible completions of the input.") +\\[minibuffer-complete-word] completes the next word of the input. +\\[minibuffer-completion-help] displays possible completions of the input.")) -(define-key 'minibuffer-local-completion #\return 'exit-minibuffer) -(define-key 'minibuffer-local-completion #\linefeed 'exit-minibuffer) -(define-key 'minibuffer-local-completion #\c-m-y 'minibuffer-yank-default) (define-key 'minibuffer-local-completion #\tab 'minibuffer-complete) (define-key 'minibuffer-local-completion #\space 'minibuffer-complete-word) (define-key 'minibuffer-local-completion #\? 'minibuffer-completion-help) -(define-major-mode minibuffer-local-must-match fundamental #f - "Major mode for editing solicited input strings. -The following commands are special to this mode: - -\\[minibuffer-complete-and-exit] terminates the input. -\\[minibuffer-yank-default] yanks the default string, if there is one. -\\[minibuffer-complete] completes as much of the input as possible. -\\[minibuffer-complete-word] completes up to the next space. -\\[minibuffer-completion-help] displays possible completions of the input.") +(define-major-mode minibuffer-local-must-match minibuffer-local-completion #f + (mode-description (ref-mode-object minibuffer-local-completion))) (define-key 'minibuffer-local-must-match #\return 'minibuffer-complete-and-exit) (define-key 'minibuffer-local-must-match #\linefeed 'minibuffer-complete-and-exit) -(define-key 'minibuffer-local-must-match #\c-m-y 'minibuffer-yank-default) -(define-key 'minibuffer-local-must-match #\tab 'minibuffer-complete) -(define-key 'minibuffer-local-must-match #\space 'minibuffer-complete-word) -(define-key 'minibuffer-local-must-match #\? 'minibuffer-completion-help) (define-command exit-minibuffer "Terminate this minibuffer argument." @@ -382,32 +462,32 @@ The following commands are special to this mode: (lambda (k) ;; Run the final value verification, just to catch any ;; errors that it might generate. - (verify-final-value? (typein-string) k) + (verify-final-value (typein-string) k) (exit-typein-edit)))) - ((memq *default-type* '(NULL-DEFAULT INSERTED-DEFAULT)) + ((memq (default-type) '(NULL-DEFAULT INSERTED-DEFAULT)) (exit-typein-edit)) - ((or (not *default-string*) - (eq? *default-type* 'NO-DEFAULT)) + ((or (not (default-string)) + (eq? (default-type) 'NO-DEFAULT)) (editor-failure)) (else - (if (and (memq *default-type* '(INVISIBLE-DEFAULT VISIBLE-DEFAULT)) - *default-string*) - (set-typein-string! *default-string* false)) + (if (and (memq (default-type) '(INVISIBLE-DEFAULT VISIBLE-DEFAULT)) + (default-string)) + (set-typein-string! (default-string) #f)) (exit-typein-edit))))) (define-command minibuffer-yank-default "Insert the default string at point." () (lambda () - (if *default-string* - (insert-string *default-string*) + (if (default-string) + (insert-string (default-string)) (editor-failure)))) (define-command minibuffer-complete "Complete the minibuffer contents as far as possible." () (lambda () - (case (complete-input-string completion-procedure/complete-string true) + (case (complete-input-string (options/complete-string *options*) #t) ((WAS-ALREADY-EXACT-AND-UNIQUE-COMPLETION) (temporary-typein-message " [Sole completion]")) ((WAS-ALREADY-EXACT-COMPLETION) @@ -417,7 +497,7 @@ The following commands are special to this mode: "Complete the minibuffer contents at most a single word." () (lambda () - (case (complete-input-string completion-procedure/complete-word true) + (case (complete-input-string completion-procedure/complete-word #t) ((WAS-ALREADY-EXACT-AND-UNIQUE-COMPLETION) (temporary-typein-message " [Sole completion]")) ((WAS-ALREADY-EXACT-COMPLETION) @@ -429,7 +509,7 @@ The following commands are special to this mode: (lambda () (minibuffer-completion-help (lambda () - (completion-procedure/list-completions (typein-string)))))) + ((options/list-completions *options*) (typein-string)))))) (define (minibuffer-completion-help list-completions) (pop-up-generated-completions @@ -445,38 +525,39 @@ a repetition of this command will exit." (lambda () (let ((string (typein-string))) (if (and (string-null? string) - (memq *default-type* '(INVISIBLE-DEFAULT VISIBLE-DEFAULT)) - *default-string*) - (set-typein-string! *default-string* false))) + (memq (default-type) '(INVISIBLE-DEFAULT VISIBLE-DEFAULT)) + (default-string)) + (set-typein-string! (default-string) #f))) (call-with-current-continuation (lambda (k) - (if (verify-final-value? (typein-string) k) + (if (verify-final-value (typein-string) k) (exit-typein-edit) - (case (complete-input-string completion-procedure/complete-string + (case (complete-input-string (options/complete-string *options*) #f) ((WAS-ALREADY-EXACT-AND-UNIQUE-COMPLETION WAS-ALREADY-EXACT-COMPLETION) (exit-typein-edit)) ((COMPLETED-TO-EXACT-AND-UNIQUE-COMPLETION COMPLETED-TO-EXACT-COMPLETION) - (if *completion-confirm?* + (if (options/confirm-completion? *options*) (temporary-typein-message " [Confirm]") (exit-typein-edit))) (else (update-typein!) (editor-failure)))))))) -(define (verify-final-value? string error-continuation) - (if completion-procedure/verify-final-value? - (bind-condition-handler (list condition-type:error) - (lambda (condition) - condition - (editor-beep) - (temporary-typein-message " [Error]") - (error-continuation unspecific)) - (lambda () - (completion-procedure/verify-final-value? string))) - #t)) +(define (verify-final-value string error-continuation) + (let ((verifier (options/verify-final-value *options*))) + (if verifier + (bind-condition-handler (list condition-type:error) + (lambda (condition) + condition + (editor-beep) + (temporary-typein-message " [Error]") + (error-continuation unspecific)) + (lambda () + (verifier string))) + #t))) ;;;; Completion Primitives @@ -499,24 +580,24 @@ a repetition of this command will exit." (set! effected? #t) (if (not (string=? string original)) (set-typein-string! string update?)) - (if (if *completion-case-insensitive?* + (if (if (case-insensitive-completion?) (string-ci=? string original) (string=? string original)) 'WAS-ALREADY-EXACT-AND-UNIQUE-COMPLETION 'COMPLETED-TO-EXACT-AND-UNIQUE-COMPLETION)) (lambda (string list-completions) (let ((verified? - (completion-procedure/verify-final-value? string))) + ((options/verify-final-value *options*) string))) (set! effected? #t) (if (not (string=? string original)) (set-typein-string! string update?)) (if verified? - (if (if *completion-case-insensitive?* + (if (if (case-insensitive-completion?) (string-ci=? string original) (string=? string original)) 'WAS-ALREADY-EXACT-COMPLETION 'COMPLETED-TO-EXACT-COMPLETION) - (if (if *completion-case-insensitive?* + (if (if (case-insensitive-completion?) (string-ci=? string original) (string=? string original)) (begin @@ -540,7 +621,7 @@ a repetition of this command will exit." (lambda (new-string) (let ((end (string-length new-string))) (let ((index - (and (if *completion-case-insensitive?* + (and (if (case-insensitive-completion?) (string-prefix-ci? string new-string) (string-prefix? string new-string)) (substring-find-next-char-not-of-syntax @@ -555,7 +636,7 @@ a repetition of this command will exit." (if-not-unique (lambda (new-string list-completions) (if-not-unique (truncate-string new-string) list-completions)))) - (completion-procedure/complete-string string + ((options/complete-string *options*) string if-unique (lambda (new-string list-completions) (if (= (string-length new-string) (string-length string)) @@ -565,7 +646,7 @@ a repetition of this command will exit." (let ((completions (list-transform-positive completions (let ((prefix (string-append string suffix))) - (if *completion-case-insensitive?* + (if (case-insensitive-completion?) (lambda (completion) (string-prefix-ci? prefix completion)) @@ -578,7 +659,7 @@ a repetition of this command will exit." (if-unique (car completions))) (else (if-not-unique - ((if *completion-case-insensitive?* + ((if (case-insensitive-completion?) string-greatest-common-prefix-ci string-greatest-common-prefix) completions) @@ -679,11 +760,11 @@ a repetition of this command will exit." (define (prompt-for-char prompt) (let ((input - (prompt-for-typein (string-append prompt ": ") false + (prompt-for-typein (string-append prompt ": ") #f (lambda () (let ((input (with-editor-interrupts-disabled keyboard-read))) (if (and (char? input) (char-ascii? input)) - (set-typein-string! (key-name input) true)) + (set-typein-string! (key-name input) #t)) (if (input-event? input) (abort-typein-edit input) input)))))) @@ -693,7 +774,7 @@ a repetition of this command will exit." (define (prompt-for-key prompt #!optional comtab) (let ((comtab (if (default-object? comtab) (current-comtabs) comtab))) - (prompt-for-typein (string-append prompt ": ") false + (prompt-for-typein (string-append prompt ": ") #f (lambda () (let outer-loop ((prefix '())) (let inner-loop @@ -701,13 +782,13 @@ a repetition of this command will exit." (if (input-event? char) (abort-typein-edit char)) (let ((chars (append! prefix (list char)))) - (set-typein-string! (xkey->name chars) true) + (set-typein-string! (xkey->name chars) #t) (if (prefix-key-list? comtab chars) (outer-loop chars) (let ((command (comtab-entry comtab chars))) (if (memq command extension-commands) (inner-loop - (fluid-let ((execute-extended-keys? false)) + (fluid-let ((execute-extended-keys? #f)) (dispatch-on-command command))) chars)))))))))) @@ -717,20 +798,20 @@ a repetition of this command will exit." (prompt-for-typein (if (string-suffix? " " prompt) prompt (string-append prompt " (y or n)? ")) - false + #f (lambda () - (let loop ((lost? false)) + (let loop ((lost? #f)) (let ((char (keyboard-read))) (cond ((and (char? char) (or (char-ci=? char #\y) (char-ci=? char #\space))) - (set-typein-string! "y" true) - true) + (set-typein-string! "y" #t) + #t) ((and (char? char) (or (char-ci=? char #\n) (char-ci=? char #\rubout))) - (set-typein-string! "n" true) - false) + (set-typein-string! "n" #t) + #f) ((input-event? char) (abort-typein-edit char)) (else @@ -738,12 +819,12 @@ a repetition of this command will exit." (if (not lost?) (insert-string "Please answer y or n. " (buffer-absolute-start (current-buffer)))) - (loop true)))))))) + (loop #t)))))))) (define (prompt-for-yes-or-no? prompt) (string-ci=? "Yes" - (prompt-for-typein (string-append prompt " (yes or no)? ") true + (prompt-for-typein (string-append prompt " (yes or no)? ") #t (typein-editor-thunk (ref-mode-object minibuffer-local-yes-or-no))))) (define-major-mode minibuffer-local-yes-or-no fundamental #f @@ -764,9 +845,43 @@ a repetition of this command will exit." (message "Please answer yes or no.") (sit-for 2000) (clear-message) - (set-typein-string! "" false)))))) + (set-typein-string! "" #f)))))) -;;;; Command History Prompt +;;;; Prompt History + +(define-command next-prompt-history-item + "Inserts the next item of the prompt history into the minibuffer. +The next item is the one more recent than the current item. +Has no effect if there is no history associated with this prompt. +With argument, skips forward that many items in the history." + "p" + (lambda (argument) + (let ((history (options/history *options*)) + (index (options/history-index *options*))) + (if (and (pair? history) (not (zero? argument))) + (let ((index* + (let ((index* (- index argument))) + (cond ((< index* 0) 0) + ((>= index* (length history)) (- (length history) 1)) + (else index*))))) + (set-options/history-index! *options* index*) + (set-typein-string! + (history-entry->string (list-ref history index*)) + #t) + (set-current-point! (buffer-start (current-buffer)))))))) + +(define-command previous-prompt-history-item + "Inserts the previous item of the prompt history into the minibuffer. +The previous item is the one less recent than the current item. +Has no effect if there is no history associated with this prompt. +With argument, skips backward that many items in the history." + "p" + (lambda (argument) + ((ref-command next-prompt-history-item) (- argument)))) + +(define (history-entry->string command) + (fluid-let ((*unparse-with-maximum-readability?* #t)) + (write-to-string command))) (define-command repeat-complex-command "Edit and re-evaluate last complex command, or ARGth from last. @@ -779,55 +894,12 @@ Whilst editing the command, the following commands are available: \\{repeat-complex-command}" "p" (lambda (argument) - (fluid-let ((*command-history* (command-history-list)) - (*command-history-index* argument)) - (if (or (<= argument 0) - (> argument (length *command-history*))) - (editor-error "argument out of range: " argument)) - (execute-command-history-entry - (read-from-string - (prompt-for-string "Redo" - (command-history-entry->string - (list-ref *command-history* (-1+ argument))) - 'INSERTED-DEFAULT - (ref-mode-object repeat-complex-command))))))) - -(define *command-history*) -(define *command-history-index*) - -(define (command-history-entry->string command) - (fluid-let ((*unparse-with-maximum-readability?* true)) - (write-to-string command))) - -(define-major-mode repeat-complex-command minibuffer-local #f - "Major mode for editing command history.") - -(define-key 'repeat-complex-command #\M-n 'next-complex-command) -(define-key 'repeat-complex-command #\M-p 'previous-complex-command) - -(define-command next-complex-command - "Inserts the next element of `command-history' into the minibuffer." - "p" - (lambda (argument) - (let ((index - (min (max 1 (- *command-history-index* argument)) - (length *command-history*)))) - (if (and (not (zero? argument)) - (= index *command-history-index*)) - (editor-error (if (= index 1) - "No following item in command history" - "No preceeding item in command history"))) - (set! *command-history-index* index) - (set-typein-string! - (command-history-entry->string (list-ref *command-history* (-1+ index))) - true) - (set-current-point! (buffer-start (current-buffer)))))) - -(define-command previous-complex-command - "Inserts the next element of `command-history' into the minibuffer." - "p" - (lambda (argument) - ((ref-command next-complex-command) (- argument)))) + (execute-command-history-entry + (read-from-string + (prompt-for-string "Redo" #f + 'DEFAULT-TYPE 'INSERTED-DEFAULT + 'HISTORY (command-history-list) + 'HISTORY-INDEX (- argument 1)))))) ;;; Password Prompts @@ -853,12 +925,12 @@ Whilst editing the command, the following commands are available: (if (> ts-len 0) (let ((new-string (string-head ts (-1+ ts-len)))) (set-typein-string! - (make-string (string-length new-string) #\.) true) + (make-string (string-length new-string) #\.) #t) (loop new-string)) (loop ts)))) (else - (set-typein-string! - (make-string (1+ (string-length ts)) #\.) true) + (set-typein-string! (make-string (1+ (string-length ts)) #\.) + #t) (loop (string-append ts (char->string input)))))))))) (define (prompt-for-confirmed-password) diff --git a/v7/src/edwin/replaz.scm b/v7/src/edwin/replaz.scm index 7691eedf4..098f7851a 100644 --- a/v7/src/edwin/replaz.scm +++ b/v7/src/edwin/replaz.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: replaz.scm,v 1.79 1999/01/02 06:11:34 cph Exp $ +;;; $Id: replaz.scm,v 1.80 1999/01/28 03:59:58 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology ;;; @@ -28,11 +28,11 @@ boolean?) (define (replace-string-arguments name) - (let ((source (prompt-for-string name false))) + (let ((source (prompt-for-string name #f))) (list source (prompt-for-string (string-append name " " source " with") - false - 'NULL-DEFAULT) + #f + 'DEFAULT-TYPE 'NULL-DEFAULT) (command-argument)))) (define-command replace-string diff --git a/v7/src/edwin/rmail.scm b/v7/src/edwin/rmail.scm index 9f18f3d3f..538d5289c 100644 --- a/v7/src/edwin/rmail.scm +++ b/v7/src/edwin/rmail.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: rmail.scm,v 1.59 1999/01/02 06:11:34 cph Exp $ +;;; $Id: rmail.scm,v 1.60 1999/01/28 03:59:59 cph Exp $ ;;; ;;; Copyright (c) 1991-1999 Massachusetts Institute of Technology ;;; @@ -295,7 +295,7 @@ then performs rmail editing on that file, but does not copy any new mail into the file." (lambda () (list (and (command-argument) - (prompt-for-existing-file "Run rmail on RMAIL file" false)))) + (prompt-for-existing-file "Run rmail on RMAIL file" #f)))) (lambda (filename) (rmail-find-file (or filename (ref-variable rmail-file-name))) (let ((mode (current-major-mode))) @@ -1586,8 +1586,7 @@ buffer visiting that file." (let ((pathname (prompt-for-pathname (string-append prompt " (default " (file-namestring default) ")") - (directory-pathname default) - #f))) + (directory-pathname default)))) (if (file-directory? pathname) (merge-pathnames (file-pathname default) (pathname-as-directory pathname)) @@ -1930,12 +1929,11 @@ Completion is performed over known labels when reading." (prompt-for-string-table-name prompt rmail-last-label - 'VISIBLE-DEFAULT (alist->string-table (map list (append! (map symbol->string attributes) (buffer-keywords (current-buffer))))) - require-match?))) + 'REQUIRE-MATCH? require-match?))) (set! rmail-last-label label) label)) diff --git a/v7/src/edwin/snr.scm b/v7/src/edwin/snr.scm index 4eb9ba280..675b6497c 100644 --- a/v7/src/edwin/snr.scm +++ b/v7/src/edwin/snr.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: snr.scm,v 1.50 1999/01/02 06:11:34 cph Exp $ +;;; $Id: snr.scm,v 1.51 1999/01/28 04:00:03 cph Exp $ ;;; ;;; Copyright (c) 1995-1999 Massachusetts Institute of Technology ;;; @@ -870,7 +870,7 @@ Prompts for the News-group name, with completion." (string->group (let ((convert (lambda (vector) (map news-group:name (vector->list vector))))) - (prompt-for-completed-string prompt default 'VISIBLE-DEFAULT + (prompt-for-completed-string prompt default (lambda (string if-unique if-not-unique if-not-found) (ordered-vector-minimum-match (group-names) string (lambda (s) s) string-order (prefix-matcher string) @@ -884,7 +884,7 @@ Prompts for the News-group name, with completion." (ordered-vector-matches (group-names) string (lambda (s) s) string-order (prefix-matcher string)))) string->group - #t #f)))))) + 'REQUIRE-MATCH? #t)))))) (define-command news-unsubscribe-group "Unsubscribe from the News group indicated by point. diff --git a/v7/src/edwin/tagutl.scm b/v7/src/edwin/tagutl.scm index a4fb01ca9..f0d865063 100644 --- a/v7/src/edwin/tagutl.scm +++ b/v7/src/edwin/tagutl.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: tagutl.scm,v 1.56 1999/01/02 06:11:34 cph Exp $ +;;; $Id: tagutl.scm,v 1.57 1999/01/28 04:00:06 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology ;;; @@ -266,12 +266,12 @@ query-replace with the command \\[tags-loop-continue]. See documentation of variable tags-file-pathnames." (lambda () - (let ((source (prompt-for-string "Tags query replace (regexp)" false))) + (let ((source (prompt-for-string "Tags query replace (regexp)" #f))) (list source (prompt-for-string (string-append "Tags query replace " source " with") - false - 'NULL-DEFAULT) + #f + 'DEFAULT-TYPE 'NULL-DEFAULT) (command-argument)))) (lambda (source target delimited) (set! tags-loop-continuation -- 2.25.1