From d303723754e9de93fc9325b012c345ed54f3da4c Mon Sep 17 00:00:00 2001 From: BT Templeton Date: Wed, 14 Aug 2013 20:23:59 -0400 Subject: [PATCH] Lisp completion functions * src/minibuf.c (minibuf_conform_representation, Ftry_completion) (Fall_completions, Ftest_completion, Finternal_complete_buffer): Rewrite in Lisp and move... * lisp/minibuffer.el (minibuf-conform-representation, try-completion) (all-completions, test-completion, internal-complete-buffer): ...here. --- lisp/minibuffer.el | 385 +++++++++++++++++++++++++++++ lisp/subr.el | 2 - src/minibuf.c | 602 --------------------------------------------- 3 files changed, 385 insertions(+), 604 deletions(-) diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index e7e08342b4..bdb9ef9cbf 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -89,6 +89,391 @@ (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. diff --git a/lisp/subr.el b/lisp/subr.el index 306c338390..5280c77107 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -1250,8 +1250,6 @@ is converted into a string by expressing it in decimal." (make-obsolete 'unfocus-frame "it does nothing." "22.1") (make-obsolete 'make-variable-frame-local "explicitly check for a frame-parameter instead." "22.2") -(set-advertised-calling-convention - 'all-completions '(string collection &optional predicate) "23.1") (set-advertised-calling-convention 'unintern '(name obarray) "23.3") (set-advertised-calling-convention 'redirect-frame-focus '(frame focus-frame) "24.3") (set-advertised-calling-convention 'decode-char '(ch charset) "21.4") diff --git a/src/minibuf.c b/src/minibuf.c index e257ac2177..5df56a5f98 100644 --- a/src/minibuf.c +++ b/src/minibuf.c @@ -1149,440 +1149,6 @@ function, instead of the usual behavior. */) return result; } -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); -} - -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); -} - 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. @@ -1655,173 +1221,6 @@ See also `completing-read-function'. */) return Ffuncall (9, args); } -/* 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, @@ -1920,7 +1319,6 @@ syms_of_minibuf (void) 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. -- 2.20.1