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 9d2e681e2e1a6d6b2c2086c9f31c4c8757566017..a3f356299b869fb51c30d39fc8372e31f5a671be 100644 (file)
--- 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)))
 \f

diff --git a/v7/src/edwin/prompt.scm b/v7/src/edwin/prompt.scm
index 8e83f4acb6d65a440c0870a5585a6c3c576b8cee..7dc7deb825cafebde77623d6c099874d2d20df6e 100644 (file)
--- 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 6934659dc70b452014a332f5fe5ca510d4fedc1f..8a240eb701f94e250b477aa6e26637d02f423623 100644 (file)
--- 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 529386491e957284a239b341052c89749418ca12..87c4d114550a3245fa6e818cb6469300a485183b 100644 (file)
--- 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)))
-
+\f
 (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))