pkg 3e29407122 10/76: And more fixes

[Gerd Moellmann]

branch: pkg
commit 3e29407122da36e942c9a1c44e701f8aacae7c72
Author: Gerd Möllmann <gerd@gnu.org>
Commit: Gerd Möllmann <gerd@gnu.org>

    And more fixes
---
 src/lisp.h  |   8 ++-
 src/lread.c | 222 +++---------------------------------------------------------
 src/pkg.c   |  58 +++++++++++++---
 3 files changed, 65 insertions(+), 223 deletions(-)

diff --git a/src/lisp.h b/src/lisp.h
index c268a35140..68a7233abd 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -2263,9 +2263,13 @@ extern Lisp_Object pkg_unqualified_symbol (Lisp_Object 
name);
 extern bool pkg_keywordp (Lisp_Object obj);
 extern Lisp_Object pkg_add_keyword (Lisp_Object sym);
 extern Lisp_Object pkg_add_symbol (Lisp_Object symbol, Lisp_Object package);
-extern bool pkg_intern_name (Lisp_Object name, Lisp_Object *tem);
-extern void pkg_early_intern_symbol (Lisp_Object symbol);
+extern Lisp_Object pkg_emacs_intern (Lisp_Object name, Lisp_Object package);
+extern Lisp_Object pkg_emacs_intern_soft (Lisp_Object name, Lisp_Object 
package);
+extern Lisp_Object pkg_emacs_unintern (Lisp_Object name, Lisp_Object package);
 extern bool pkg_intern_name_c_string (const char *p, ptrdiff_t len, 
Lisp_Object *symbol);
+extern void pkg_early_intern_symbol (Lisp_Object symbol);
+
+extern bool package_system_ready;
 
 
 /* Return whether a value might be a valid docstring.
diff --git a/src/lread.c b/src/lread.c
index 5ffabe2441..4260850399 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -155,11 +155,6 @@ static void readevalloop (Lisp_Object, struct infile *, 
Lisp_Object, bool,
 
 static void build_load_history (Lisp_Object, bool);
 
-static Lisp_Object oblookup_considering_shorthand (Lisp_Object, const char *,
-                                                  ptrdiff_t, ptrdiff_t,
-                                                  char **, ptrdiff_t *,
-                                                  ptrdiff_t *);
-
 
 /* Functions that read one byte from the current source READCHARFUN
    or unreads one byte.  If the integer argument C is -1, it returns
@@ -4227,8 +4222,10 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
                if (c < 0)
                  end_of_file_error ();
                if (c == '|')
-                 c = READCHAR;
-               break;
+                 {
+                   c = READCHAR;
+                   break;
+                 }
              }
            else
              {
@@ -4296,7 +4293,7 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
          symbol_start = read_buffer;
        const ptrdiff_t symbol_nbytes = p - symbol_start;
 
-       /* This could be number after all.  But not if empty, and not
+       /* This could be a number after all.  But not if empty, and not
           if in |...|, and not if any quoted characters were found,
           or a package prefix was found, or we have #:xyz.  */
        if (!any_quoted
@@ -4821,48 +4818,15 @@ define_symbol (Lisp_Object sym, char const *str)
       intern_sym (sym, initial_obarray, bucket);
     }
 }
-
+
 DEFUN ("intern", Fintern, Sintern, 1, 2, 0,
        doc: /* Return the canonical symbol whose name is STRING.
 If there is none, one is created by this function and returned.
 A second optional argument specifies the obarray to use;
 it defaults to the value of `obarray'.  */)
-  (Lisp_Object string, Lisp_Object obarray)
+  (Lisp_Object string, Lisp_Object package)
 {
-  Lisp_Object tem;
-
-  obarray = check_obarray (NILP (obarray) ? Vobarray : obarray);
-  CHECK_STRING (string);
-
-  /* If the package system finds it, return that.  */
-  if (pkg_intern_name (string, &tem))
-    {
-      eassert (!NILP (SYMBOL_PACKAGE (tem)));
-      return tem;
-    }
-
-  char* longhand = NULL;
-  ptrdiff_t longhand_chars = 0;
-  ptrdiff_t longhand_bytes = 0;
-  tem = oblookup_considering_shorthand (obarray, SSDATA (string),
-                                       SCHARS (string), SBYTES (string),
-                                       &longhand, &longhand_chars,
-                                       &longhand_bytes);
-
-  if (!SYMBOLP (tem))
-    {
-      if (longhand)
-       {
-         tem = intern_driver (make_specified_string (longhand, longhand_chars,
-                                                     longhand_bytes, true),
-                              obarray, tem);
-         xfree (longhand);
-       }
-      else
-       tem = intern_driver (NILP (Vpurify_flag) ? string : Fpurecopy (string),
-                            obarray, tem);
-    }
-  return tem;
+  return pkg_emacs_intern (string, package);
 }
 
 DEFUN ("intern-soft", Fintern_soft, Sintern_soft, 1, 2, 0,
@@ -4873,40 +4837,9 @@ A second optional argument specifies the obarray to use;
 it defaults to the value of `obarray'.  */)
   (Lisp_Object name, Lisp_Object obarray)
 {
-  register Lisp_Object tem, string;
-
-  /* PKG-FIXME: Find it in the package system.  */
-
-  if (NILP (obarray)) obarray = Vobarray;
-  obarray = check_obarray (obarray);
-
-  if (!SYMBOLP (name))
-    {
-      char *longhand = NULL;
-      ptrdiff_t longhand_chars = 0;
-      ptrdiff_t longhand_bytes = 0;
-
-      CHECK_STRING (name);
-      string = name;
-      tem = oblookup_considering_shorthand (obarray, SSDATA (string),
-                                           SCHARS (string), SBYTES (string),
-                                           &longhand, &longhand_chars,
-                                           &longhand_bytes);
-      if (longhand)
-       xfree (longhand);
-      return FIXNUMP (tem) ? Qnil : tem;
-    }
-  else
-    {
-      /* If already a symbol, we don't do shorthand-longhand translation,
-        as promised in the docstring.  */
-      string = SYMBOL_NAME (name);
-      tem
-       = oblookup (obarray, SSDATA (string), SCHARS (string), SBYTES (string));
-      return EQ (name, tem) ? name : Qnil;
-    }
+  return pkg_emacs_intern_soft (name, obarray);
 }
-
+
 DEFUN ("unintern", Funintern, Sunintern, 1, 2, 0,
        doc: /* Delete the symbol named NAME, if any, from OBARRAY.
 The value is t if a symbol was found and deleted, nil otherwise.
@@ -4916,77 +4849,7 @@ OBARRAY, if nil, defaults to the value of the variable 
`obarray'.
 usage: (unintern NAME OBARRAY)  */)
   (Lisp_Object name, Lisp_Object obarray)
 {
-  register Lisp_Object tem;
-  Lisp_Object string;
-  size_t hash;
-
-  if (NILP (obarray)) obarray = Vobarray;
-  obarray = check_obarray (obarray);
-
-  if (SYMBOLP (name))
-    string = SYMBOL_NAME (name);
-  else
-    {
-      CHECK_STRING (name);
-      string = name;
-    }
-
-  char *longhand = NULL;
-  ptrdiff_t longhand_chars = 0;
-  ptrdiff_t longhand_bytes = 0;
-  tem = oblookup_considering_shorthand (obarray, SSDATA (string),
-                                       SCHARS (string), SBYTES (string),
-                                       &longhand, &longhand_chars,
-                                       &longhand_bytes);
-  if (longhand)
-    xfree(longhand);
-
-  if (FIXNUMP (tem))
-    return Qnil;
-  /* If arg was a symbol, don't delete anything but that symbol itself.  */
-  if (SYMBOLP (name) && !EQ (name, tem))
-    return Qnil;
-
-  /* There are plenty of other symbols which will screw up the Emacs
-     session if we unintern them, as well as even more ways to use
-     `setq' or `fset' or whatnot to make the Emacs session
-     unusable.  Let's not go down this silly road.  --Stef  */
-  /* if (NILP (tem) || EQ (tem, Qt))
-       error ("Attempt to unintern t or nil"); */
-
-  XSYMBOL (tem)->u.s.interned = SYMBOL_UNINTERNED;
-
-  hash = oblookup_last_bucket_number;
-
-  if (EQ (AREF (obarray, hash), tem))
-    {
-      if (XSYMBOL (tem)->u.s.next)
-       {
-         Lisp_Object sym;
-         XSETSYMBOL (sym, XSYMBOL (tem)->u.s.next);
-         ASET (obarray, hash, sym);
-       }
-      else
-       ASET (obarray, hash, make_fixnum (0));
-    }
-  else
-    {
-      Lisp_Object tail, following;
-
-      for (tail = AREF (obarray, hash);
-          XSYMBOL (tail)->u.s.next;
-          tail = following)
-       {
-         XSETSYMBOL (following, XSYMBOL (tail)->u.s.next);
-         if (EQ (following, tem))
-           {
-             set_symbol_next (tail, XSYMBOL (following)->u.s.next);
-             break;
-           }
-       }
-    }
-
-  return Qt;
+  return pkg_emacs_unintern (name, obarray);
 }
 
 /* Return the symbol in OBARRAY whose names matches the string
@@ -5030,69 +4893,6 @@ oblookup (Lisp_Object obarray, register const char *ptr, 
ptrdiff_t size, ptrdiff
   return tem;
 }
 
-/* Like 'oblookup', but considers 'Vread_symbol_shorthands',
-   potentially recognizing that IN is shorthand for some other
-   longhand name, which is then placed in OUT.  In that case,
-   memory is malloc'ed for OUT (which the caller must free) while
-   SIZE_OUT and SIZE_BYTE_OUT respectively hold the character and byte
-   sizes of the transformed symbol name.  If IN is not recognized
-   shorthand for any other symbol, OUT is set to point to NULL and
-   'oblookup' is called.  */
-
-Lisp_Object
-oblookup_considering_shorthand (Lisp_Object obarray, const char *in,
-                               ptrdiff_t size, ptrdiff_t size_byte, char **out,
-                               ptrdiff_t *size_out, ptrdiff_t *size_byte_out)
-{
-  Lisp_Object tail = Vread_symbol_shorthands;
-
-  /* First, assume no transformation will take place.  */
-  *out = NULL;
-  /* Then, iterate each pair in Vread_symbol_shorthands.  */
-  FOR_EACH_TAIL_SAFE (tail)
-    {
-      Lisp_Object pair = XCAR (tail);
-      /* Be lenient to 'read-symbol-shorthands': if some element isn't a
-        cons, or some member of that cons isn't a string, just skip
-        to the next element.  */
-      if (!CONSP (pair))
-       continue;
-      Lisp_Object sh_prefix = XCAR (pair);
-      Lisp_Object lh_prefix = XCDR (pair);
-      if (!STRINGP (sh_prefix) || !STRINGP (lh_prefix))
-       continue;
-      ptrdiff_t sh_prefix_size = SBYTES (sh_prefix);
-
-      /* Compare the prefix of the transformation pair to the symbol
-        name.  If a match occurs, do the renaming and exit the loop.
-        In other words, only one such transformation may take place.
-        Calculate the amount of memory to allocate for the longhand
-        version of the symbol name with xrealloc.  This isn't
-        strictly needed, but it could later be used as a way for
-        multiple transformations on a single symbol name.  */
-      if (sh_prefix_size <= size_byte
-         && memcmp (SSDATA (sh_prefix), in, sh_prefix_size) == 0)
-       {
-         ptrdiff_t lh_prefix_size = SBYTES (lh_prefix);
-         ptrdiff_t suffix_size = size_byte - sh_prefix_size;
-         *out = xrealloc (*out, lh_prefix_size + suffix_size);
-         memcpy (*out, SSDATA(lh_prefix), lh_prefix_size);
-         memcpy (*out + lh_prefix_size, in + sh_prefix_size, suffix_size);
-         *size_out = SCHARS (lh_prefix) - SCHARS (sh_prefix) + size;
-         *size_byte_out = lh_prefix_size + suffix_size;
-         break;
-       }
-    }
-  /* Now, as promised, call oblookup with the "final" symbol name to
-     lookup.  That function remains oblivious to whether a
-     transformation happened here or not, but the caller of this
-     function can tell by inspecting the OUT parameter.  */
-  if (*out)
-    return oblookup (obarray, *out, *size_out, *size_byte_out);
-  else
-    return oblookup (obarray, in, size, size_byte);
-}
-
 
 void
 map_obarray (Lisp_Object obarray, void (*fn) (Lisp_Object, Lisp_Object), 
Lisp_Object arg)
diff --git a/src/pkg.c b/src/pkg.c
index f099dcc75b..03533dceac 100644
--- a/src/pkg.c
+++ b/src/pkg.c
@@ -30,7 +30,7 @@ along with GNU Emacs.  If not, see 
<https://www.gnu.org/licenses/>.  */
 #include "lisp.h"
 #include "character.h"
 
-static bool package_system_ready = false;
+bool package_system_ready = false;
 
 /* Lists of keywords and other symbols that are defined before
    packages are ready to use.  These are fixed up and the lists set
@@ -545,15 +545,6 @@ pkg_intern_symbol (const Lisp_Object symbol_or_name, 
Lisp_Object package)
   return pkg_add_symbol (Fmake_symbol (name), package);
 }
 
-bool
-pkg_intern_name (Lisp_Object name, Lisp_Object *tem)
-{
-  if (!package_system_ready)
-    return false;
-  *tem = pkg_intern_symbol (name, Vearmuffs_package);
-  return true;
-}
-
 bool
 pkg_intern_name_c_string (const char *p, ptrdiff_t len, Lisp_Object *symbol)
 {
@@ -592,6 +583,53 @@ pkg_unintern_symbol (Lisp_Object symbol, Lisp_Object 
package)
 }
 
 
+/***********************************************************************
+                       Old Emacs intern stuff
+ ***********************************************************************/
+
+/* Implements Emacs' old Fintern function.  */
+
+Lisp_Object
+pkg_emacs_intern (Lisp_Object name, Lisp_Object package)
+{
+  eassert (package_system_ready);
+  CHECK_STRING (name);
+  return pkg_intern_symbol (name, Vearmuffs_package);
+}
+
+/* Implements Emacs' old Fintern_soft function.  */
+
+Lisp_Object
+pkg_emacs_intern_soft (Lisp_Object symbol, Lisp_Object package)
+{
+  eassert (package_system_ready);
+
+  const Lisp_Object name = SYMBOLP (symbol) ? SYMBOL_NAME (symbol) : symbol;
+  CHECK_STRING (name);
+  package = package_or_default (package);
+
+  Lisp_Object found = lookup_symbol (name, package);
+  if (!EQ (found, Qunbound))
+    {
+      /* We should never find an uninterned symbol in a package.  */
+      eassert (!NILP (SYMBOL_PACKAGE (found)));
+      return found;
+    }
+
+  return Qnil;
+}
+
+/* Implements Emacs' old Funintern function.  */
+
+Lisp_Object
+pkg_emacs_unintern (Lisp_Object name, Lisp_Object package)
+{
+  eassert (package_system_ready);
+  package = package_or_default (package);
+  return pkg_unintern_symbol (name, package);
+}
+
+
 /***********************************************************************
                                Reader
  ***********************************************************************/