diff --git a/lisp/international/mule.el b/lisp/international/mule.el index ee116976eaa..deb801ff1af 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 fce17bf1137..942057c838f 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 0b2395d9761..4a0abb74b3f 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 54c34120390..00000000000 --- 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 -;; 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 . - -;;; 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 2abe2fd91ab..0c0c4f34ba3 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 ba349237cb7..fadf858b717 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 00000000000..7e1ed952291 --- /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 e3d5615ec7d..00000000000 --- 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 -;; 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 . - -;;; 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