(eval-when-compile (require 'cl-lib))
+(defun minibuf-conform-representation (string basis)
+ (cond
+ ((eq (multibyte-string-p string) (multibyte-string-p basis))
+ string)
+ ((multibyte-string-p string)
+ (string-make-unibyte string))
+ (t
+ (string-make-multibyte string))))
+
+(defun try-completion (string collection &optional predicate)
+ "Return common substring of all completions of STRING in COLLECTION.
+Test each possible completion specified by COLLECTION
+to see if it begins with STRING. The possible completions may be
+strings or symbols. Symbols are converted to strings before testing,
+see `symbol-name'.
+All that match STRING are compared together; the longest initial sequence
+common to all these matches is the return value.
+If there is no match at all, the return value is nil.
+For a unique match which is exact, the return value is t.
+
+If COLLECTION is an alist, the keys (cars of elements) are the
+possible completions. If an element is not a cons cell, then the
+element itself is the possible completion.
+If COLLECTION is a hash-table, all the keys that are strings or symbols
+are the possible completions.
+If COLLECTION is an obarray, the names of all symbols in the obarray
+are the possible completions.
+
+COLLECTION can also be a function to do the completion itself.
+It receives three arguments: the values STRING, PREDICATE and nil.
+Whatever it returns becomes the value of `try-completion'.
+
+If optional third argument PREDICATE is non-nil,
+it is used to test each possible match.
+The match is a candidate only if PREDICATE returns non-nil.
+The argument given to PREDICATE is the alist element
+or the symbol from the obarray. If COLLECTION is a hash-table,
+predicate is called with two arguments: the key and the value.
+Additionally to this predicate, `completion-regexp-list'
+is used to further constrain the set of candidates."
+ (catch 'return
+ (let (bestmatch
+ eltstring
+ ;; Size in bytes of BESTMATCH.
+ (bestmatchsize 0)
+ ;; These are in bytes, too.
+ (compare 0)
+ (matchsize 0)
+ (type (cond
+ ((hash-table-p collection) 'hash-table)
+ ((vectorp collection) 'obarray)
+ ((or (null collection)
+ (and (consp collection)
+ (not (functionp collection))))
+ 'list)
+ (t 'function)))
+ (matchcount 0))
+ ;;(cl-check-type string string)
+ (when (eq type 'function)
+ (throw 'return
+ (funcall collection string predicate nil)))
+ (catch 'break
+ (funcall
+ (cond
+ ((eq type 'hash-table) #'maphash)
+ ((eq type 'list) #'mapc)
+ ((eq type 'obarray) #'mapatoms))
+ (lambda (elt &optional hash-value)
+ (catch 'continue
+ ;; Is this element a possible completion?
+ (setq eltstring (if (and (eq type 'list) (consp elt))
+ (car elt)
+ elt))
+ (when (symbolp eltstring)
+ (setq eltstring (symbol-name eltstring)))
+ (when (and (stringp eltstring)
+ (<= (length string) (length eltstring))
+ (eq t (compare-strings eltstring
+ 0
+ (length string)
+ string
+ 0
+ nil
+ completion-ignore-case)))
+ ;; Yes.
+ (let ((case-fold-search completion-ignore-case))
+ (let ((regexps completion-regexp-list))
+ (while (consp regexps)
+ (when (null (string-match (car regexps) eltstring 0))
+ (throw 'continue nil))
+ (setq regexps (cdr regexps)))))
+ ;; Ignore this element if there is a predicate and the
+ ;; predicate doesn't like it.
+ (unless (cond
+ ((null predicate) t)
+ ((eq predicate 'commandp)
+ (commandp elt nil))
+ ((eq type 'hash-table)
+ (funcall predicate elt hash-value))
+ (t (funcall predicate elt)))
+ (throw 'continue nil))
+ ;; Update computation of how much all possible completions match
+ (if (null bestmatch)
+ (setq matchcount 1
+ bestmatch eltstring
+ bestmatchsize (length eltstring))
+ (setq compare (min bestmatchsize (length eltstring))
+ matchsize
+ (let ((tem (compare-strings bestmatch
+ 0
+ compare
+ eltstring
+ 0
+ compare
+ completion-ignore-case)))
+ (if (eq tem t) compare (1- (abs tem)))))
+ (when completion-ignore-case
+ ;; If this is an exact match except for case, use it as
+ ;; the best match rather than one that is not an exact
+ ;; match. This way, we get the case pattern of the actual
+ ;; match.
+ (when (or (and (eql matchsize (length eltstring))
+ (< matchsize (length bestmatch)))
+ ;; If there is more than one exact match
+ ;; ignoring case, and one of them is exact
+ ;; including case, prefer that one. If there is
+ ;; no exact match ignoring case, prefer a match
+ ;; that does not change the case of the input.
+ (and (eql (eql matchsize (length eltstring))
+ (eql matchsize (length bestmatch)))
+ (eq t (compare-strings eltstring
+ 0
+ (length string)
+ string
+ 0
+ nil
+ nil))
+ (not (eq t (compare-strings bestmatch
+ 0
+ (length string)
+ string
+ 0
+ nil
+ nil)))))
+ (setq bestmatch eltstring)))
+ (when (or (not (eql bestmatchsize (length eltstring)))
+ (not (eql bestmatchsize matchsize)))
+ ;; Don't count the same string multiple times.
+ (if (<= matchcount 1)
+ (setq matchcount (+ matchcount 1))))
+ (setq bestmatchsize matchsize)
+ (when (and (<= matchsize (length string))
+ ;; If completion-ignore-case is non-nil, don't
+ ;; short-circuit because we want to find the
+ ;; best possible match *including* case
+ ;; differences.
+ (not completion-ignore-case)
+ (> matchcount 1))
+ ;; No need to look any further.
+ (throw 'break nil))))))
+ collection))
+ (cond
+ ;; No completions found.
+ ((null bestmatch)
+ nil)
+ ;; If we are ignoring case, and there is no exact match, and no
+ ;; additional text was supplied, don't change the case of what the
+ ;; user typed.
+ ((and completion-ignore-case
+ (eql bestmatchsize (length string))
+ (> (length bestmatch) bestmatchsize))
+ (minibuf-conform-representation string bestmatch))
+ ;; Return t if the supplied string is an exact match (counting
+ ;; case); it does not require any change to be made.
+ ((and (eql matchcount 1) (equal bestmatch string))
+ t)
+ ;; Else extract the part in which all completions agree.
+ (t (substring bestmatch 0 bestmatchsize))))))
+
+(defun all-completions (string collection &optional predicate hide-spaces)
+ "Search for partial matches to STRING in COLLECTION.
+Test each of the possible completions specified by COLLECTION
+to see if it begins with STRING. The possible completions may be
+strings or symbols. Symbols are converted to strings before testing,
+see `symbol-name'.
+The value is a list of all the possible completions that match STRING.
+
+If COLLECTION is an alist, the keys (cars of elements) are the
+possible completions. If an element is not a cons cell, then the
+element itself is the possible completion.
+If COLLECTION is a hash-table, all the keys that are strings or symbols
+are the possible completions.
+If COLLECTION is an obarray, the names of all symbols in the obarray
+are the possible completions.
+
+COLLECTION can also be a function to do the completion itself.
+It receives three arguments: the values STRING, PREDICATE and t.
+Whatever it returns becomes the value of `all-completions'.
+
+If optional third argument PREDICATE is non-nil,
+it is used to test each possible match.
+The match is a candidate only if PREDICATE returns non-nil.
+The argument given to PREDICATE is the alist element
+or the symbol from the obarray. If COLLECTION is a hash-table,
+predicate is called with two arguments: the key and the value.
+Additionally to this predicate, `completion-regexp-list'
+is used to further constrain the set of candidates.
+
+An obsolete optional fourth argument HIDE-SPACES is still accepted for
+backward compatibility. If non-nil, strings in COLLECTION that start
+with a space are ignored unless STRING itself starts with a space."
+ (catch 'return
+ (let (eltstring
+ allmatches
+ (type (cond ((hash-table-p collection) 'hash-table)
+ ((vectorp collection) 'obarray)
+ ((or (null collection)
+ (and (consp collection)
+ (not (functionp collection))))
+ 'list)
+ (t 'function))))
+ ;;(cl-check-type string string)
+ (when (eq type 'function)
+ (throw 'return
+ (funcall collection string predicate t)))
+ (catch 'break
+ (funcall
+ (cond
+ ((eq type 'hash-table) #'maphash)
+ ((eq type 'obarray) #'mapatoms)
+ ((eq type 'list) #'mapc))
+ (lambda (elt &optional hash-value)
+ (catch 'continue
+ (setq eltstring (if (and (eq type 'list) (consp elt))
+ (car elt)
+ elt))
+ ;; Is this element a possible completion?
+ (when (symbolp eltstring)
+ (setq eltstring (symbol-name eltstring)))
+ (when (and (stringp eltstring)
+ (<= (length string) (length eltstring))
+ ;; If HIDE_SPACES, reject alternatives that start
+ ;; with space unless the input starts with space.
+ (or (not hide-spaces)
+ (and (> (length string) 0)
+ (eql (aref string 0) ?\ ))
+ (eql (aref eltstring 0) ?\ ))
+ (eq t (compare-strings eltstring 0
+ (length string)
+ string 0
+ (length string)
+ completion-ignore-case)))
+ (let ((case-fold-search completion-ignore-case))
+ (let ((regexps completion-regexp-list))
+ (while (consp regexps)
+ (unless (string-match (car regexps) eltstring 0)
+ (throw 'continue nil))
+ (setq regexps (cdr regexps)))))
+ ;; Ignore this element if there is a predicate and the
+ ;; predicate doesn't like it.
+ (unless (cond
+ ((not predicate) t)
+ ((eq predicate 'commandp) (commandp elt nil))
+ ((eq type 'hash-table) (funcall predicate elt hash-value))
+ (t (funcall predicate elt)))
+ (throw 'continue nil))
+ ;; Ok => put it on the list.
+ (setq allmatches (cons eltstring allmatches)))))
+ collection))
+ (nreverse allmatches))))
+
+(set-advertised-calling-convention
+ 'all-completions '(string collection &optional predicate) "23.1")
+
+(defun test-completion (string collection &optional predicate)
+ "Return non-nil if STRING is a valid completion.
+Takes the same arguments as `all-completions' and `try-completion'.
+If COLLECTION is a function, it is called with three arguments:
+the values STRING, PREDICATE and `lambda'."
+ (catch 'return
+ (let (tem)
+ ;; check-string string
+ (cond
+ ((or (null collection)
+ (and (consp collection)
+ (not (functionp collection))))
+ (setq tem (assoc-string string collection completion-ignore-case))
+ (unless tem
+ (throw 'return nil)))
+ ((vectorp collection)
+ (setq tem (intern-soft string collection)) ; XXX nil
+ (unless tem
+ (let ((string (if (multibyte-string-p string)
+ (string-make-unibyte string)
+ (string-make-multibyte string))))
+ (setq tem (intern-soft string collection))))
+ (when (and completion-ignore-case (not tem))
+ (catch 'break
+ (mapatoms
+ #'(lambda (symbol)
+ (if (eq t (compare-strings string 0 nil
+ (symbol-name symbol) 0 nil
+ t))
+ (setq tem symbol)
+ (throw 'break nil)))
+ collection)))
+ (unless tem
+ (throw 'return nil)))
+ ((hash-table-p collection)
+ (let ((unique (cons nil nil)))
+ (let ((x (gethash string collection unique)))
+ (if (not (eq x unique))
+ (setq tem x)
+ (catch 'break
+ (maphash
+ #'(lambda (key value)
+ value ; ignore
+ (let ((key (if (symbolp key) (symbol-name key) key)))
+ (when (and (stringp key)
+ (eq t (compare-strings string 0 nil
+ key 0 nil
+ completion-ignore-case)))
+ (setq tem key)
+ (throw 'break nil))))
+ collection)))
+ (unless (stringp tem)
+ (throw 'return nil)))))
+ (t (throw 'return (funcall collection string predicate 'lambda))))
+ ;; Reject this element if it fails to match all the regexps.
+ (when (consp completion-regexp-list)
+ (let ((case-fold-search completion-ignore-case))
+ (let ((regexps completion-regexp-list))
+ (while (consp regexps)
+ (unless (string-match (car regexps)
+ (if (symbolp tem) string tem)
+ nil)
+ (throw 'return nil))
+ (setq regexps (cdr regexps))))))
+ ;; Finally, check the predicate.
+ (if predicate
+ (if (hash-table-p collection)
+ (funcall predicate tem (gethash tem collection))
+ (funcall predicate tem))
+ t))))
+
+(defun internal-complete-buffer (string predicate flag)
+ "Perform completion on buffer names.
+STRING and PREDICATE have the same meanings as in `try-completion',
+`all-completions', and `test-completion'.
+
+If FLAG is nil, invoke `try-completion'; if it is t, invoke
+`all-completions'; otherwise invoke `test-completion'."
+ (let ((buffer-alist (mapcar #'(lambda (buf)
+ (cons (buffer-name buf) buf))
+ (buffer-list))))
+ (cond
+ ((not flag)
+ (try-completion string buffer-alist predicate))
+ ((eq flag t)
+ (let ((res (all-completions string buffer-alist predicate nil)))
+ (if (> (length string) 0)
+ res
+ ;; Strip out internal buffers.
+ (let ((bufs res))
+ ;; First, look for a non-internal buffer in `res'.
+ (while (and (consp bufs)
+ (eql (aref (car bufs) 0) ?\ ))
+ (setq bufs (cdr bufs)))
+ (if (null bufs)
+ (if (eql (length res) (length buffer-alist))
+ ;; If all bufs are internal don't strip them out.
+ res
+ bufs)
+ (setq res bufs)
+ (while (consp (cdr bufs))
+ (if (eql (aref (cadr bufs) 0) ?\ )
+ (rplacd bufs (cddr bufs))
+ (setq bufs (cdr bufs))))
+ res)))))
+ ((eq flag 'lambda)
+ (test-completion string buffer-alist predicate))
+ ((eq flag 'metadata)
+ (list 'metadata (cons 'category 'buffer)))
+ (t nil))))
+
;;; Completion table manipulation
;; New completion-table operation.
return result;
}
\f
-static Lisp_Object
-minibuf_conform_representation (Lisp_Object string, Lisp_Object basis)
-{
- if (STRING_MULTIBYTE (string) == STRING_MULTIBYTE (basis))
- return string;
-
- if (STRING_MULTIBYTE (string))
- return Fstring_make_unibyte (string);
- else
- return Fstring_make_multibyte (string);
-}
-
-DEFUN ("try-completion", Ftry_completion, Stry_completion, 2, 3, 0,
- doc: /* Return common substring of all completions of STRING in COLLECTION.
-Test each possible completion specified by COLLECTION
-to see if it begins with STRING. The possible completions may be
-strings or symbols. Symbols are converted to strings before testing,
-see `symbol-name'.
-All that match STRING are compared together; the longest initial sequence
-common to all these matches is the return value.
-If there is no match at all, the return value is nil.
-For a unique match which is exact, the return value is t.
-
-If COLLECTION is an alist, the keys (cars of elements) are the
-possible completions. If an element is not a cons cell, then the
-element itself is the possible completion.
-If COLLECTION is a hash-table, all the keys that are strings or symbols
-are the possible completions.
-If COLLECTION is an obarray, the names of all symbols in the obarray
-are the possible completions.
-
-COLLECTION can also be a function to do the completion itself.
-It receives three arguments: the values STRING, PREDICATE and nil.
-Whatever it returns becomes the value of `try-completion'.
-
-If optional third argument PREDICATE is non-nil,
-it is used to test each possible match.
-The match is a candidate only if PREDICATE returns non-nil.
-The argument given to PREDICATE is the alist element
-or the symbol from the obarray. If COLLECTION is a hash-table,
-predicate is called with two arguments: the key and the value.
-Additionally to this predicate, `completion-regexp-list'
-is used to further constrain the set of candidates. */)
- (Lisp_Object string, Lisp_Object collection, Lisp_Object predicate)
-{
- Lisp_Object bestmatch, tail, elt, eltstring;
- /* Size in bytes of BESTMATCH. */
- ptrdiff_t bestmatchsize = 0;
- /* These are in bytes, too. */
- ptrdiff_t compare, matchsize;
- enum { function_table, list_table, obarray_table, hash_table}
- type = (HASH_TABLE_P (collection) ? hash_table
- : VECTORP (collection) ? obarray_table
- : ((NILP (collection)
- || (CONSP (collection) && !FUNCTIONP (collection)))
- ? list_table : function_table));
- ptrdiff_t idx = 0, obsize = 0;
- int matchcount = 0;
- Lisp_Object bucket, zero, end, tem;
- struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
-
- CHECK_STRING (string);
- if (type == function_table)
- return call3 (collection, string, predicate, Qnil);
-
- bestmatch = bucket = Qnil;
- zero = make_number (0);
-
- /* If COLLECTION is not a list, set TAIL just for gc pro. */
- tail = collection;
- if (type == obarray_table)
- {
- collection = check_obarray (collection);
- obsize = ASIZE (collection);
- bucket = AREF (collection, idx);
- }
-
- while (1)
- {
- /* Get the next element of the alist, obarray, or hash-table. */
- /* Exit the loop if the elements are all used up. */
- /* elt gets the alist element or symbol.
- eltstring gets the name to check as a completion. */
-
- if (type == list_table)
- {
- if (!CONSP (tail))
- break;
- elt = XCAR (tail);
- eltstring = CONSP (elt) ? XCAR (elt) : elt;
- tail = XCDR (tail);
- }
- else if (type == obarray_table)
- {
- if (!EQ (bucket, zero))
- {
- if (!SYMBOLP (bucket))
- error ("Bad data in guts of obarray");
- elt = bucket;
- eltstring = elt;
- if (XSYMBOL (bucket)->next)
- XSETSYMBOL (bucket, XSYMBOL (bucket)->next);
- else
- XSETFASTINT (bucket, 0);
- }
- else if (++idx >= obsize)
- break;
- else
- {
- bucket = AREF (collection, idx);
- continue;
- }
- }
- else /* if (type == hash_table) */
- {
- while (idx < HASH_TABLE_SIZE (XHASH_TABLE (collection))
- && NILP (HASH_HASH (XHASH_TABLE (collection), idx)))
- idx++;
- if (idx >= HASH_TABLE_SIZE (XHASH_TABLE (collection)))
- break;
- else
- elt = eltstring = HASH_KEY (XHASH_TABLE (collection), idx++);
- }
-
- /* Is this element a possible completion? */
-
- if (SYMBOLP (eltstring))
- eltstring = Fsymbol_name (eltstring);
-
- if (STRINGP (eltstring)
- && SCHARS (string) <= SCHARS (eltstring)
- && (tem = Fcompare_strings (eltstring, zero,
- make_number (SCHARS (string)),
- string, zero, Qnil,
- completion_ignore_case ? Qt : Qnil),
- EQ (Qt, tem)))
- {
- /* Yes. */
- Lisp_Object regexps;
-
- /* Ignore this element if it fails to match all the regexps. */
- {
- dynwind_begin ();
- specbind (Qcase_fold_search,
- completion_ignore_case ? Qt : Qnil);
- for (regexps = Vcompletion_regexp_list; CONSP (regexps);
- regexps = XCDR (regexps))
- {
- tem = Fstring_match (XCAR (regexps), eltstring, zero);
- if (NILP (tem))
- break;
- }
- dynwind_end ();
- if (CONSP (regexps))
- continue;
- }
-
- /* Ignore this element if there is a predicate
- and the predicate doesn't like it. */
-
- if (!NILP (predicate))
- {
- if (EQ (predicate, Qcommandp))
- tem = Fcommandp (elt, Qnil);
- else
- {
- GCPRO4 (tail, string, eltstring, bestmatch);
- tem = (type == hash_table
- ? call2 (predicate, elt,
- HASH_VALUE (XHASH_TABLE (collection),
- idx - 1))
- : call1 (predicate, elt));
- UNGCPRO;
- }
- if (NILP (tem)) continue;
- }
-
- /* Update computation of how much all possible completions match */
-
- if (NILP (bestmatch))
- {
- matchcount = 1;
- bestmatch = eltstring;
- bestmatchsize = SCHARS (eltstring);
- }
- else
- {
- compare = min (bestmatchsize, SCHARS (eltstring));
- tem = Fcompare_strings (bestmatch, zero,
- make_number (compare),
- eltstring, zero,
- make_number (compare),
- completion_ignore_case ? Qt : Qnil);
- matchsize = EQ (tem, Qt) ? compare : eabs (XINT (tem)) - 1;
-
- if (completion_ignore_case)
- {
- /* If this is an exact match except for case,
- use it as the best match rather than one that is not an
- exact match. This way, we get the case pattern
- of the actual match. */
- if ((matchsize == SCHARS (eltstring)
- && matchsize < SCHARS (bestmatch))
- ||
- /* If there is more than one exact match ignoring case,
- and one of them is exact including case,
- prefer that one. */
- /* If there is no exact match ignoring case,
- prefer a match that does not change the case
- of the input. */
- ((matchsize == SCHARS (eltstring))
- ==
- (matchsize == SCHARS (bestmatch))
- && (tem = Fcompare_strings (eltstring, zero,
- make_number (SCHARS (string)),
- string, zero,
- Qnil,
- Qnil),
- EQ (Qt, tem))
- && (tem = Fcompare_strings (bestmatch, zero,
- make_number (SCHARS (string)),
- string, zero,
- Qnil,
- Qnil),
- ! EQ (Qt, tem))))
- bestmatch = eltstring;
- }
- if (bestmatchsize != SCHARS (eltstring)
- || bestmatchsize != matchsize)
- /* Don't count the same string multiple times. */
- matchcount += matchcount <= 1;
- bestmatchsize = matchsize;
- if (matchsize <= SCHARS (string)
- /* If completion-ignore-case is non-nil, don't
- short-circuit because we want to find the best
- possible match *including* case differences. */
- && !completion_ignore_case
- && matchcount > 1)
- /* No need to look any further. */
- break;
- }
- }
- }
-
- if (NILP (bestmatch))
- return Qnil; /* No completions found. */
- /* If we are ignoring case, and there is no exact match,
- and no additional text was supplied,
- don't change the case of what the user typed. */
- if (completion_ignore_case && bestmatchsize == SCHARS (string)
- && SCHARS (bestmatch) > bestmatchsize)
- return minibuf_conform_representation (string, bestmatch);
-
- /* Return t if the supplied string is an exact match (counting case);
- it does not require any change to be made. */
- if (matchcount == 1 && !NILP (Fequal (bestmatch, string)))
- return Qt;
-
- XSETFASTINT (zero, 0); /* Else extract the part in which */
- XSETFASTINT (end, bestmatchsize); /* all completions agree. */
- return Fsubstring (bestmatch, zero, end);
-}
-\f
-DEFUN ("all-completions", Fall_completions, Sall_completions, 2, 4, 0,
- doc: /* Search for partial matches to STRING in COLLECTION.
-Test each of the possible completions specified by COLLECTION
-to see if it begins with STRING. The possible completions may be
-strings or symbols. Symbols are converted to strings before testing,
-see `symbol-name'.
-The value is a list of all the possible completions that match STRING.
-
-If COLLECTION is an alist, the keys (cars of elements) are the
-possible completions. If an element is not a cons cell, then the
-element itself is the possible completion.
-If COLLECTION is a hash-table, all the keys that are strings or symbols
-are the possible completions.
-If COLLECTION is an obarray, the names of all symbols in the obarray
-are the possible completions.
-
-COLLECTION can also be a function to do the completion itself.
-It receives three arguments: the values STRING, PREDICATE and t.
-Whatever it returns becomes the value of `all-completions'.
-
-If optional third argument PREDICATE is non-nil,
-it is used to test each possible match.
-The match is a candidate only if PREDICATE returns non-nil.
-The argument given to PREDICATE is the alist element
-or the symbol from the obarray. If COLLECTION is a hash-table,
-predicate is called with two arguments: the key and the value.
-Additionally to this predicate, `completion-regexp-list'
-is used to further constrain the set of candidates.
-
-An obsolete optional fourth argument HIDE-SPACES is still accepted for
-backward compatibility. If non-nil, strings in COLLECTION that start
-with a space are ignored unless STRING itself starts with a space. */)
- (Lisp_Object string, Lisp_Object collection, Lisp_Object predicate, Lisp_Object hide_spaces)
-{
- Lisp_Object tail, elt, eltstring;
- Lisp_Object allmatches;
- int type = HASH_TABLE_P (collection) ? 3
- : VECTORP (collection) ? 2
- : NILP (collection) || (CONSP (collection) && !FUNCTIONP (collection));
- ptrdiff_t idx = 0, obsize = 0;
- Lisp_Object bucket, tem, zero;
- struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
-
- CHECK_STRING (string);
- if (type == 0)
- return call3 (collection, string, predicate, Qt);
- allmatches = bucket = Qnil;
- zero = make_number (0);
-
- /* If COLLECTION is not a list, set TAIL just for gc pro. */
- tail = collection;
- if (type == 2)
- {
- collection = check_obarray (collection);
- obsize = ASIZE (collection);
- bucket = AREF (collection, idx);
- }
-
- while (1)
- {
- /* Get the next element of the alist, obarray, or hash-table. */
- /* Exit the loop if the elements are all used up. */
- /* elt gets the alist element or symbol.
- eltstring gets the name to check as a completion. */
-
- if (type == 1)
- {
- if (!CONSP (tail))
- break;
- elt = XCAR (tail);
- eltstring = CONSP (elt) ? XCAR (elt) : elt;
- tail = XCDR (tail);
- }
- else if (type == 2)
- {
- if (!EQ (bucket, zero))
- {
- if (!SYMBOLP (bucket))
- error ("Bad data in guts of obarray");
- elt = bucket;
- eltstring = elt;
- if (XSYMBOL (bucket)->next)
- XSETSYMBOL (bucket, XSYMBOL (bucket)->next);
- else
- XSETFASTINT (bucket, 0);
- }
- else if (++idx >= obsize)
- break;
- else
- {
- bucket = AREF (collection, idx);
- continue;
- }
- }
- else /* if (type == 3) */
- {
- while (idx < HASH_TABLE_SIZE (XHASH_TABLE (collection))
- && NILP (HASH_HASH (XHASH_TABLE (collection), idx)))
- idx++;
- if (idx >= HASH_TABLE_SIZE (XHASH_TABLE (collection)))
- break;
- else
- elt = eltstring = HASH_KEY (XHASH_TABLE (collection), idx++);
- }
-
- /* Is this element a possible completion? */
-
- if (SYMBOLP (eltstring))
- eltstring = Fsymbol_name (eltstring);
-
- if (STRINGP (eltstring)
- && SCHARS (string) <= SCHARS (eltstring)
- /* If HIDE_SPACES, reject alternatives that start with space
- unless the input starts with space. */
- && (NILP (hide_spaces)
- || (SBYTES (string) > 0
- && SREF (string, 0) == ' ')
- || SREF (eltstring, 0) != ' ')
- && (tem = Fcompare_strings (eltstring, zero,
- make_number (SCHARS (string)),
- string, zero,
- make_number (SCHARS (string)),
- completion_ignore_case ? Qt : Qnil),
- EQ (Qt, tem)))
- {
- /* Yes. */
- Lisp_Object regexps;
-
- /* Ignore this element if it fails to match all the regexps. */
- {
- dynwind_begin ();
- specbind (Qcase_fold_search,
- completion_ignore_case ? Qt : Qnil);
- for (regexps = Vcompletion_regexp_list; CONSP (regexps);
- regexps = XCDR (regexps))
- {
- tem = Fstring_match (XCAR (regexps), eltstring, zero);
- if (NILP (tem))
- break;
- }
- dynwind_end ();
- if (CONSP (regexps))
- continue;
- }
-
- /* Ignore this element if there is a predicate
- and the predicate doesn't like it. */
-
- if (!NILP (predicate))
- {
- if (EQ (predicate, Qcommandp))
- tem = Fcommandp (elt, Qnil);
- else
- {
- GCPRO4 (tail, eltstring, allmatches, string);
- tem = type == 3
- ? call2 (predicate, elt,
- HASH_VALUE (XHASH_TABLE (collection), idx - 1))
- : call1 (predicate, elt);
- UNGCPRO;
- }
- if (NILP (tem)) continue;
- }
- /* Ok => put it on the list. */
- allmatches = Fcons (eltstring, allmatches);
- }
- }
-
- return Fnreverse (allmatches);
-}
-\f
DEFUN ("completing-read", Fcompleting_read, Scompleting_read, 2, 8, 0,
doc: /* Read a string in the minibuffer, with completion.
PROMPT is a string to prompt with; normally it ends in a colon and a space.
return Ffuncall (9, args);
}
\f
-/* Test whether TXT is an exact completion. */
-DEFUN ("test-completion", Ftest_completion, Stest_completion, 2, 3, 0,
- doc: /* Return non-nil if STRING is a valid completion.
-Takes the same arguments as `all-completions' and `try-completion'.
-If COLLECTION is a function, it is called with three arguments:
-the values STRING, PREDICATE and `lambda'. */)
- (Lisp_Object string, Lisp_Object collection, Lisp_Object predicate)
-{
- Lisp_Object regexps, tail, tem = Qnil;
- ptrdiff_t i = 0;
-
- CHECK_STRING (string);
-
- if (NILP (collection) || (CONSP (collection) && !FUNCTIONP (collection)))
- {
- tem = Fassoc_string (string, collection, completion_ignore_case ? Qt : Qnil);
- if (NILP (tem))
- return Qnil;
- }
- else if (VECTORP (collection))
- {
- /* Bypass intern-soft as that loses for nil. */
- tem = oblookup (collection,
- SSDATA (string),
- SCHARS (string),
- SBYTES (string));
- if (!SYMBOLP (tem))
- {
- if (STRING_MULTIBYTE (string))
- string = Fstring_make_unibyte (string);
- else
- string = Fstring_make_multibyte (string);
-
- tem = oblookup (collection,
- SSDATA (string),
- SCHARS (string),
- SBYTES (string));
- }
-
- if (completion_ignore_case && !SYMBOLP (tem))
- {
- for (i = ASIZE (collection) - 1; i >= 0; i--)
- {
- tail = AREF (collection, i);
- if (SYMBOLP (tail))
- while (1)
- {
- if (EQ (Fcompare_strings (string, make_number (0), Qnil,
- Fsymbol_name (tail),
- make_number (0) , Qnil, Qt),
- Qt))
- {
- tem = tail;
- break;
- }
- if (XSYMBOL (tail)->next == 0)
- break;
- XSETSYMBOL (tail, XSYMBOL (tail)->next);
- }
- }
- }
-
- if (!SYMBOLP (tem))
- return Qnil;
- }
- else if (HASH_TABLE_P (collection))
- {
- struct Lisp_Hash_Table *h = XHASH_TABLE (collection);
- Lisp_Object key = Qnil;
- i = hash_lookup (h, string, NULL);
- if (i >= 0)
- tem = HASH_KEY (h, i);
- else
- for (i = 0; i < HASH_TABLE_SIZE (h); ++i)
- if (!NILP (HASH_HASH (h, i))
- && (key = HASH_KEY (h, i),
- SYMBOLP (key) ? key = Fsymbol_name (key) : key,
- STRINGP (key))
- && EQ (Fcompare_strings (string, make_number (0), Qnil,
- key, make_number (0) , Qnil,
- completion_ignore_case ? Qt : Qnil),
- Qt))
- {
- tem = key;
- break;
- }
- if (!STRINGP (tem))
- return Qnil;
- }
- else
- return call3 (collection, string, predicate, Qlambda);
-
- /* Reject this element if it fails to match all the regexps. */
- if (CONSP (Vcompletion_regexp_list))
- {
- dynwind_begin ();
- specbind (Qcase_fold_search, completion_ignore_case ? Qt : Qnil);
- for (regexps = Vcompletion_regexp_list; CONSP (regexps);
- regexps = XCDR (regexps))
- {
- if (NILP (Fstring_match (XCAR (regexps),
- SYMBOLP (tem) ? string : tem,
- Qnil))){
-
- dynwind_end ();
- return Qnil;
- }
- }
- dynwind_end ();
- }
-
- /* Finally, check the predicate. */
- if (!NILP (predicate))
- {
- return HASH_TABLE_P (collection)
- ? call2 (predicate, tem, HASH_VALUE (XHASH_TABLE (collection), i))
- : call1 (predicate, tem);
- }
- else
- return Qt;
-}
-
-static Lisp_Object Qmetadata;
-
-DEFUN ("internal-complete-buffer", Finternal_complete_buffer, Sinternal_complete_buffer, 3, 3, 0,
- doc: /* Perform completion on buffer names.
-STRING and PREDICATE have the same meanings as in `try-completion',
-`all-completions', and `test-completion'.
-
-If FLAG is nil, invoke `try-completion'; if it is t, invoke
-`all-completions'; otherwise invoke `test-completion'. */)
- (Lisp_Object string, Lisp_Object predicate, Lisp_Object flag)
-{
- if (NILP (flag))
- return Ftry_completion (string, Vbuffer_alist, predicate);
- else if (EQ (flag, Qt))
- {
- Lisp_Object res = Fall_completions (string, Vbuffer_alist, predicate, Qnil);
- if (SCHARS (string) > 0)
- return res;
- else
- { /* Strip out internal buffers. */
- Lisp_Object bufs = res;
- /* First, look for a non-internal buffer in `res'. */
- while (CONSP (bufs) && SREF (XCAR (bufs), 0) == ' ')
- bufs = XCDR (bufs);
- if (NILP (bufs))
- return (EQ (Flength (res), Flength (Vbuffer_alist))
- /* If all bufs are internal don't strip them out. */
- ? res : bufs);
- res = bufs;
- while (CONSP (XCDR (bufs)))
- if (SREF (XCAR (XCDR (bufs)), 0) == ' ')
- XSETCDR (bufs, XCDR (XCDR (bufs)));
- else
- bufs = XCDR (bufs);
- return res;
- }
- }
- else if (EQ (flag, Qlambda))
- return Ftest_completion (string, Vbuffer_alist, predicate);
- else if (EQ (flag, Qmetadata))
- return list2 (Qmetadata, Fcons (Qcategory, Qbuffer));
- else
- return Qnil;
-}
-
/* Like assoc but assumes KEY is a string, and ignores case if appropriate. */
DEFUN ("assoc-string", Fassoc_string, Sassoc_string, 2, 3, 0,
DEFSYM (Qcurrent_input_method, "current-input-method");
DEFSYM (Qactivate_input_method, "activate-input-method");
DEFSYM (Qcase_fold_search, "case-fold-search");
- DEFSYM (Qmetadata, "metadata");
DEFVAR_LISP ("read-expression-history", Vread_expression_history,
doc: /* A history list for arguments that are Lisp expressions to evaluate.
HCoop / bpt / emacs.git / commitdiff