From: Chris Hanson Date: Wed, 18 Nov 1998 03:18:08 +0000 (+0000) Subject: Add additional argument to PROMPT-FOR-COMPLETED-STRING that controls X-Git-Tag: 20090517-FFI~4717 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0a3d9a99836afb04b652152cda1e7e97e8db4218;p=mit-scheme.git Add additional argument to PROMPT-FOR-COMPLETED-STRING that controls whether the completion is case-insensitive; change callers to pass this extra argument. Redefine STRING-GREATEST-COMMON-PREFIX to be case-sensitive, define STRING-GREATEST-COMMON-PREFIX-CI, and change callers to use the appropriate version. --- diff --git a/v7/src/edwin/filcom.scm b/v7/src/edwin/filcom.scm index 9d2e681e2..a3f356299 100644 --- a/v7/src/edwin/filcom.scm +++ b/v7/src/edwin/filcom.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: filcom.scm,v 1.194 1998/11/18 02:55:25 cph Exp $ +;;; $Id: filcom.scm,v 1.195 1998/11/18 03:17:52 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-98 Massachusetts Institute of Technology ;;; @@ -743,7 +743,8 @@ Prefix arg means treat the plaintext file as binary data." (file-test-no-errors verify-final-value? (prompt-string->pathname string insertion directory))) - require-match?) + require-match? + #f) insertion directory))) diff --git a/v7/src/edwin/prompt.scm b/v7/src/edwin/prompt.scm index 8e83f4acb..7dc7deb82 100644 --- a/v7/src/edwin/prompt.scm +++ b/v7/src/edwin/prompt.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: prompt.scm,v 1.171 1998/08/30 01:50:29 cph Exp $ +;;; $Id: prompt.scm,v 1.172 1998/11/18 03:17:41 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-98 Massachusetts Institute of Technology ;;; @@ -202,6 +202,7 @@ (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) @@ -223,13 +224,15 @@ complete-string list-completions verify-final-value? - require-match?) + 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-confirm?* (not (eq? require-match? true))) + (*completion-case-insensitive?* case-insensitive?)) (%prompt-for-string prompt (if require-match? @@ -300,7 +303,8 @@ (string-table-completions string-table string)) (lambda (string) (string-table-get string-table string)) - require-match?)) + require-match? + (string-table-ci? string-table))) (define (prompt-for-string-table-value prompt default-string @@ -519,7 +523,9 @@ a repetition of this command will exit." (set! effected? #t) (if (not (string=? string original)) (set-typein-string! string update?)) - (if (string-ci=? string original) + (if (if *completion-case-insensitive?* + (string-ci=? string original) + (string=? string original)) 'WAS-ALREADY-EXACT-AND-UNIQUE-COMPLETION 'COMPLETED-TO-EXACT-AND-UNIQUE-COMPLETION)) (lambda (string list-completions) @@ -529,10 +535,14 @@ a repetition of this command will exit." (if (not (string=? string original)) (set-typein-string! string update?)) (if verified? - (if (string-ci=? string original) + (if (if *completion-case-insensitive?* + (string-ci=? string original) + (string=? string original)) 'WAS-ALREADY-EXACT-COMPLETION 'COMPLETED-TO-EXACT-COMPLETION) - (if (string-ci=? string original) + (if (if *completion-case-insensitive?* + (string-ci=? string original) + (string=? string original)) (begin (if (ref-variable completion-auto-help) (minibuffer-completion-help list-completions) @@ -554,7 +564,9 @@ a repetition of this command will exit." (lambda (new-string) (let ((end (string-length new-string))) (let ((index - (and (string-prefix-ci? string new-string) + (and (if *completion-case-insensitive?* + (string-prefix-ci? string new-string) + (string-prefix? string new-string)) (substring-find-next-char-not-of-syntax new-string (string-length string) end (ref-variable syntax-table) #\w)))) @@ -577,16 +589,23 @@ a repetition of this command will exit." (let ((completions (list-transform-positive completions (let ((prefix (string-append string suffix))) - (lambda (completion) - (string-prefix-ci? prefix - completion)))))) + (if *completion-case-insensitive?* + (lambda (completion) + (string-prefix-ci? prefix + completion)) + (lambda (completion) + (string-prefix? prefix + completion))))))) (cond ((null? completions) (if-not-found)) ((null? (cdr completions)) (if-unique (car completions))) (else (if-not-unique - (string-greatest-common-prefix completions) + ((if *completion-case-insensitive?* + string-greatest-common-prefix-ci + string-greatest-common-prefix) + completions) (lambda () completions)))))))) (try-suffix "-" (lambda () diff --git a/v7/src/edwin/snr.scm b/v7/src/edwin/snr.scm index 6934659dc..8a240eb70 100644 --- a/v7/src/edwin/snr.scm +++ b/v7/src/edwin/snr.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: snr.scm,v 1.43 1998/09/08 04:12:59 cph Exp $ +;;; $Id: snr.scm,v 1.44 1998/11/18 03:18:00 cph Exp $ ;;; ;;; Copyright (c) 1995-98 Massachusetts Institute of Technology ;;; @@ -877,7 +877,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)))))) + #t #f)))))) (define-command news-unsubscribe-group "Unsubscribe from the News group indicated by point. diff --git a/v7/src/edwin/utils.scm b/v7/src/edwin/utils.scm index 529386491..87c4d1145 100644 --- a/v7/src/edwin/utils.scm +++ b/v7/src/edwin/utils.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: utils.scm,v 1.43 1998/01/03 05:03:11 cph Exp $ +;;; $Id: utils.scm,v 1.44 1998/11/18 03:18:08 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-98 Massachusetts Institute of Technology ;;; @@ -198,8 +198,21 @@ (%substring-move! string1 0 length1 result 0) (%substring-move! string2 start2 end2 result length1) result))) - + (define (string-greatest-common-prefix strings) + (let loop + ((strings (cdr strings)) + (string (car strings)) + (index (string-length (car strings)))) + (if (null? strings) + (substring string 0 index) + (let ((string* (car strings))) + (let ((index* (string-match-forward string string*))) + (if (< index* index) + (loop (cdr strings) string* index*) + (loop (cdr strings) string index))))))) + +(define (string-greatest-common-prefix-ci strings) (let loop ((strings (cdr strings)) (string (car strings))