Move most of the shorthand implementation to C code

This very likely isn't the final form of the implementation.  For one,
the reader is much slower and allocates a Lisp string for every atom
read, regardless if its already interned or not, which perhaps has the
potential to be catastrophic in terms of GC.

But it passes the tests.

The solution to this, is probably to simplify the semantics of
shorthand-shorthands.  Instead of making it a regexp-to-longhand
alist, make it just prefix-to-longhand.  Then we wouldn't need to call
Fstring_match in oblookup_considering_shorthand, meaning we wouldn't
need a Lisp string there.

* lisp/shorthand.el (shorthand-shorthands): Move to C code.
(shorthand--expand-shorthand): Remove.
(shorthand-read-wrapper): Remove.
(shorthand-intern-soft-wrapper): Remove.
(read, intern-soft): No longer advise.

* src/lread.c:
(read1, Fintern, Fintern_soft, Funintern): Use
oblookup_considering_shorthand.
(oblookup_considering_shorthand): New helper.
(syms_of_lread): Declare shorthand-shorthands.

diff --git a/lisp/shorthand.el b/lisp/shorthand.el
index 54c34120390a5f8127de8815758c36088649039f..f40af92e1c781d8e3030f7254b661639ac102a62 100644 (file)
--- a/lisp/shorthand.el
+++ b/lisp/shorthand.el
@@ -49,52 +49,10 @@
 ;; that with the shorthands for other longer named symbols.
 
 ;;; Code:
-
 (require 'cl-lib)
 
-(defvar shorthand-shorthands nil)
 (put 'shorthand-shorthands 'safe-local-variable #'consp)
 
-(defun shorthand--expand-shorthand (form)
-  (cl-typecase form
-    (cons (setcar form (shorthand--expand-shorthand (car form)))
-          (setcdr form (shorthand--expand-shorthand (cdr form))))
-    (vector (cl-loop for i from 0 for e across form
-                     do (aset form i (shorthand--expand-shorthand e))))
-    (symbol (let* ((name (symbol-name form)))
-              (cl-loop for (short-pat . long-pat) in shorthand-shorthands
-                       when (string-match short-pat name)
-                       do (setq name (replace-match long-pat t nil name)))
-              (setq form (intern name))))
-    (string) (number)
-    (t       (message "[shorthand] unexpected %s" (type-of form))))
-  form)
-
-(defun shorthand-read-wrapper (wrappee stream &rest stuff)
-  "Read a form from STREAM.
-Do this in two steps, read the form while shadowing the global
-`obarray' so that symbols aren't just automatically interned into
-`obarray' as usual.  Then walk the form using
-`shorthand--expand-shorthand' and every time a symbol is found,
-apply the transformations of `shorthand-shorthands' to it before
-interning it the \"real\" global `obarray'.  This ensures that
-longhand, _not_ shorthand, versions of each symbol is interned."
-  (if (and load-file-name (string-match "\\.elc$" load-file-name))
-      (apply wrappee stream stuff)
-    (shorthand--expand-shorthand
-     (let ((obarray (obarray-make))) (apply wrappee stream stuff)))))
-
-(defun shorthand-intern-soft-wrapper (wrappee name &rest stuff)
-  "Tell if string NAME names an interned symbol.
-Even if NAME directly doesn't, its longhand expansion might."
-  (let ((res (apply wrappee name stuff)))
-    (or res (cl-loop
-             for (short-pat . long-pat) in shorthand-shorthands
-             thereis (apply wrappee
-                            (replace-regexp-in-string short-pat
-                                                      long-pat name)
-                            stuff)))))
-
 (defun shorthand-load-wrapper (wrappee file &rest stuff)
   "Load Elisp FILE, aware of file-local `shortand-shorthands'."
   (let (file-local-shorthands)
@@ -106,8 +64,6 @@ Even if NAME directly doesn't, its longhand expansion might."
     (let ((shorthand-shorthands file-local-shorthands))
       (apply wrappee file stuff))))
 
-(advice-add 'read        :around #'shorthand-read-wrapper)
-(advice-add 'intern-soft :around #'shorthand-intern-soft-wrapper)
 (advice-add 'load        :around #'shorthand-load-wrapper)
 
 (provide 'shorthand)

diff --git a/src/lread.c b/src/lread.c
index 2abe2fd91ab4db232a216100556e9dde7987ab1e..f7d0a8c5ea9e1290c03920c27f1bd09f34d546c7 100644 (file)
--- a/src/lread.c
+++ b/src/lread.c
@@ -2956,6 +2956,7 @@ read_integer (Lisp_Object readcharfun, int radix,
   return unbind_to (count, string_to_number (read_buffer, radix, NULL));
 }
 
+Lisp_Object oblookup_considering_shorthand (Lisp_Object, Lisp_Object*);
 
 /* If the next token is ')' or ']' or '.', we store that character
    in *PCH and the return value is not interesting.  Else, we store
@@ -3781,23 +3782,17 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
            }
          else
            {
-             /* Don't create the string object for the name unless
-                we're going to retain it in a new symbol.
-
-                Like intern_1 but supports multibyte names.  */
+             /* Like intern_1 but supports multibyte names.  */
              Lisp_Object obarray = check_obarray (Vobarray);
-             Lisp_Object tem = oblookup (obarray, read_buffer,
-                                         nchars, nbytes);
+              Lisp_Object name
+                   = make_specified_string (read_buffer, nchars, nbytes,
+                                            multibyte);
+             Lisp_Object tem = oblookup_considering_shorthand (obarray, &name);
 
              if (SYMBOLP (tem))
                result = tem;
              else
-               {
-                 Lisp_Object name
-                   = make_specified_string (read_buffer, nchars, nbytes,
-                                            multibyte);
-                 result = intern_driver (name, obarray, tem);
-               }
+                result = intern_driver (name, obarray, tem);
            }
 
          if (EQ (Vread_with_symbol_positions, Qt)
@@ -4407,7 +4402,7 @@ it defaults to the value of `obarray'.  */)
   obarray = check_obarray (NILP (obarray) ? Vobarray : obarray);
   CHECK_STRING (string);
 
-  tem = oblookup (obarray, SSDATA (string), SCHARS (string), SBYTES (string));
+  tem = oblookup_considering_shorthand (obarray, &string);
   if (!SYMBOLP (tem))
     tem = intern_driver (NILP (Vpurify_flag) ? string : Fpurecopy (string),
                         obarray, tem);
@@ -4422,7 +4417,8 @@ 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;
+  register Lisp_Object tem;
+  Lisp_Object string;
 
   if (NILP (obarray)) obarray = Vobarray;
   obarray = check_obarray (obarray);
@@ -4435,7 +4431,7 @@ it defaults to the value of `obarray'.  */)
   else
     string = SYMBOL_NAME (name);
 
-  tem = oblookup (obarray, SSDATA (string), SCHARS (string), SBYTES (string));
+  tem = oblookup_considering_shorthand (obarray, &string);
   if (FIXNUMP (tem) || (SYMBOLP (name) && !EQ (name, tem)))
     return Qnil;
   else
@@ -4451,7 +4447,8 @@ OBARRAY, if nil, defaults to the value of the variable `obarray'.
 usage: (unintern NAME OBARRAY)  */)
   (Lisp_Object name, Lisp_Object obarray)
 {
-  register Lisp_Object string, tem;
+  register Lisp_Object tem;
+  Lisp_Object string;
   size_t hash;
 
   if (NILP (obarray)) obarray = Vobarray;
@@ -4465,9 +4462,7 @@ usage: (unintern NAME OBARRAY)  */)
       string = name;
     }
 
-  tem = oblookup (obarray, SSDATA (string),
-                 SCHARS (string),
-                 SBYTES (string));
+  tem = oblookup_considering_shorthand (obarray, &string);
   if (FIXNUMP (tem))
     return Qnil;
   /* If arg was a symbol, don't delete anything but that symbol itself.  */
@@ -4554,6 +4549,26 @@ oblookup (Lisp_Object obarray, register const char *ptr, ptrdiff_t size, ptrdiff
   XSETINT (tem, hash);
   return tem;
 }
+
+Lisp_Object
+oblookup_considering_shorthand (Lisp_Object obarray, Lisp_Object* string)
+{
+  Lisp_Object tail = Vshorthand_shorthands;
+  FOR_EACH_TAIL_SAFE(tail)
+    {
+      Lisp_Object pair = XCAR (tail);
+      Lisp_Object shorthand = XCAR (pair);
+      Lisp_Object longhand = XCDR (pair);
+      CHECK_STRING (shorthand);
+      CHECK_STRING (longhand);
+      Lisp_Object match = Fstring_match(shorthand, *string, Qnil);
+      if (!NILP(match)){
+        *string = Freplace_match(longhand, Qnil, Qnil, *string, Qnil);
+      }
+    }
+  return oblookup(obarray, SSDATA (*string), SCHARS (*string), SBYTES (*string));
+}
+
 \f
 void
 map_obarray (Lisp_Object obarray, void (*fn) (Lisp_Object, Lisp_Object), Lisp_Object arg)
@@ -5310,4 +5325,9 @@ that are loaded before your customizations are read!  */);
   DEFSYM (Qrehash_threshold, "rehash-threshold");
 
   DEFSYM (Qchar_from_name, "char-from-name");
+
+  DEFVAR_LISP ("shorthand-shorthands", Vshorthand_shorthands,
+          doc: /* Alist of known symbol name shorthands*/);
+  Vshorthand_shorthands = Qnil;
+  DEFSYM (Qshorthand_shorthands, "shorthand-shorthands");
 }