--- /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@parhasard.net>
+;; Maintainers: Aidan Kehoe <kehoea@parhasard.net>
+;; 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")))
+