Mercurial > hg > xemacs-beta

comparison tests/automated/completion-tests.el @ 5634:2014ff433daf

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Support hash COLLECTIONs, #'{all,try}-completion{s,}; add #'test-completion src/ChangeLog addition: 2012-01-01 Aidan Kehoe <kehoea@parhasard.net> 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@parhasard.net> * automated/completion-tests.el: New. Test #'try-completion, #'all-completion and #'test-completion with list, vector and hash-table COLLECTION arguments.
author Aidan Kehoe <kehoea@parhasard.net>
date Sun, 01 Jan 2012 15:18:52 +0000
parents
children
comparison
equal deleted inserted replaced
5633:49c36ed998b6 5634:2014ff433daf
1 ;; Copyright (C) 2012 Free Software Foundation, Inc.
2
3 ;; Author: Aidan Kehoe <kehoea@parhasard.net>
4 ;; Maintainers: Aidan Kehoe <kehoea@parhasard.net>
5 ;; Created: 2012
6 ;; Keywords: tests
7
8 ;; This file is part of XEmacs.
9
10 ;; XEmacs is free software: you can redistribute it and/or modify it
11 ;; under the terms of the GNU General Public License as published by the
12 ;; Free Software Foundation, either version 3 of the License, or (at your
13 ;; option) any later version.
14
15 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT
16 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
17 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 ;; for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>.
22
23 ;;; Synched up with: Not in FSF.
24
25 ;; This file tests pseudo-alist, obarray and hash-table arguments to
26 ;; #'try-completion, #'all-completions and #'test-completion. It doesn't
27 ;; test function arguments as COLLECTION.
28
29 (require 'cl)
30
31 (or (featurep 'xemacs)
32 (defmacro Assert (assertion &optional failing-case)
33 ;; This file can actually execute on GNU, though it exposes some bugs
34 ;; as of So 1 Jan 2012 14:41:32 GMT, described in
35 ;; http://mid.gmane.org/20224.27302.821804.284656@parhasard.net .
36 `(condition-case err
37 (assert ,assertion nil
38 ,@(if (memq (car-safe assertion)
39 '(eq eql equal equalp = string= < <= > >=))
40 (list
41 (concat (if failing-case
42 (concat failing-case ", ")
43 "")
44 "%S should be `"
45 (symbol-name (car assertion))
46 "' to %S but isn't")
47 (cadr assertion)
48 (caddr assertion))
49 (list failing-case)))
50 (error
51 (message "error executing %S, %S, %S" ',assertion ,failing-case
52 err)))))
53
54 (let* ((strings '("del-alist" "delay-mode-hooks" "delete" "delete*"
55 "delete-and-extract-region" "delete-annotation"
56 "delete-auto-save-file-if-necessary" "delete-backward-char"
57 "delete-blank-lines" "delete-char"
58 "delete-completion-window" "delete-console"
59 "delete-debug-class-to-check" "delete-device"
60 "delete-directory" "delete-duplicates" "delete-dups"
61 "delete-extent" "delete-extract-rectangle" "delete-field"
62 "delete-file" "delete-forward-p" "delete-frame"
63 "delete-horizontal-space" "delete-if" "delete-if-not"
64 "delete-indentation" "delete-itimer" "delete-matching-lines"
65 "delete-menu-item" "delete-non-matching-lines"
66 "delete-other-frames" "delete-other-windows"
67 "delete-overlay" "delete-primary-selection" "delete-process"
68 "delete-rectangle" "delete-region" "delete-selection-mode"
69 "delete-text-in-column" "delete-to-left-margin"
70 "delete-window" "delete-windows-on" "delq" "remote-compile"
71 "remote-path-file-handler-function" "remove" "remove*"
72 "remove-alist" "remove-char-table" "remove-database"
73 "remove-directory" "remove-duplicates"
74 "remove-face-property" "remove-from-invisibility-spec"
75 "remove-glyph-property" "remove-gutter-element"
76 "remove-hook" "remove-if" "remove-if-not"
77 "remove-local-hook" "remove-message"
78 "remove-progress-feedback" "remove-range-table"
79 "remove-specifier"
80 "remove-specifier-specs-matching-tag-set-cdrs"
81 "remove-text-properties" "sublis"
82 "submenu-generate-accelerator-spec" "subr-arity"
83 "subr-interactive" "subr-max-args" "subr-min-args"
84 "subr-name" "subregexp-context-p" "subrp" "subseq" "subsetp"
85 "subsidiary-coding-system" "subst" "subst-char-in-region"
86 "subst-char-in-string" "subst-if" "subst-if-not"
87 "substitute" "substitute-command-keys" "substitute-env-vars"
88 "substitute-if" "substitute-if-not"
89 "substitute-in-file-name" "substitute-key-definition"
90 "substring" "substring-no-properties" "subtract-time"
91 "subwindow-height" "subwindow-image-instance-p"
92 "subwindow-width" "subwindow-xid" "subwindowp"))
93 (list (let ((count -1))
94 (mapcar #'(lambda (string)
95 (incf count)
96 (case (% count 3)
97 (0 string)
98 (1 (cons (make-symbol string) nil))
99 (2 (cons string (make-symbol string))))) strings)))
100 (vector (loop
101 for string in strings
102 with vector = (make-vector 511 0)
103 with count = -1
104 with symbol = nil
105 do
106 (setq symbol (intern string vector)
107 count (1+ count))
108 (case (% count 3)
109 (0 (set symbol nil))
110 (1 (fset symbol (symbol-function 'ignore)))
111 (2 (setf (symbol-plist symbol) 'hello)))
112 finally return vector))
113 (init-hash-table
114 #'(lambda ()
115 (loop
116 for string in strings
117 with hash-table = (make-hash-table :test #'equal)
118 with count = -1
119 do
120 (incf count)
121 (case (% count 3)
122 (0 (setf (gethash (make-symbol string) hash-table)
123 'hello))
124 (1 (setf (gethash string hash-table) 'everyone))
125 (2 (setf (gethash string hash-table) nil)))
126 finally return hash-table)))
127 (hash-table (funcall init-hash-table))
128 ;; The following three could be circular lists, but that's not
129 ;; portable to GNU.
130 (list-list (make-list (length strings) list))
131 (vector-list (make-list (length strings) vector))
132 (hash-table-list (make-list (length strings) hash-table))
133 scratch-hash-table cleared)
134 (macrolet
135 ((Assert-with-collections (assertion failing-case)
136 `(progn
137 (Assert ,(subst 'list 'collection assertion :test #'eq)
138 ,(replace-regexp-in-string "collection" "list" failing-case))
139 (Assert ,(subst 'vector 'collection assertion :test #'eq)
140 ,(replace-regexp-in-string "collection" "vector"
141 failing-case))
142 (Assert ,(subst 'hash-table 'collection assertion :test #'eq)
143 ,(replace-regexp-in-string "collection" "hash-table"
144 failing-case)))))
145 ;; #'try-completion.
146 (Assert (every #'try-completion strings list-list)
147 "check #'try-completion gives no false negatives, list")
148 (Assert (every #'try-completion strings vector-list)
149 "check #'try-completion gives no false negatives, vector")
150 (Assert (every #'try-completion strings hash-table-list)
151 "check #'try-completion gives no false negatives, hash-table")
152 (Assert-with-collections
153 (null (try-completion "iX/ZXLwiOU+a " collection))
154 "check #'try-completion with no match, collection")
155 (Assert-with-collections
156 (eq t (try-completion "delq" collection))
157 "check #'try-completion with an exact match, collection")
158 (Assert-with-collections
159 (equal "delq"
160 (let ((completion-ignore-case t))
161 (try-completion "DElq" collection)))
162 "check #'try-completion with a case-insensitive match, collection")
163 (Assert-with-collections
164 (equal "del" (try-completion "de" collection))
165 "check #'try-completion where it needs to complete, collection")
166 (Assert (equal "del" (try-completion "de" list #'consp))
167 "check #'try-completion, list, it needs to complete, predicate")
168 (Assert
169 (equal "del" (try-completion "de" vector #'fboundp))
170 "check #'try-completion, vector, it needs to complete, predicate")
171 (Assert
172 (equal "del" (try-completion "de" hash-table #'(lambda (key value)
173 (eq 'everyone value))))
174 "check #'try-completion, hash-table, it needs to complete, predicate")
175 (Assert
176 ;; The actual result here is undefined, the important thing is we don't
177 ;; segfault.
178 (prog1
179 t
180 (try-completion "de"
181 (setq cleared nil
182 scratch-hash-table (funcall init-hash-table))
183 #'(lambda (key value)
184 (if cleared
185 (eq 'everyone value)
186 (clrhash scratch-hash-table)
187 (garbage-collect)
188 (setq cleared t)))))
189 "check #'try-completion doesn't crash when hash table modified")
190
191 ;; #'all-completions
192 (Assert (every #'all-completions strings list-list)
193 "check #'all-completions gives no false negatives, list")
194 (Assert (every #'all-completions strings vector-list)
195 "check #'all-completions gives no false negatives, vector")
196 (Assert (every #'all-completions strings hash-table-list)
197 "check #'all-completions gives no false negatives, hash-table")
198 (Assert-with-collections
199 (null (all-completions "iX/ZXLwiOU+a " collection))
200 "check #'all-completion with no match, collection")
201 (Assert-with-collections
202 (equal '("delq") (all-completions "delq" collection))
203 "check #'all-completions with an exact match, collection")
204 (Assert-with-collections
205 (equal '("delq") (let ((completion-ignore-case t))
206 (all-completions "dElQ" collection)))
207 "check #'all-completions with a case-insensitive match, collection")
208 (Assert
209 (equal
210 '("delay-mode-hooks" "delete-and-extract-region"
211 "delete-backward-char" "delete-completion-window" "delete-device"
212 "delete-dups" "delete-field" "delete-frame" "delete-if-not"
213 "delete-matching-lines" "delete-other-frames"
214 "delete-primary-selection" "delete-region" "delete-to-left-margin"
215 "delq")
216 (sort (all-completions "de" vector #'fboundp) #'string-lessp))
217 "check #'all-completions where it need to complete, vector")
218 (Assert
219 (eql (length (all-completions "de" hash-table #'(lambda (key value)
220 (eq 'everyone value))))
221 15)
222 "check #'all-completions gives enough results with predicate, hash")
223 (Assert
224 (equal (sort
225 (all-completions
226 "de" list #'(lambda (object) (and (consp object)
227 (null (cdr object)))))
228 #'string-lessp)
229 (sort
230 (all-completions
231 "de" hash-table #'(lambda (key value)
232 (eq 'everyone value)))
233 #'string-lessp))
234 "check #'all-completion with complex predicates behaves well")
235 (Assert-with-collections
236 (equal (sort* (all-completions "" collection) #'string-lessp) strings)
237 "check #'all-completions, empty string, with collection")
238 (Assert
239 ;; The actual result here is undefined, the important thing is we don't
240 ;; segfault.
241 (prog1
242 t
243 (all-completions "de"
244 (setq cleared nil
245 scratch-hash-table (funcall init-hash-table))
246 #'(lambda (key value)
247 (if cleared
248 (eq 'everyone value)
249 (clrhash scratch-hash-table)
250 (garbage-collect)
251 (setq cleared t)))))
252 "check #'all-completions doesn't crash when hash table modified")
253 ;; #'test-completion
254 (Assert (every #'test-completion strings list-list)
255 "check #'test-completion gives no false negatives, list")
256 (Assert (every #'test-completion strings vector-list)
257 "check #'test-completion gives no false negatives, vector")
258 (Assert (every #'test-completion strings hash-table-list)
259 "check #'test-completion gives no false negatives, hash-table")
260 (Assert-with-collections
261 (null (test-completion "iX/ZXLwiOU+a " collection))
262 "check #'test-completion with no match, collection")
263 (Assert-with-collections
264 (eq t (test-completion "delq" collection))
265 "check #'test-completion with an exact match, collection")
266 (Assert-with-collections
267 (null (let (completion-ignore-case) (test-completion "DElq" collection)))
268 "check #'test-completion fails correctly if case-sensitive, collection")
269 (Assert-with-collections
270 (eq t (let ((completion-ignore-case t))
271 (test-completion "DElq" collection)))
272 "check #'test-completion with a case-insensitive match, collection")
273 (Assert-with-collections
274 (null (test-completion "de" collection))
275 "check #'test-completion gives nil if no exact match, collection")
276 (Assert (null (test-completion "de" list #'consp))
277 "check #'test-completion, list, no exact match, predicate")
278 (Assert (eq t (test-completion "delete-matching-lines" list #'consp))
279 "check #'test-completion, list, exact match, predicate")
280 (Assert (null (test-completion "de" vector #'fboundp))
281 "check #'test-completion, vector, no exact match, predicate")
282 (Assert (eq t (test-completion "delete-to-left-margin" vector #'fboundp))
283 "check #'test-completion, vector, exact match, predicate")
284 (Assert
285 (null (test-completion "de" hash-table #'(lambda (key value)
286 (eq 'everyone value))))
287 "check #'test-completion, hash-table, it needs to complete, predicate")
288 (Assert
289 (eq t (test-completion "delete-frame" hash-table
290 #'(lambda (key value) (eq 'everyone value))))
291 "check #'test-completion, hash-table, exact match, predicate")
292 (Assert
293 ;; The actual result here is undefined, the important thing is we don't
294 ;; segfault.
295 (prog1
296 t
297 (test-completion "delete-frame"
298 (setq cleared nil
299 scratch-hash-table (funcall init-hash-table))
300 #'(lambda (key value)
301 (if cleared
302 (eq 'everyone value)
303 (clrhash scratch-hash-table)
304 (garbage-collect)
305 (setq cleared t)))))
306 "check #'all-completions doesn't crash when hash table modified")))
307