scratch/pkg 434b1d656c9: Completion experiments

[Gerd Moellmann]

branch: scratch/pkg
commit 434b1d656c91c658762102405b0dadd4fea16085
Author: Gerd Möllmann <gerd@gnu.org>
Commit: Gerd Möllmann <gerd@gnu.org>

    Completion experiments
    
    * src/pkg.c (pkg_symbol_completion_string, pkg_strip_package_prefix):
    New functions.
    (init_pkg_once): Add QCsymbol.
    * src/lisp.h: Declare new functions.
    * src/minibuf.c (Ftry_completion, Fall_completions, Ftest_completion):
    Use new functions.
    * lisp/simple.el (execute-extended-command): Use read-from-string
    instead of intern-soft to determine command function for the case it
    has a package prefix.
---
 lisp/simple.el |  6 +++-
 src/lisp.h     |  2 ++
 src/minibuf.c  | 96 ++++++++++++++++++++++++++++++++++------------------------
 src/pkg.c      | 33 ++++++++++++++++++++
 4 files changed, 96 insertions(+), 41 deletions(-)

diff --git a/lisp/simple.el b/lisp/simple.el
index 6f36a02ab65..d982427fcb2 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -2583,7 +2583,11 @@ customizing `read-extended-command-predicate'."
           (execute-extended-command--last-typed nil))
       (setq command-name (read-extended-command))
       (setq typed execute-extended-command--last-typed)))
-  (let* ((function (and (stringp command-name) (intern-soft command-name)))
+  (let* ((function (and (stringp command-name)
+                        ;; PKG-FIXME: what if some schmock has
+                        ;; a commands with ":" in it?
+                        (let ((symbol-packages t))
+                          (car (read-from-string command-name)))))
          (binding (and suggest-key-bindings
                       (not executing-kbd-macro)
                       (where-is-internal function overriding-local-map t)))
diff --git a/src/lisp.h b/src/lisp.h
index b4792e03f8c..7e62c4fab73 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -2312,6 +2312,8 @@ extern void pkg_map_symbols_c_fn (void (*fn) 
(Lisp_Object, Lisp_Object), Lisp_Ob
 extern Lisp_Object pkg_find_package (Lisp_Object name);
 extern Lisp_Object pkg_find_symbol (Lisp_Object name, Lisp_Object package, 
Lisp_Object *status);
 extern void pkg_in_emacs_package (void);
+extern Lisp_Object pkg_symbol_completion_string (Lisp_Object sym, Lisp_Object 
status);
+extern Lisp_Object pkg_strip_package_prefix (Lisp_Object string, Lisp_Object 
package);
 
 
 /* Return whether a value might be a valid docstring.
diff --git a/src/minibuf.c b/src/minibuf.c
index 9b0bcb0870a..938065d1601 100644
--- a/src/minibuf.c
+++ b/src/minibuf.c
@@ -1618,6 +1618,9 @@ or from one of the possible completions.  */)
 
   CHECK_STRING (string);
 
+  if (EQ (collection, Vobarray))
+    return Ftry_completion_in_all_packages (string, collection, predicate);
+
   if (FUNCTIONP (collection))
     return call3 (collection, string, predicate, Qnil);
 
@@ -1655,20 +1658,19 @@ or from one of the possible completions.  */)
 
       if (HASH_TABLE_P (collection))
        {
-         while (idx < HASH_TABLE_SIZE (XHASH_TABLE (collection))
-                && BASE_EQ (HASH_KEY (XHASH_TABLE (collection), idx),
-                            Qunbound))
-           idx++;
-         if (idx >= HASH_TABLE_SIZE (XHASH_TABLE (collection)))
+         const struct Lisp_Hash_Table *ht = XHASH_TABLE (collection);
+         while (idx < HASH_TABLE_SIZE (ht)
+                && BASE_EQ (HASH_KEY (ht, idx), Qunbound))
+           ++idx;
+         if (idx >= HASH_TABLE_SIZE (ht))
            break;
-         else if (symbol_table_p)
+         elt = eltstring = HASH_KEY (ht, idx);
+         if (symbol_table_p)
            {
-             elt = HASH_KEY (XHASH_TABLE (collection), idx);
-             eltstring = SYMBOL_NAME (elt);
-             ++idx;
+             const Lisp_Object status = HASH_VALUE (ht, idx);
+             eltstring = pkg_symbol_completion_string (elt, status);
            }
-         else
-           elt = eltstring = HASH_KEY (XHASH_TABLE (collection), idx++);
+         ++idx;
        }
       else
        {
@@ -1854,6 +1856,9 @@ with a space are ignored unless STRING itself starts with 
a space.  */)
   Lisp_Object tail, elt, eltstring;
   Lisp_Object allmatches;
 
+  if (EQ (collection, Vobarray))
+    return Fall_completions_in_all_packages (string, collection, predicate, 
hide_spaces);
+
   /* Fake obarray?  */
   if (VECTORP (collection))
     collection = Faref (collection, make_fixnum (0));
@@ -1903,19 +1908,19 @@ with a space are ignored unless STRING itself starts 
with a space.  */)
        }
       else /* if (type == 3) */
        {
-         while (idx < HASH_TABLE_SIZE (XHASH_TABLE (collection))
-                && BASE_EQ (HASH_KEY (XHASH_TABLE (collection), idx),
-                            Qunbound))
-           idx++;
-         if (idx >= HASH_TABLE_SIZE (XHASH_TABLE (collection)))
+         const struct Lisp_Hash_Table *ht = XHASH_TABLE (collection);
+         while (idx < HASH_TABLE_SIZE (ht)
+                && BASE_EQ (HASH_KEY (ht, idx), Qunbound))
+           ++idx;
+         if (idx >= HASH_TABLE_SIZE (ht))
            break;
-         else if (symbol_table_p)
+         elt = eltstring = HASH_KEY (ht, idx);
+         if (symbol_table_p)
            {
-             elt = HASH_KEY (XHASH_TABLE (collection), idx++);
-             eltstring = SYMBOL_NAME (elt);
+             const Lisp_Object status = HASH_VALUE (ht, idx);
+             eltstring = pkg_symbol_completion_string (elt, status);
            }
-         else
-           elt = eltstring = HASH_KEY (XHASH_TABLE (collection), idx++);
+         ++idx;
        }
 
       /* Is this element a possible completion?  */
@@ -2060,6 +2065,9 @@ the values STRING, PREDICATE and `lambda'.  */)
 
   CHECK_STRING (string);
 
+  if (EQ (collection, Vobarray))
+    return Ftest_completion_in_all_packages (string, collection, predicate);
+
   /* If a vector (obarray), use the package stored in slot 0.  */
   if (VECTORP (collection))
     collection = Faref (collection, make_fixnum (0));
@@ -2068,7 +2076,11 @@ the values STRING, PREDICATE and `lambda'.  */)
      normal hash-table.  */
   const bool symbol_table_p = PACKAGEP (collection);
   if (symbol_table_p)
-    collection = PACKAGE_SYMBOLS (collection);
+    {
+      const Lisp_Object package = collection;
+      collection = PACKAGE_SYMBOLS (package);
+      string = pkg_strip_package_prefix (string, package);
+    }
 
   if (NILP (collection) || (CONSP (collection) && !FUNCTIONP (collection)))
     {
@@ -2078,28 +2090,32 @@ the values STRING, PREDICATE and `lambda'.  */)
     }
   else if (HASH_TABLE_P (collection))
     {
+      /* STRING is some input from the minibuffer, without intersting
+        properties.  It may be, for example, "emacs:cd".
+       */
       struct Lisp_Hash_Table *h = XHASH_TABLE (collection);
       i = hash_lookup (h, string, NULL);
       if (i >= 0)
-        {
-          tem = HASH_KEY (h, i);
-          goto found_matching_key;
-        }
+       tem = HASH_KEY (h, i);
       else
-       for (i = 0; i < HASH_TABLE_SIZE (h); ++i)
-          {
-            tem = HASH_KEY (h, i);
-            if (BASE_EQ (tem, Qunbound)) continue;
-            Lisp_Object strkey = (SYMBOLP (tem) ? Fsymbol_name (tem) : tem);
-            if (!STRINGP (strkey)) continue;
-            if (BASE_EQ (Fcompare_strings (string, Qnil, Qnil,
-                                          strkey, Qnil, Qnil,
-                                          completion_ignore_case ? Qt : Qnil),
-                    Qt))
-              goto found_matching_key;
-          }
-      return Qnil;
-    found_matching_key: ;
+       {
+         for (i = 0; i < HASH_TABLE_SIZE (h); ++i)
+           {
+             tem = HASH_KEY (h, i);
+             if (BASE_EQ (tem, Qunbound))
+               continue;
+             Lisp_Object strkey = (SYMBOLP (tem) ? Fsymbol_name (tem) : tem);
+             if (!STRINGP (strkey))
+               continue;
+             if (BASE_EQ (Fcompare_strings (string, Qnil, Qnil,
+                                            strkey, Qnil, Qnil,
+                                            completion_ignore_case ? Qt : 
Qnil),
+                          Qt))
+               break;
+           }
+         if (i >= HASH_TABLE_SIZE (h))
+           return Qnil;
+       }
     }
   else
     return call3 (collection, string, predicate, Qlambda);
diff --git a/src/pkg.c b/src/pkg.c
index c00a8a4d032..4ad8125775a 100644
--- a/src/pkg.c
+++ b/src/pkg.c
@@ -1012,6 +1012,38 @@ pkg_in_emacs_package (void)
   specbind (Qearmuffs_package, Vemacs_package);
 }
 
+Lisp_Object
+pkg_symbol_completion_string (Lisp_Object sym, Lisp_Object status)
+{
+  const Lisp_Object package_name = PACKAGE_NAMEX (SYMBOL_PACKAGE (sym));
+  const char *sep = EQ (status, QCinternal) ? "::" : ":";
+  return CALLN (Fconcat, package_name, build_string (sep), SYMBOL_NAME (sym));
+}
+
+Lisp_Object
+pkg_strip_package_prefix (Lisp_Object string, Lisp_Object package)
+{
+  const Lisp_Object package_name = PACKAGE_NAMEX (package);
+  if (SCHARS (string) <= SCHARS (package_name))
+    return string;
+
+  if (!BASE_EQ (Qt, Fcompare_strings (package_name, make_fixnum (0),
+                                     make_fixnum (SCHARS (package_name)),
+                                     string, make_fixnum (0),
+                                     make_fixnum (SCHARS (package_name)),
+                                     completion_ignore_case ? Qt : Qnil)))
+    return string;
+
+  ptrdiff_t start = SCHARS (package_name);
+  if (SREF (string, start) != ':')
+    return string;
+
+  ++start;
+  if (start < SCHARS (string) & SREF (string, start) == ':')
+    ++start;
+  return Fsubstring (string, make_fixnum (start), Qnil);
+}
+
 
 /***********************************************************************
                            Initialization
@@ -1028,6 +1060,7 @@ init_pkg_once (void)
   DEFSYM (QCinternal, ":internal");
   DEFSYM (QCnicknames, ":nicknames");
   DEFSYM (QCuse, ":use");
+  DEFSYM (QCsymbol, ":symbol");
 
   DEFSYM (Qearmuffs_package, "*package*");
   DEFSYM (Qemacs_package, "emacs-package");