master 71857d4 2/6: Move most of the shorthand implementation to C code

[João Távora]

branch: master
commit 71857d410635743d437ce1ee73dff69de50030d6
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
    
    It passes the tests designed for the previous Elisp implementation.
    
    Likely, this 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.  This has the potential to
    be catastrophic in terms of GC.
    
    Also rename the main variable to elisp-shorthands, from the
    repetitive shorthand-shorthands.
    
    For some reason, I had to put 'hack-elisp-shorthands' and
    'load-with-shorthands-and-code-conversion', the new source-file
    loading functions, in lisp/international/mule.el.
    
    Otherwise, lisp/loadup.el wouldn't see them, for some reason that I
    didn't investigate.  This should probably be fixed.
    
    * lisp/shorthand.el: Remove.
    
    * test/lisp/shorthand-tests.el: Remove.
    
    * src/lread.c:
    (read1, Fintern, Fintern_soft, Funintern): Use
    oblookup_considering_shorthand.
    (oblookup_considering_shorthand): New helper.
    (syms_of_lread): Declare elisp-shorthands.
    
    * lisp/progmodes/elisp-mode.el (elisp-shorthands):
    Put a safe-local-variable spec.
    
    * test/lisp/progmodes/elisp-mode-tests.el (elisp-shorthand-read-buffer)
    (elisp-shorthand-read-from-string)
    (elisp-shorthand-byte-compile-a-file)
    (elisp-shorthand-load-a-file): New tests.
    
    * test/lisp/progmodes/elisp-resources/simple-shorthand-test.el: New file
    
    * lisp/loadup.el (load-source-file-function): Set to
    load-with-shorthands-and-code-conversion.
    
    * lisp/international/mule.el (hack-elisp-shorthands): Move here.
    (load-with-shorthands-and-code-conversion): And here.
---
 lisp/international/mule.el                         |  30 ++++++
 lisp/loadup.el                                     |   2 +-
 lisp/progmodes/elisp-mode.el                       |   3 +
 lisp/shorthand.el                                  | 114 ---------------------
 src/lread.c                                        |  65 ++++++++----
 test/lisp/progmodes/elisp-mode-tests.el            |  59 +++++++++++
 .../elisp-resources/simple-shorthand-test.el       |  25 +++++
 test/lisp/shorthand-tests.el                       |  60 -----------
 8 files changed, 165 insertions(+), 193 deletions(-)

diff --git a/lisp/international/mule.el b/lisp/international/mule.el
index ee11697..deb801f 100644
--- a/lisp/international/mule.el
+++ b/lisp/international/mule.el
@@ -294,6 +294,31 @@ attribute."
 
     (apply 'define-charset-internal name (mapcar 'cdr attrs))))
 
+(defun hack-elisp-shorthands (fullname)
+  "Return value of the `elisp-shorthands' file-local variable in FULLNAME.
+FULLNAME is the full name of an Elisp file which potentially
+specifies a file-local value for `elisp-shorthands'.  The Elisp
+code isn't read or evaluated in any way, we merely extract what
+the buffer-local value of `elisp-shorthands' would be if the file
+had been found by `find-file'."
+  (let ((size (nth 7 (file-attributes fullname))))
+    (with-temp-buffer
+      (insert-file-contents fullname nil (max 0 (- size 3000)) size)
+      (goto-char (point-max))
+      (let* ((found (search-backward-regexp "elisp-shorthands:[ \t]*" 0 t))
+             (val (and found
+                       (goto-char (match-end 0))
+                       (ignore-errors (read (current-buffer)))))
+             (probe val)
+             aux)
+        (catch 'done
+          (when (consp probe)
+            (while (setq aux (pop probe))
+              (unless (and (consp aux)
+                           (stringp (car aux))
+                           (stringp (cdr aux)))
+                (throw 'done nil)))
+            val))))))
 
 (defun load-with-code-conversion (fullname file &optional noerror nomessage)
   "Execute a file of Lisp code named FILE whose absolute name is FULLNAME.
@@ -354,6 +379,11 @@ Return t if file exists."
          (message "Loading %s...done" file)))
       t)))
 
+(defun load-with-shorthands-and-code-conversion (fullname file noerror 
nomessage)
+  "As `load-with-code-conversion', also considering Elisp shorthands."
+  (let ((elisp-shorthands (hack-elisp-shorthands fullname)))
+    (load-with-code-conversion fullname file noerror nomessage)))
+
 (defun charset-info (charset)
   "Return a vector of information of CHARSET.
 This function is provided for backward compatibility.
diff --git a/lisp/loadup.el b/lisp/loadup.el
index fce17bf..942057c 100644
--- a/lisp/loadup.el
+++ b/lisp/loadup.el
@@ -151,7 +151,7 @@
 ;; variable its advertised default value (it starts as nil, see
 ;; xdisp.c).
 (setq resize-mini-windows 'grow-only)
-(setq load-source-file-function #'load-with-code-conversion)
+(setq load-source-file-function #'load-with-shorthands-and-code-conversion)
 (load "files")
 
 ;; Load-time macro-expansion can only take effect after setting
diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el
index 0b2395d..4a0abb7 100644
--- a/lisp/progmodes/elisp-mode.el
+++ b/lisp/progmodes/elisp-mode.el
@@ -2075,5 +2075,8 @@ Runs in a batch-mode Emacs.  Interactively use variable
     (terpri)
     (pp collected)))
 
+
+(put 'elisp-shorthands 'safe-local-variable #'consp)
+
 (provide 'elisp-mode)
 ;;; elisp-mode.el ends here
diff --git a/lisp/shorthand.el b/lisp/shorthand.el
deleted file mode 100644
index 54c3412..0000000
--- a/lisp/shorthand.el
+++ /dev/null
@@ -1,114 +0,0 @@
-;;; shorthand.el --- namespacing system  -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2020  Free Software Foundation
-
-;; Author: João Távora <joaotavora@gmail.com>
-;; Keywords: languages, lisp
-
-;; This program 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.
-
-;; This program 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 this program.  If not, see <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Simple-minded namespacing in Emacs:
-
-;; 1. Do this on an Emacs you don't care about, since this advises basic
-;;    functions;
-;; 2. Load `shorthand.el` (or byte-compile and load it);
-;; 3. Construct an example user of this library.
-;;
-;;    magnar-string.el is constructed by taking s.el, renaming it to
-;;    magnar-string.el, and then appending this to the end of the file:
-;;
-;;    ;;; magnar-string.el ends here,
-;;    Local Variables:
-;;    shorthand-shorthands: (("^s-" . "magnar-string-"))
-;;    End:
-;;
-;; 4. Load `magnar-string.el` or byte-compile it and load `magnar-string.elc`;
-;; 5. Try C-h f and check there's no "s-" pollution; Not even the `s-`
-;;    symbols are interned.  All the relevant functions are namespaced
-;;    under "magnar-string-";
-;; 6. Open test.el, and play around there.  Open test2.el and play around
-;;    with magnar-string.el under a different "mstring-" prefix;
-;; 7. Evaluating code should work.  Eldoc should also work.  Xref (`M-.`)
-;;    is broken.  Anything else might breaks spectacularly;
-
-;; Read `shorthand.el`: it's less than 50 loc.  The idea is to keep only
-;; one obarray, but instruments `read` to not pollute it with symbols
-;; 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)
-    (when (file-readable-p file)
-      (with-temp-buffer
-        (insert-file-contents file)
-        (hack-local-variables)
-        (setq file-local-shorthands shorthand-shorthands)))
-    (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)
-;;; shorthand.el ends here
diff --git a/src/lread.c b/src/lread.c
index 2abe2fd..0c0c4f3 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);
@@ -4435,7 +4430,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 +4446,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 +4461,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 +4548,37 @@ 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 original = *string; /* Save pointer to original string... */
+  Lisp_Object tail = Velisp_shorthands;
+  FOR_EACH_TAIL_SAFE(tail)
+    {
+      Lisp_Object pair = XCAR (tail);
+      if (!CONSP (pair)) goto undo;
+      Lisp_Object shorthand = XCAR (pair);
+      Lisp_Object longhand = XCDR (pair);
+      if (!STRINGP (shorthand) || !STRINGP (longhand)) goto undo;
+      Lisp_Object match = Fstring_match (shorthand, *string, Qnil);
+      if (!NILP(match)){
+        *string = Freplace_match(longhand, Qnil, Qnil, *string, Qnil);
+      }
+    }
+  goto fine;
+ undo:
+  {
+    static const char* warn =
+      "Fishy value of `elisp-shorthands'.  "
+      "Consider reviewing before evaluating code.";
+    message_dolog (warn, sizeof(warn), 0, 0);
+    *string = original;   /* ...so we can any failed trickery here. */
+  }
+ fine:
+  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 +5335,8 @@ that are loaded before your customizations are read!  */);
   DEFSYM (Qrehash_threshold, "rehash-threshold");
 
   DEFSYM (Qchar_from_name, "char-from-name");
+
+  DEFVAR_LISP ("elisp-shorthands", Velisp_shorthands,
+          doc: /* Alist of known symbol name shorthands*/);
+  Velisp_shorthands = Qnil;
 }
diff --git a/test/lisp/progmodes/elisp-mode-tests.el 
b/test/lisp/progmodes/elisp-mode-tests.el
index ba34923..fadf858 100644
--- a/test/lisp/progmodes/elisp-mode-tests.el
+++ b/test/lisp/progmodes/elisp-mode-tests.el
@@ -1021,5 +1021,64 @@ evaluation of BODY."
     (should (equal (elisp--xref-infer-namespace p3) 'any))
     (should (equal (elisp--xref-infer-namespace p4) 'any))))
 
+
+(ert-deftest elisp-shorthand-read-buffer ()
+  (let* ((gsym (downcase (symbol-name (cl-gensym "sh-"))))
+         (shorthand-sname (format "s-%s" gsym))
+         (expected (intern (format "shorthand-longhand-%s" gsym))))
+    (cl-assert (not (intern-soft shorthand-sname)))
+    (should (equal (let ((elisp-shorthands
+                          '(("^s-" . "shorthand-longhand-"))))
+                     (with-temp-buffer
+                       (insert shorthand-sname)
+                       (goto-char (point-min))
+                       (read (current-buffer))))
+                   expected))
+    (should (not (intern-soft shorthand-sname)))))
+
+(ert-deftest elisp-shorthand-read-from-string ()
+  (let* ((gsym (downcase (symbol-name (cl-gensym "sh-"))))
+         (shorthand-sname (format "s-%s" gsym))
+         (expected (intern (format "shorthand-longhand-%s" gsym))))
+    (cl-assert (not (intern-soft shorthand-sname)))
+    (should (equal (let ((elisp-shorthands
+                          '(("^s-" . "shorthand-longhand-"))))
+                     (car (read-from-string shorthand-sname)))
+                   expected))
+    (should (not (intern-soft shorthand-sname)))))
+
+(defvar elisp--test-resources-dir
+  (expand-file-name "elisp-resources/"
+                    (file-name-directory
+                     (or load-file-name
+                         (error "this file needs to be loaded")))))
+
+(ert-deftest elisp-shorthand-load-a-file ()
+  (let ((test-file (expand-file-name "simple-shorthand-test.el"
+                                     elisp--test-resources-dir)))
+    (mapatoms (lambda (s)
+                (when (string-match "^elisp--foo-" (symbol-name s))
+                  (unintern s obarray))))
+    (load test-file)
+    (should (intern-soft "elisp--foo-test"))
+    (should-not (intern-soft "f-test"))))
+
+(ert-deftest elisp-shorthand-byte-compile-a-file ()
+
+  (let ((test-file (expand-file-name "simple-shorthand-test.el"
+                                     elisp--test-resources-dir))
+        (byte-compiled (expand-file-name "simple-shorthand-test.elc"
+                                         elisp--test-resources-dir)))
+    (mapatoms (lambda (s)
+                (when (string-match "^elisp--foo-" (symbol-name s))
+                  (unintern s obarray))))
+    (byte-compile-file test-file)
+    (should-not (intern-soft "f-test"))
+    (should (intern-soft "elisp--foo-test"))
+    (should-not (fboundp (intern-soft "elisp--foo-test")))
+    (load byte-compiled)
+    (should (intern-soft "elisp--foo-test"))
+    (should-not (intern-soft "f-test"))))
+
 (provide 'elisp-mode-tests)
 ;;; elisp-mode-tests.el ends here
diff --git a/test/lisp/progmodes/elisp-resources/simple-shorthand-test.el 
b/test/lisp/progmodes/elisp-resources/simple-shorthand-test.el
new file mode 100644
index 0000000..7e1ed95
--- /dev/null
+++ b/test/lisp/progmodes/elisp-resources/simple-shorthand-test.el
@@ -0,0 +1,25 @@
+(defun f-test ()
+  (let ((elisp-shorthands '(("^foo-" . "bar-"))))
+    (with-temp-buffer
+      (insert "(foo-bar)")
+      (goto-char (point-min))
+      (read (current-buffer)))))
+
+(defun f-test2 ()
+  (let ((elisp-shorthands '(("^foo-" . "bar-"))))
+    (read-from-string "(foo-bar)")))
+
+
+(defun f-test3 ()
+  (let ((elisp-shorthands '(("^foo-" . "bar-"))))
+    (intern "foo-bar")))
+
+(when nil
+  (f-test3)
+  (f-test2)
+  (f-test))
+
+
+;; Local Variables:
+;; elisp-shorthands: (("^f-" . "elisp--foo-"))
+;; End:
diff --git a/test/lisp/shorthand-tests.el b/test/lisp/shorthand-tests.el
deleted file mode 100644
index e3d5615..0000000
--- a/test/lisp/shorthand-tests.el
+++ /dev/null
@@ -1,60 +0,0 @@
-;;; shorthand-tests.el --- Tests for shorthand.el  -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2020 Free Software Foundation, Inc.
-
-;; Author: João Távora <joaotavora@gmail.com>
-;; Keywords:
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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.
-
-;; GNU Emacs 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 GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;
-
-;;; Code:
-
-(require 'shorthand)
-(require 'cl-lib)
-(require 'ert)
-
-(ert-deftest shorthand-read-buffer ()
-  (let* ((gsym (downcase (symbol-name (cl-gensym "sh-"))))
-         (shorthand-sname (format "s-%s" gsym))
-         (expected (intern (format "shorthand-longhand-%s" gsym))))
-    (cl-assert (not (intern-soft shorthand-sname)))
-    (should (equal (let ((shorthand-shorthands
-                          '(("^s-" . "shorthand-longhand-"))))
-                     (with-temp-buffer
-                       (insert shorthand-sname)
-                       (goto-char (point-min))
-                       (read (current-buffer))))
-                   expected))
-    (should (not (intern-soft shorthand-sname)))))
-
-(ert-deftest shorthand-read-from-string ()
-  (let* ((gsym (downcase (symbol-name (cl-gensym "sh-"))))
-         (shorthand-sname (format "s-%s" gsym))
-         (expected (intern (format "shorthand-longhand-%s" gsym))))
-    (cl-assert (not (intern-soft shorthand-sname)))
-    (should (equal (let ((shorthand-shorthands
-                          '(("^s-" . "shorthand-longhand-"))))
-                     (car (read-from-string shorthand-sname)))
-                   expected))
-    (should (not (intern-soft shorthand-sname)))))
-
-
-(provide 'shorthand-tests)
-;;; shorthand-tests.el ends here