feature/shorthand-namespacing 5811e05 02/11: Move most of the shorthand implementation to C code

[João Távora]

branch: feature/shorthand-namespacing
commit 5811e055c0f46e0a2163027d26c54cde642d21c9
Author: João Távora <joaotavora@gmail.com>
Commit: João Távora <joaotavora@gmail.com>

    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.
---
 lisp/shorthand.el | 44 -----------------------------------------
 src/lread.c       | 58 +++++++++++++++++++++++++++++++++++++------------------
 2 files changed, 39 insertions(+), 63 deletions(-)

diff --git a/lisp/shorthand.el b/lisp/shorthand.el
index 54c3412..f40af92 100644
--- 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 2abe2fd..f7d0a8c 100644
--- 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));
+}
+
 
 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");
 }