[COMMIT] Support hash COLLECTIONs, #'{all,try}-completion{s,}; add #'test-completion

APPROVE COMMIT NOTE: This patch has been committed. # HG changeset patch # User Aidan Kehoe <kehoea(a)parhasard.net&gt; # Date 1325431132 0 # Node ID 2014ff433dafca722d256995c405d3a8faabfd85 # Parent 49c36ed998b65d72657b50a3573a20bde8e41227 Support hash COLLECTIONs, #'{all,try}-completion{s,}; add #'test-completion src/ChangeLog addition: 2012-01-01 Aidan Kehoe <kehoea(a)parhasard.net&gt; Add #'test-completion, API from GNU. Accept hash table COLLECTIONs in it and in the other completion-oriented functions, #'try-completion, #'all-completions, and those Lisp functions implemented in terms of them. * lisp.h: Update the prototype of map_obarray(), making FN compatible with the FUNCTION argument of elisp_maphash(); * abbrev.c (abbrev_match_mapper): * abbrev.c (record_symbol): * doc.c (verify_doc_mapper): * symbols.c (mapatoms_1): * symbols.c (apropos_mapper): Update these mapper functions to reflect the new argument to map_obarray(). * symbols.c (map_obarray): Call FN with two arguments, the string name of the symbol, and the symbol itself, for API (mapper) compatibility with elisp_maphash(). * minibuf.c (map_completion): New. Map a maphash_function_t across a non function COLLECTION, as appropriate for #'try-completion and friends. * minibuf.c (map_completion_list): New. Map a maphash_function_t across a pseudo-alist, as appropriate for the completion functions. * minibuf.c (ignore_completion_p): PRED needs to be called with two args if and only if the collection is a hash table. Implement this. * minibuf.c (try_completion_mapper): New. The loop body of #'try-completion, refactored out. * minibuf.c (Ftry_completion): Use try_completion_mapper(), map_completion(). * minibuf.c (all_completions_mapper): New. The loop body of #'all-completions, refactored out. * minibuf.c (Fall_completions): Use all_completions_mapper(), map_completion(). * minibuf.c (test_completion_mapper): New. The loop body of #'test-completion. * minibuf.c (Ftest_completion): New, API from GNU. * minibuf.c (syms_of_minibuf): Make Ftest_completion available. tests/ChangeLog addition: 2012-01-01 Aidan Kehoe <kehoea(a)parhasard.net&gt; * automated/completion-tests.el: New. Test #'try-completion, #'all-completion and #'test-completion with list, vector and hash-table COLLECTION arguments. diff -r 49c36ed998b6 -r 2014ff433daf src/ChangeLog --- a/src/ChangeLog Fri Dec 30 16:39:14 2011 +0000 +++ b/src/ChangeLog Sun Jan 01 15:18:52 2012 +0000 ＠＠ -1,3 +1,49 ＠＠ +2012-01-01 Aidan Kehoe <kehoea(a)parhasard.net&gt; + + Add #'test-completion, API from GNU. + Accept hash table COLLECTIONs in it and in the other + completion-oriented functions, #'try-completion, + #'all-completions, and those Lisp functions implemented in terms + of them. + + * lisp.h: Update the prototype of map_obarray(), making FN + compatible with the FUNCTION argument of elisp_maphash(); + + * abbrev.c (abbrev_match_mapper): + * abbrev.c (record_symbol): + * doc.c (verify_doc_mapper): + * symbols.c (mapatoms_1): + * symbols.c (apropos_mapper): + Update these mapper functions to reflect the new argument to + map_obarray(). + + * symbols.c (map_obarray): + Call FN with two arguments, the string name of the symbol, and the + symbol itself, for API (mapper) compatibility with + elisp_maphash(). + + * minibuf.c (map_completion): New. Map a maphash_function_t across + a non function COLLECTION, as appropriate for #'try-completion and + friends. + * minibuf.c (map_completion_list): New. Map a maphash_function_t + across a pseudo-alist, as appropriate for the completion + functions. + * minibuf.c (ignore_completion_p): PRED needs to be called with + two args if and only if the collection is a hash table. Implement + this. + * minibuf.c (try_completion_mapper): New. The loop body of + #'try-completion, refactored out. + * minibuf.c (Ftry_completion): Use try_completion_mapper(), + map_completion(). + * minibuf.c (all_completions_mapper): New. The loop body of + #'all-completions, refactored out. + * minibuf.c (Fall_completions): Use all_completions_mapper(), + map_completion(). + * minibuf.c (test_completion_mapper): New. The loop body of + #'test-completion. + * minibuf.c (Ftest_completion): New, API from GNU. + * minibuf.c (syms_of_minibuf): Make Ftest_completion available. + 2011-12-30 Aidan Kehoe <kehoea(a)parhasard.net&gt; * eval.c (Fmacroexpand): diff -r 49c36ed998b6 -r 2014ff433daf src/abbrev.c --- a/src/abbrev.c Fri Dec 30 16:39:14 2011 +0000 +++ b/src/abbrev.c Sun Jan 01 15:18:52 2012 +0000 ＠＠ -88,7 +88,8 ＠＠ before point, case-insensitively. When found, return non-zero, so that map_obarray terminates mapping. */ static int -abbrev_match_mapper (Lisp_Object symbol, void *arg) +abbrev_match_mapper (Lisp_Object UNUSED (key), Lisp_Object symbol, + void *arg) { struct abbrev_match_mapper_closure *closure = (struct abbrev_match_mapper_closure *)arg; ＠＠ -478,7 +479,7 ＠＠ } static int -record_symbol (Lisp_Object sym, void *arg) +record_symbol (Lisp_Object UNUSED (key), Lisp_Object sym, void *arg) { Lisp_Object closure = * (Lisp_Object *) arg; XSETCDR (closure, Fcons (sym, XCDR (closure))); diff -r 49c36ed998b6 -r 2014ff433daf src/doc.c --- a/src/doc.c Fri Dec 30 16:39:14 2011 +0000 +++ b/src/doc.c Sun Jan 01 15:18:52 2012 +0000 ＠＠ -972,7 +972,7 ＠＠ static int -verify_doc_mapper (Lisp_Object sym, void *arg) +verify_doc_mapper (Lisp_Object UNUSED (key), Lisp_Object sym, void *arg) { Lisp_Object closure = * (Lisp_Object *) arg; diff -r 49c36ed998b6 -r 2014ff433daf src/lisp.h --- a/src/lisp.h Fri Dec 30 16:39:14 2011 +0000 +++ b/src/lisp.h Sun Jan 01 15:18:52 2012 +0000 ＠＠ -5797,7 +5797,9 ＠＠ MODULE_API Lisp_Object intern (const CIbyte *str); Lisp_Object intern_massaging_name (const CIbyte *str); Lisp_Object oblookup (Lisp_Object, const Ibyte *, Bytecount); -void map_obarray (Lisp_Object, int (*) (Lisp_Object, void *), void *); +/* Note that the mapper function has the same signature as in elisp_maphash. */ +void map_obarray (Lisp_Object, int (*) (Lisp_Object, Lisp_Object, void *), + void *); Lisp_Object indirect_function (Lisp_Object, int); Lisp_Object symbol_value_in_buffer (Lisp_Object, Lisp_Object); void kill_buffer_local_variables (struct buffer *); diff -r 49c36ed998b6 -r 2014ff433daf src/minibuf.c --- a/src/minibuf.c Fri Dec 30 16:39:14 2011 +0000 +++ b/src/minibuf.c Sun Jan 01 15:18:52 2012 +0000 ＠＠ -35,6 +35,7 ＠＠ #include "insdel.h" #include "redisplay.h" #include "window-impl.h" +#include "elhash.h" /* Depth in minibuffer invocations. */ int minibuf_level; ＠＠ -244,6 +245,51 ＠＠ else return len - l; } +/* Map FUNCTION, a C function, across LISZT, a pseudo-alist, calling + it with three args, ELTSTRING (the car of the element if a cons, + otherwise the element itself), ELT (the element, always) and + EXTRA_ARG. Stop if FUNCTION returns non-zero. */ +static void +map_completion_list (maphash_function_t function, Lisp_Object liszt, + void *extra_arg) +{ + Lisp_Object eltstring; + + GC_EXTERNAL_LIST_LOOP_2 (elt, liszt) + { + eltstring = CONSP (elt) ? XCAR (elt) : elt; + if (function (eltstring, elt, extra_arg)) + { + XUNGCPRO (elt); + return; + } + } + END_GC_EXTERNAL_LIST_LOOP (elt); +} + +static void +map_completion (maphash_function_t function, Lisp_Object collection, + void *extra_arg, Lisp_Object predicate) +{ + if (LISTP (collection)) + { + map_completion_list (function, collection, extra_arg); + } + else if (VECTORP (collection)) + { + map_obarray (collection, function, extra_arg); + } + else if (NILP (predicate)) + { + /* This can't call Lisp, no need to copy and compress the hash + table entries. */ + elisp_maphash_unsafe (function, collection, extra_arg); + } + else + { + elisp_maphash (function, collection, extra_arg); + } +} int regexp_ignore_completion_p (const Ibyte *nonreloc, ＠＠ -264,53 +310,157 ＠＠ return 0; } - /* Callers should GCPRO, since this may call eval */ static int ignore_completion_p (Lisp_Object completion_string, - Lisp_Object pred, Lisp_Object completion) + Lisp_Object pred, Lisp_Object completion, + Boolint hash_tablep) { + Lisp_Object tem; + if (regexp_ignore_completion_p (0, completion_string, 0, -1)) return 1; - /* Ignore this element if there is a predicate - and the predicate doesn't like it. */ - if (!NILP (pred)) - { - Lisp_Object tem; - if (EQ (pred, Qcommandp)) + if (NILP (pred)) + { + return 0; + } + + /* Ignore this element if there is a predicate and the predicate doesn't + like it. */ + if (hash_tablep) + { + tem = call2 (pred, completion_string, completion); + } + else if (EQ (pred, Qcommandp)) + { tem = Fcommandp (completion); - else + } + else + { tem = call1 (pred, completion); - if (NILP (tem)) - return 1; - } + } + + return NILP (tem); +} + +struct try_completion_closure +{ + Lisp_Object string; + Charcount slength; + Lisp_Object predicate; + Lisp_Object bestmatch; + Charcount blength; + Charcount bestmatchsize; + Boolint hash_tablep; + int matchcount; +}; + +static int +try_completion_mapper (Lisp_Object eltstring, Lisp_Object value, + void *arg) +{ + struct try_completion_closure *tcc = (struct try_completion_closure *) arg; + Charcount eltlength; + + if (SYMBOLP (eltstring)) + { + eltstring = XSYMBOL_NAME (eltstring); + } + + if (!STRINGP (eltstring)) + { + return 0; + } + + /* Is this element a possible completion? */ + eltlength = string_char_length (eltstring); + if (tcc->slength <= eltlength + && (0 > scmp (XSTRING_DATA (eltstring), XSTRING_DATA (tcc->string), + tcc->slength))) + { + struct gcpro gcpro1, gcpro2, gcpro3; + int loser; + GCPRO3 (tcc->string, eltstring, tcc->bestmatch); + loser = ignore_completion_p (eltstring, tcc->predicate, value, + tcc->hash_tablep); + UNGCPRO; + if (loser) /* reject this one */ + { + return 0; + } + + /* Update computation of how much all possible completions + match */ + + tcc->matchcount++; + if (NILP (tcc->bestmatch)) + { + tcc->bestmatch = eltstring; + tcc->blength = eltlength; + tcc->bestmatchsize = eltlength; + } + else + { + Charcount compare = min (tcc->bestmatchsize, eltlength); + Charcount matchsize = + scmp (XSTRING_DATA (tcc->bestmatch), XSTRING_DATA (eltstring), + compare); + if (matchsize < 0) + matchsize = compare; + 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 == eltlength + && matchsize < tcc->blength) + || + /* 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 == eltlength) + == + (matchsize == tcc->blength) + && 0 > scmp_1 (XSTRING_DATA (eltstring), + XSTRING_DATA (tcc->string), + tcc->slength, 0) + && 0 <= scmp_1 (XSTRING_DATA (tcc->bestmatch), + XSTRING_DATA (tcc->string), + tcc->slength, 0))) + { + tcc->bestmatch = eltstring; + tcc->blength = eltlength; + } + } + tcc->bestmatchsize = matchsize; + } + } + return 0; } - -/* #### Maybe we should allow COLLECTION to be a hash table. - It is wrong for the use of obarrays to be better-rewarded than the - use of hash tables. By better-rewarded I mean that you can pass an - obarray to all of the completion functions, whereas you can't do - anything like that with a hash table. - - To do so, there should probably be a - map_obarray_or_alist_or_hash_table function which would be used by - both Ftry_completion and Fall_completions. [[ But would the - additional funcalls slow things down? ]] Seriously doubtful. --ben */ - DEFUN ("try-completion", Ftry_completion, 2, 3, 0, /* Return common substring of all completions of STRING in COLLECTION. -COLLECTION must be an alist, an obarray, or a function. -Each string in COLLECTION is tested to see if it begins with STRING. -All that match are compared together; the longest initial sequence -common to all matches is returned as a string. If there is no match -at all, nil is returned. For an exact match, t is returned. +COLLECTION must be a list, a hash table, an obarray, or a function. -If COLLECTION is list, the elements of the list that are not cons +Each string (or symbol) in COLLECTION is tested to see if it (or its +name) begins with STRING. All that match are compared together; the +longest initial sequence common to all matches is returned as a +string. If there is no match at all, nil is returned. For an exact +match, t is returned. + +If COLLECTION is a list, the elements of the list that are not cons cells and the cars of the elements of the list that are cons cells -(which must be strings) form the set of possible completions. +\(which must be strings or symbols) form the set of possible +completions. + +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. ＠＠ -322,207 +472,122 ＠＠ 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. +or the symbol from the obarray. If COLLECTION is a hash table, +PREDICATE is passed two arguments, the key and the value of the hash +table entry. */ (string, collection, predicate)) { /* This function can GC */ - Lisp_Object bestmatch, tail; - Charcount bestmatchsize = 0; - int list; - int indice = 0; - int matchcount = 0; - int obsize; - Lisp_Object bucket; - Charcount slength, blength; + struct try_completion_closure tcc; CHECK_STRING (string); - if (CONSP (collection)) + if (!NILP (Ffunctionp (collection))) { - Lisp_Object tem = XCAR (collection); - if (SYMBOLP (tem)) /* lambda, autoload, etc. Emacs-lisp sucks */ - return call3 (collection, string, predicate, Qnil); - else - list = 1; - } - else if (VECTORP (collection)) - list = 0; - else if (NILP (collection)) - list = 1; - else - return call3 (collection, string, predicate, Qnil); - - bestmatch = Qnil; - blength = 0; - slength = string_char_length (string); - - /* If COLLECTION is not a list, set TAIL just for gc pro. */ - tail = collection; - if (!list) - { - obsize = XVECTOR_LENGTH (collection); - bucket = XVECTOR_DATA (collection)[indice]; - } - else /* warning suppression */ - { - obsize = 0; - bucket = Qnil; + return call3 (collection, string, predicate, Qnil); } - while (1) + if (!(LISTP (collection) || VECTORP (collection) || HASH_TABLEP (collection))) { - /* Get the next element of the alist or obarray. */ - /* 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. */ - Lisp_Object elt; - Lisp_Object eltstring; - - if (list) - { - if (NILP (tail)) - break; - elt = Fcar (tail); - if (CONSP (elt)) - eltstring = Fcar (elt); - else - eltstring = elt; - tail = Fcdr (tail); - } - else - { - if (!ZEROP (bucket)) - { - Lisp_Symbol *next; - if (!SYMBOLP (bucket)) - { - invalid_argument ("Bad obarray passed to try-completions", - bucket); - } - next = symbol_next (XSYMBOL (bucket)); - elt = bucket; - eltstring = Fsymbol_name (elt); - if (next) - bucket = wrap_symbol (next); - else - bucket = Qzero; - } - else if (++indice >= obsize) - break; - else - { - bucket = XVECTOR_DATA (collection)[indice]; - continue; - } - } - - /* Is this element a possible completion? */ - - if (STRINGP (eltstring)) - { - Charcount eltlength = string_char_length (eltstring); - if (slength <= eltlength - && (0 > scmp (XSTRING_DATA (eltstring), - XSTRING_DATA (string), - slength))) - { - { - struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; - int loser; - GCPRO4 (tail, string, eltstring, bestmatch); - loser = ignore_completion_p (eltstring, predicate, elt); - UNGCPRO; - if (loser) /* reject this one */ - continue; - } - - /* Update computation of how much all possible - completions match */ - - matchcount++; - if (NILP (bestmatch)) - { - bestmatch = eltstring; - blength = eltlength; - bestmatchsize = eltlength; - } - else - { - Charcount compare = min (bestmatchsize, eltlength); - Charcount matchsize = - scmp (XSTRING_DATA (bestmatch), - XSTRING_DATA (eltstring), - compare); - if (matchsize < 0) - matchsize = compare; - 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 == eltlength - && matchsize < blength) - || - /* 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 == eltlength) - == - (matchsize == blength) - && 0 > scmp_1 (XSTRING_DATA (eltstring), - XSTRING_DATA (string), - slength, 0) - && 0 <= scmp_1 (XSTRING_DATA (bestmatch), - XSTRING_DATA (string), - slength, 0))) - { - bestmatch = eltstring; - blength = eltlength; - } - } - bestmatchsize = matchsize; - } - } - } + signal_error (Qwrong_type_argument, + "must be a list, vector, hash table or function", + collection); } - if (NILP (bestmatch)) + tcc.string = string; + tcc.slength = string_char_length (string); + tcc.bestmatch = Qnil; + tcc.blength = 0; + tcc.bestmatchsize = 0; + tcc.predicate = predicate; + tcc.hash_tablep = HASH_TABLEP (collection); + tcc.matchcount = 0; + + map_completion (try_completion_mapper, collection, &tcc, predicate); + + if (NILP (tcc.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 == slength - && blength > bestmatchsize) + + /* 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 && tcc.bestmatchsize == tcc.slength + && tcc.blength > tcc.bestmatchsize) return string; - /* Return t if the supplied string is an exact match (counting case); - it does not require any change to be made. */ - if (matchcount == 1 - && bestmatchsize == slength - && 0 > scmp_1 (XSTRING_DATA (bestmatch), - XSTRING_DATA (string), - bestmatchsize, 0)) + /* Return t if the supplied string is an exact match (counting + case); it does not require any change to be made. */ + if (tcc.matchcount == 1 && tcc.bestmatchsize == tcc.slength + && 0 > scmp_1 (XSTRING_DATA (tcc.bestmatch), XSTRING_DATA (tcc.string), + tcc.bestmatchsize, 0)) return Qt; /* Else extract the part in which all completions agree */ - return Fsubseq (bestmatch, Qzero, make_fixnum (bestmatchsize)); + return Fsubseq (tcc.bestmatch, Qzero, make_fixnum (tcc.bestmatchsize)); +} + +struct all_completions_closure +{ + Lisp_Object string; + Charcount slength; + Lisp_Object predicate; + Lisp_Object allmatches; + Boolint hash_tablep; +}; + +static int +all_completions_mapper (Lisp_Object eltstring, Lisp_Object value, void *arg) +{ + struct all_completions_closure *acc = (struct all_completions_closure *) arg; + /* Is this element a possible completion? */ + + if (SYMBOLP (eltstring)) + { + eltstring = XSYMBOL_NAME (eltstring); + } + + if (STRINGP (eltstring) && (acc->slength <= string_char_length (eltstring)) + /* Reject alternatives that start with space unless the input + starts with space. */ + && ((acc->slength > 0 && string_ichar (acc->string, 0) == ' ') + || string_ichar (eltstring, 0) != ' ') + && (0 > scmp (XSTRING_DATA (eltstring), XSTRING_DATA (acc->string), + acc->slength))) + { + /* Yes. Now check whether predicate likes it. */ + struct gcpro gcpro1, gcpro2; + int loser; + GCPRO2 (eltstring, acc->string); + loser = ignore_completion_p (eltstring, acc->predicate, value, + acc->hash_tablep); + UNGCPRO; + if (!loser) + { + /* Ok => put it on the list. */ + XSETCDR (acc->allmatches, Fcons (eltstring, Qnil)); + acc->allmatches = XCDR (acc->allmatches); + } + } + + return 0; } - DEFUN ("all-completions", Fall_completions, 2, 3, 0, /* Search for partial matches to STRING in COLLECTION. -COLLECTION must be an alist, an obarray, or a function. -Each string in COLLECTION is tested to see if it begins with STRING. -The value is a list of all the strings from COLLECTION that match. +COLLECTION must be an list, a hash table, an obarray, or a function. -If COLLECTION is an alist, the cars of the elements of the alist -\(which must be strings) form the set of possible completions. +Each string (or symbol) in COLLECTION is tested to see if it (or its +name) begins with STRING. The value is a list of all the strings from +COLLECTION that match. + +If COLLECTION is a list, the elements of the list that are not cons +cells and the cars of the elements of the list that are cons cells +\(which must be strings or symbols) form the set of possible +completions. + +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. ＠＠ -534,117 +599,179 ＠＠ 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. +or the symbol from the obarray. If COLLECTION is a hash table, +PREDICATE is passed two arguments, the key and the value of the hash +table entry. */ (string, collection, predicate)) { /* This function can GC */ - Lisp_Object tail; - Lisp_Object allmatches; - int list; - int indice = 0; - int obsize; - Lisp_Object bucket; - Charcount slength; + struct all_completions_closure acc; + Lisp_Object allmatches = noseeum_cons (Qnil, Qnil); + struct gcpro gcpro1; CHECK_STRING (string); - if (CONSP (collection)) + if (!NILP (Ffunctionp (collection))) { - Lisp_Object tem = XCAR (collection); - if (SYMBOLP (tem)) /* lambda, autoload, etc. Emacs-lisp sucks */ - return call3 (collection, string, predicate, Qt); - else - list = 1; - } - else if (VECTORP (collection)) - list = 0; - else if (NILP (collection)) - list = 1; - else - return call3 (collection, string, predicate, Qt); - - allmatches = Qnil; - slength = string_char_length (string); - - /* If COLLECTION is not a list, set TAIL just for gc pro. */ - tail = collection; - if (!list) - { - obsize = XVECTOR_LENGTH (collection); - bucket = XVECTOR_DATA (collection)[indice]; - } - else /* warning suppression */ - { - obsize = 0; - bucket = Qnil; + return call3 (collection, string, predicate, Qt); } - while (1) + if (!(LISTP (collection) || VECTORP (collection) || HASH_TABLEP (collection))) { - /* Get the next element of the alist or obarray. */ - /* 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. */ - Lisp_Object elt; - Lisp_Object eltstring; + signal_error (Qwrong_type_argument, + "must be a list, vector, hash table or function", + collection); + } + GCPRO1 (allmatches); + acc.string = string; + acc.slength = string_char_length (string); + acc.predicate = predicate; + acc.allmatches = allmatches; + acc.hash_tablep = HASH_TABLEP (collection); - if (list) - { - if (NILP (tail)) - break; - elt = Fcar (tail); - eltstring = Fcar (elt); - tail = Fcdr (tail); - } - else - { - if (!ZEROP (bucket)) - { - Lisp_Symbol *next = symbol_next (XSYMBOL (bucket)); - elt = bucket; - eltstring = Fsymbol_name (elt); - if (next) - bucket = wrap_symbol (next); - else - bucket = Qzero; - } - else if (++indice >= obsize) - break; - else - { - bucket = XVECTOR_DATA (collection)[indice]; - continue; - } - } + map_completion (all_completions_mapper, collection, &acc, predicate); - /* Is this element a possible completion? */ + acc.allmatches = XCDR (allmatches); + free_cons (allmatches); + UNGCPRO; + return acc.allmatches; +} + +struct test_completion_closure +{ + Lisp_Object string; + Lisp_Object predicate; + Lisp_Object result; + Boolint hash_tablep; +}; - if (STRINGP (eltstring) - && (slength <= string_char_length (eltstring)) - /* Reject alternatives that start with space - unless the input starts with space. */ - && ((string_char_length (string) > 0 && - string_ichar (string, 0) == ' ') - || string_ichar (eltstring, 0) != ' ') - && (0 > scmp (XSTRING_DATA (eltstring), - XSTRING_DATA (string), - slength))) - { - /* Yes. Now check whether predicate likes it. */ - struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; - int loser; - GCPRO4 (tail, eltstring, allmatches, string); - loser = ignore_completion_p (eltstring, predicate, elt); - UNGCPRO; - if (!loser) - /* Ok => put it on the list. */ - allmatches = Fcons (eltstring, allmatches); +static int +test_completion_mapper (Lisp_Object eltstring, Lisp_Object value, void *arg) +{ + struct test_completion_closure *tcc = (struct test_completion_closure *) arg; + + if (SYMBOLP (eltstring)) + { + eltstring = XSYMBOL_NAME (eltstring); + } + + if (!STRINGP (eltstring)) + { + return 0; + } + + if (completion_ignore_case ? + 0 == qxetextcasecmp (XSTRING_DATA (tcc->string), + XSTRING_LENGTH (tcc->string), + XSTRING_DATA (eltstring), + XSTRING_LENGTH (eltstring)) +: 0 == qxememcmp4 (XSTRING_DATA (tcc->string), + XSTRING_LENGTH (tcc->string), + XSTRING_DATA (eltstring), + XSTRING_LENGTH (eltstring))) + { + struct gcpro gcpro1, gcpro2, gcpro3; + int loser; + GCPRO3 (eltstring, tcc->string, tcc->predicate); + loser = ignore_completion_p (eltstring, tcc->predicate, value, + tcc->hash_tablep); + UNGCPRO; + if (!loser) + { + tcc->result = Qt; + return 1; } } - return Fnreverse (allmatches); + return 0; } + +DEFUN ("test-completion", Ftest_completion, 2, 3, 0, /* +Return non-nil if STRING is a valid completion in COLLECTION. + +COLLECTION must be a list, a hash table, an obarray, or a function. + +Each string (or symbol) in COLLECTION is tested to see if it (or its +name) begins with STRING. The value is a list of all the strings from +COLLECTION that match. + +If COLLECTION is a list, the elements of the list that are not cons +cells and the cars of the elements of the list that are cons cells +\(which must be strings or symbols) form the set of possible +completions. + +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. + +If COLLECTION is a function, it is called with three arguments: the +values STRING, PREDICATE and the symbol `lambda'. Whatever it returns +is passed back by `test-completion'. + +If optional third argument PREDICATE is non-nil, it is used to test +for possible matches. 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 passed two arguments, the key and the value of the hash +table entry. +*/ + (string, collection, predicate)) +{ + struct test_completion_closure tcc; + + CHECK_STRING (string); + + if (!NILP (Ffunctionp (collection))) + { + return call3 (collection, string, predicate, Qlambda); + } + + if (!(LISTP (collection) || VECTORP (collection) || HASH_TABLEP (collection))) + { + signal_error (Qwrong_type_argument, + "must be a list, vector, hash table or function", + collection); + } + + tcc.string = string; + tcc.predicate = predicate; + tcc.result = Qnil; + tcc.hash_tablep = HASH_TABLEP (collection); + + if (VECTORP (collection) && !completion_ignore_case) + { + /* We're case sensitive -> no need for a linear search. */ + Lisp_Object lookup = Fintern_soft (string, collection, Qzero); + + if (ZEROP (lookup)) + { + return Qnil; + } + + return ignore_completion_p (XSYMBOL_NAME (lookup), tcc.predicate, + lookup, 0) ? Qnil : Qt; + + /* It would be reasonable to do something similar for the hash + tables, except, both symbol and string keys are vaild + completions there. So a negative #'gethash for the string + (with #'equal as the hash table tests) still means you have + to do the linear search, for any symbols with that string + name, which hash very differently; returning t is a little + quicker, but returning nil is just as slow, so our average + performance barely changes, at the cost of code + complexity. */ + } + else + { + map_completion (test_completion_mapper, collection, &tcc, predicate); + } + + return tcc.result; +} +  /* Useless FSFmacs functions */ /* More than useless. I've nuked minibuf_prompt_width so they won't ＠＠ -939,6 +1066,7 ＠＠ DEFSUBR (Ftry_completion); DEFSUBR (Fall_completions); + DEFSUBR (Ftest_completion); DEFSYMBOL (Qappend_message); DEFSYMBOL (Qclear_message); diff -r 49c36ed998b6 -r 2014ff433daf src/symbols.c --- a/src/symbols.c Fri Dec 30 16:39:14 2011 +0000 +++ b/src/symbols.c Sun Jan 01 15:18:52 2012 +0000 ＠＠ -446,7 +446,7 ＠＠ non-zero value. */ void map_obarray (Lisp_Object obarray, - int (*fn) (Lisp_Object, void *), void *arg) + int (*fn) (Lisp_Object, Lisp_Object, void *), void *arg) { REGISTER int i; ＠＠ -458,7 +458,7 ＠＠ while (1) { Lisp_Symbol *next; - if ((*fn) (tail, arg)) + if ((*fn) (XSYMBOL_NAME (tail), tail, arg)) return; next = symbol_next (XSYMBOL (tail)); if (!next) ＠＠ -469,7 +469,7 ＠＠ } static int -mapatoms_1 (Lisp_Object sym, void *arg) +mapatoms_1 (Lisp_Object UNUSED (key), Lisp_Object sym, void *arg) { call1 (*(Lisp_Object *)arg, sym); return 0; ＠＠ -506,7 +506,7 ＠＠ }; static int -apropos_mapper (Lisp_Object symbol, void *arg) +apropos_mapper (Lisp_Object UNUSED (key), Lisp_Object symbol, void *arg) { struct appropos_mapper_closure *closure = (struct appropos_mapper_closure *) arg; diff -r 49c36ed998b6 -r 2014ff433daf tests/ChangeLog --- a/tests/ChangeLog Fri Dec 30 16:39:14 2011 +0000 +++ b/tests/ChangeLog Sun Jan 01 15:18:52 2012 +0000 ＠＠ -1,3 +1,9 ＠＠ +2012-01-01 Aidan Kehoe <kehoea(a)parhasard.net&gt; + + * automated/completion-tests.el: New. + Test #'try-completion, #'all-completion and #'test-completion with + list, vector and hash-table COLLECTION arguments. + 2011-12-30 Aidan Kehoe <kehoea(a)parhasard.net&gt; * automated/hash-table-tests.el: diff -r 49c36ed998b6 -r 2014ff433daf tests/automated/completion-tests.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/automated/completion-tests.el Sun Jan 01 15:18:52 2012 +0000 ＠＠ -0,0 +1,307 ＠＠ +;; Copyright (C) 2012 Free Software Foundation, Inc. + +;; Author: Aidan Kehoe <kehoea(a)parhasard.net&gt; +;; Maintainers: Aidan Kehoe <kehoea(a)parhasard.net&gt; +;; Created: 2012 +;; Keywords: tests + +;; This file is part of XEmacs. + +;; XEmacs is free software: you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by the +;; Free Software Foundation, either version 3 of the License, or (at your +;; option) any later version. + +;; XEmacs is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +;; for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>;. + +;;; Synched up with: Not in FSF. + +;; This file tests pseudo-alist, obarray and hash-table arguments to +;; #'try-completion, #'all-completions and #'test-completion. It doesn't +;; test function arguments as COLLECTION. + +(require 'cl) + +(or (featurep 'xemacs) + (defmacro Assert (assertion &optional failing-case) + ;; This file can actually execute on GNU, though it exposes some bugs + ;; as of So 1 Jan 2012 14:41:32 GMT, described in + ;; http://mid.gmane.org/20224.27302.821804.284656＠parhasard.net . + `(condition-case err + (assert ,assertion nil + ,＠(if (memq (car-safe assertion) + '(eq eql equal equalp = string= < <= > >=)) + (list + (concat (if failing-case + (concat failing-case ", ") + "") + "%S should be `" + (symbol-name (car assertion)) + "' to %S but isn't") + (cadr assertion) + (caddr assertion)) + (list failing-case))) + (error + (message "error executing %S, %S, %S" ',assertion ,failing-case + err))))) + +(let* ((strings '("del-alist" "delay-mode-hooks" "delete" "delete*" + "delete-and-extract-region" "delete-annotation" + "delete-auto-save-file-if-necessary" "delete-backward-char" + "delete-blank-lines" "delete-char" + "delete-completion-window" "delete-console" + "delete-debug-class-to-check" "delete-device" + "delete-directory" "delete-duplicates" "delete-dups" + "delete-extent" "delete-extract-rectangle" "delete-field" + "delete-file" "delete-forward-p" "delete-frame" + "delete-horizontal-space" "delete-if" "delete-if-not" + "delete-indentation" "delete-itimer" "delete-matching-lines" + "delete-menu-item" "delete-non-matching-lines" + "delete-other-frames" "delete-other-windows" + "delete-overlay" "delete-primary-selection" "delete-process" + "delete-rectangle" "delete-region" "delete-selection-mode" + "delete-text-in-column" "delete-to-left-margin" + "delete-window" "delete-windows-on" "delq" "remote-compile" + "remote-path-file-handler-function" "remove" "remove*" + "remove-alist" "remove-char-table" "remove-database" + "remove-directory" "remove-duplicates" + "remove-face-property" "remove-from-invisibility-spec" + "remove-glyph-property" "remove-gutter-element" + "remove-hook" "remove-if" "remove-if-not" + "remove-local-hook" "remove-message" + "remove-progress-feedback" "remove-range-table" + "remove-specifier" + "remove-specifier-specs-matching-tag-set-cdrs" + "remove-text-properties" "sublis" + "submenu-generate-accelerator-spec" "subr-arity" + "subr-interactive" "subr-max-args" "subr-min-args" + "subr-name" "subregexp-context-p" "subrp" "subseq" "subsetp" + "subsidiary-coding-system" "subst" "subst-char-in-region" + "subst-char-in-string" "subst-if" "subst-if-not" + "substitute" "substitute-command-keys" "substitute-env-vars" + "substitute-if" "substitute-if-not" + "substitute-in-file-name" "substitute-key-definition" + "substring" "substring-no-properties" "subtract-time" + "subwindow-height" "subwindow-image-instance-p" + "subwindow-width" "subwindow-xid" "subwindowp")) + (list (let ((count -1)) + (mapcar #'(lambda (string) + (incf count) + (case (% count 3) + (0 string) + (1 (cons (make-symbol string) nil)) + (2 (cons string (make-symbol string))))) strings))) + (vector (loop + for string in strings + with vector = (make-vector 511 0) + with count = -1 + with symbol = nil + do + (setq symbol (intern string vector) + count (1+ count)) + (case (% count 3) + (0 (set symbol nil)) + (1 (fset symbol (symbol-function 'ignore))) + (2 (setf (symbol-plist symbol) 'hello))) + finally return vector)) + (init-hash-table + #'(lambda () + (loop + for string in strings + with hash-table = (make-hash-table :test #'equal) + with count = -1 + do + (incf count) + (case (% count 3) + (0 (setf (gethash (make-symbol string) hash-table) + 'hello)) + (1 (setf (gethash string hash-table) 'everyone)) + (2 (setf (gethash string hash-table) nil))) + finally return hash-table))) + (hash-table (funcall init-hash-table)) + ;; The following three could be circular lists, but that's not + ;; portable to GNU. + (list-list (make-list (length strings) list)) + (vector-list (make-list (length strings) vector)) + (hash-table-list (make-list (length strings) hash-table)) + scratch-hash-table cleared) + (macrolet + ((Assert-with-collections (assertion failing-case) + `(progn + (Assert ,(subst 'list 'collection assertion :test #'eq) + ,(replace-regexp-in-string "collection" "list" failing-case)) + (Assert ,(subst 'vector 'collection assertion :test #'eq) + ,(replace-regexp-in-string "collection" "vector" + failing-case)) + (Assert ,(subst 'hash-table 'collection assertion :test #'eq) + ,(replace-regexp-in-string "collection" "hash-table" + failing-case))))) + ;; #'try-completion. + (Assert (every #'try-completion strings list-list) + "check #'try-completion gives no false negatives, list") + (Assert (every #'try-completion strings vector-list) + "check #'try-completion gives no false negatives, vector") + (Assert (every #'try-completion strings hash-table-list) + "check #'try-completion gives no false negatives, hash-table") + (Assert-with-collections + (null (try-completion "iX/ZXLwiOU+a " collection)) + "check #'try-completion with no match, collection") + (Assert-with-collections + (eq t (try-completion "delq" collection)) + "check #'try-completion with an exact match, collection") + (Assert-with-collections + (equal "delq" + (let ((completion-ignore-case t)) + (try-completion "DElq" collection))) + "check #'try-completion with a case-insensitive match, collection") + (Assert-with-collections + (equal "del" (try-completion "de" collection)) + "check #'try-completion where it needs to complete, collection") + (Assert (equal "del" (try-completion "de" list #'consp)) + "check #'try-completion, list, it needs to complete, predicate") + (Assert + (equal "del" (try-completion "de" vector #'fboundp)) + "check #'try-completion, vector, it needs to complete, predicate") + (Assert + (equal "del" (try-completion "de" hash-table #'(lambda (key value) + (eq 'everyone value)))) + "check #'try-completion, hash-table, it needs to complete, predicate") + (Assert + ;; The actual result here is undefined, the important thing is we don't + ;; segfault. + (prog1 + t + (try-completion "de" + (setq cleared nil + scratch-hash-table (funcall init-hash-table)) + #'(lambda (key value) + (if cleared + (eq 'everyone value) + (clrhash scratch-hash-table) + (garbage-collect) + (setq cleared t))))) + "check #'try-completion doesn't crash when hash table modified") + + ;; #'all-completions + (Assert (every #'all-completions strings list-list) + "check #'all-completions gives no false negatives, list") + (Assert (every #'all-completions strings vector-list) + "check #'all-completions gives no false negatives, vector") + (Assert (every #'all-completions strings hash-table-list) + "check #'all-completions gives no false negatives, hash-table") + (Assert-with-collections + (null (all-completions "iX/ZXLwiOU+a " collection)) + "check #'all-completion with no match, collection") + (Assert-with-collections + (equal '("delq") (all-completions "delq" collection)) + "check #'all-completions with an exact match, collection") + (Assert-with-collections + (equal '("delq") (let ((completion-ignore-case t)) + (all-completions "dElQ" collection))) + "check #'all-completions with a case-insensitive match, collection") + (Assert + (equal + '("delay-mode-hooks" "delete-and-extract-region" + "delete-backward-char" "delete-completion-window" "delete-device" + "delete-dups" "delete-field" "delete-frame" "delete-if-not" + "delete-matching-lines" "delete-other-frames" + "delete-primary-selection" "delete-region" "delete-to-left-margin" + "delq") + (sort (all-completions "de" vector #'fboundp) #'string-lessp)) + "check #'all-completions where it need to complete, vector") + (Assert + (eql (length (all-completions "de" hash-table #'(lambda (key value) + (eq 'everyone value)))) + 15) + "check #'all-completions gives enough results with predicate, hash") + (Assert + (equal (sort + (all-completions + "de" list #'(lambda (object) (and (consp object) + (null (cdr object))))) + #'string-lessp) + (sort + (all-completions + "de" hash-table #'(lambda (key value) + (eq 'everyone value))) + #'string-lessp)) + "check #'all-completion with complex predicates behaves well") + (Assert-with-collections + (equal (sort* (all-completions "" collection) #'string-lessp) strings) + "check #'all-completions, empty string, with collection") + (Assert + ;; The actual result here is undefined, the important thing is we don't + ;; segfault. + (prog1 + t + (all-completions "de" + (setq cleared nil + scratch-hash-table (funcall init-hash-table)) + #'(lambda (key value) + (if cleared + (eq 'everyone value) + (clrhash scratch-hash-table) + (garbage-collect) + (setq cleared t))))) + "check #'all-completions doesn't crash when hash table modified") + ;; #'test-completion + (Assert (every #'test-completion strings list-list) + "check #'test-completion gives no false negatives, list") + (Assert (every #'test-completion strings vector-list) + "check #'test-completion gives no false negatives, vector") + (Assert (every #'test-completion strings hash-table-list) + "check #'test-completion gives no false negatives, hash-table") + (Assert-with-collections + (null (test-completion "iX/ZXLwiOU+a " collection)) + "check #'test-completion with no match, collection") + (Assert-with-collections + (eq t (test-completion "delq" collection)) + "check #'test-completion with an exact match, collection") + (Assert-with-collections + (null (let (completion-ignore-case) (test-completion "DElq" collection))) + "check #'test-completion fails correctly if case-sensitive, collection") + (Assert-with-collections + (eq t (let ((completion-ignore-case t)) + (test-completion "DElq" collection))) + "check #'test-completion with a case-insensitive match, collection") + (Assert-with-collections + (null (test-completion "de" collection)) + "check #'test-completion gives nil if no exact match, collection") + (Assert (null (test-completion "de" list #'consp)) + "check #'test-completion, list, no exact match, predicate") + (Assert (eq t (test-completion "delete-matching-lines" list #'consp)) + "check #'test-completion, list, exact match, predicate") + (Assert (null (test-completion "de" vector #'fboundp)) + "check #'test-completion, vector, no exact match, predicate") + (Assert (eq t (test-completion "delete-to-left-margin" vector #'fboundp)) + "check #'test-completion, vector, exact match, predicate") + (Assert + (null (test-completion "de" hash-table #'(lambda (key value) + (eq 'everyone value)))) + "check #'test-completion, hash-table, it needs to complete, predicate") + (Assert + (eq t (test-completion "delete-frame" hash-table + #'(lambda (key value) (eq 'everyone value)))) + "check #'test-completion, hash-table, exact match, predicate") + (Assert + ;; The actual result here is undefined, the important thing is we don't + ;; segfault. + (prog1 + t + (test-completion "delete-frame" + (setq cleared nil + scratch-hash-table (funcall init-hash-table)) + #'(lambda (key value) + (if cleared + (eq 'everyone value) + (clrhash scratch-hash-table) + (garbage-collect) + (setq cleared t))))) + "check #'all-completions doesn't crash when hash table modified"))) + -- ‘Iodine deficiency was endemic in parts of the UK until, through what has been described as “an unplanned and accidental public health triumph”, iodine was added to cattle feed to improve milk production in the 1930s.’ (EN Pearce, Lancet, June 2011) _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://lists.xemacs.org/mailman/listinfo/xemacs-patches