From debbugs-submit-bounces@debbugs.gnu.org Wed Feb 09 14:24:47 2022 Received: (at submit) by debbugs.gnu.org; 9 Feb 2022 19:24:47 +0000 Received: from localhost ([127.0.0.1]:52709 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1nHsa7-0005Nt-Fe for submit@debbugs.gnu.org; Wed, 09 Feb 2022 14:24:47 -0500 Received: from lists.gnu.org ([209.51.188.17]:48414) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1nHsLM-0004wU-Fo for submit@debbugs.gnu.org; Wed, 09 Feb 2022 14:09:32 -0500 Received: from eggs.gnu.org ([209.51.188.92]:40514) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1nHsLM-0000dZ-77 for bug-gnu-emacs@gnu.org; Wed, 09 Feb 2022 14:09:32 -0500 Received: from [2607:f8b0:4864:20::f2e] (port=40561 helo=mail-qv1-xf2e.google.com) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1nHsLG-0007Eh-Ad for bug-gnu-emacs@gnu.org; Wed, 09 Feb 2022 14:09:31 -0500 Received: by mail-qv1-xf2e.google.com with SMTP id v10so2612540qvk.7 for ; Wed, 09 Feb 2022 11:09:25 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20210112; h=from:to:subject:date:message-id:user-agent:mime-version; bh=txY/a4dS8DPDb47uDhgysanghH++PlRz7IezpzqLMcg=; b=KSsN4UEMiBED0jw1NM50+D+bglnE9NDZwh9h3bAut2/OHZbnZsn88hy+VmcuH2If7C BCTyYbxcyu6xALAvO8KUvec7Ozpx9ZRUQN7IRo+uJlbwYflM/frnyIrJ9b40VVSG8v1K HMfCKnXxpDHITcBE1qU6miNFgL1ie3OhJ12Ao1U3fEPmHt6KyDI2ODTZDUm+DQ6yeTEf 5T9hitkZAJ2lVNGC+Z6SaVAgHYBES7Tx6ydygKgu+UL3PzZnKg91ShP1iN2lXbMYQYAN 5gk486QOav1O/q2vJeC9sS6cCmf19k4HffcvwCjD+uZppfL1lF7fxBuCDje7pZD/evHJ ho4g== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=x-gm-message-state:from:to:subject:date:message-id:user-agent :mime-version; bh=txY/a4dS8DPDb47uDhgysanghH++PlRz7IezpzqLMcg=; b=EoGvL5RUHKZzR8KHJ8FrwrDjT7uu/rdsYZSupeNEAIQReW7phk2/VlDIWib3C7xBpv 2gnIJRs3p5KgbTDpk+lwx0QqbMxP4k8uIlFwZXy3ax/xSgug8LPM0c7G3kXkW2j3rGW6 Vr+76JA8Gp4bblqw3gd0WS83+fbaalxsTN+GeRGHyEWpYU2sOWjgwK92/ogVVzJEzJTK skM40hso5y1QXVt02IQOHbqdcvWf2w9PMLKin740TN2uLNWmsuUrx9FDUgi9olGPvviT fsIX8/Mqhd6mSY3E9J2ObH8vt4jCifnUk/sjM0mXD0Iy0dDS2Fopqqs9k/saDJDnJRuB CL5Q== X-Gm-Message-State: AOAM531Ec+T5NyiW/LkjQOvsCc+TZJjsQ5pTrPwLbgVBKyADwLa0rbcF hZJHwgAN0J4XRmH9gOfm6SM/aJhEDW0= X-Google-Smtp-Source: ABdhPJxaloz8TXwH9ZMKRz762d4Ogjo3LgcZi8MAlxJt6DPrXPW7rfLcbSfiewTNY/dOD7b7CZZzlw== X-Received: by 2002:a05:6214:ac5:: with SMTP id g5mr2619558qvi.51.1644433764701; Wed, 09 Feb 2022 11:09:24 -0800 (PST) Received: from localhost (pool-96-232-253-158.nycmny.fios.verizon.net. [96.232.253.158]) by smtp.gmail.com with ESMTPSA id 187sm8552752qkm.63.2022.02.09.11.09.22 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Wed, 09 Feb 2022 11:09:23 -0800 (PST) From: dick.r.chiang@gmail.com To: bug-gnu-emacs Subject: 29.0.50; [PATCH] Back out scratch/correct-warning-pos Date: Wed, 09 Feb 2022 14:09:22 -0500 Message-ID: <87zgmzamcd.fsf@dick> User-Agent: Gnus/5.14 (Gnus v5.14) Commercial/29.0.50 (gnu/linux) MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Host-Lookup-Failed: Reverse DNS lookup failed for 2607:f8b0:4864:20::f2e (failed) Received-SPF: pass client-ip=2607:f8b0:4864:20::f2e; envelope-from=dick.r.chiang@gmail.com; helo=mail-qv1-xf2e.google.com X-Spam_score_int: -12 X-Spam_score: -1.3 X-Spam_bar: - X-Spam_report: (-1.3 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, FREEMAIL_FROM=0.001, PDS_HP_HELO_NORDNS=0.001, RCVD_IN_DNSWL_NONE=-0.0001, RDNS_NONE=0.793, SPF_HELO_NONE=0.001, SPF_PASS=-0.001, T_FILL_THIS_FORM_SHORT=0.01, T_SCC_BODY_TEXT_LINE=-0.01 autolearn=no autolearn_force=no X-Spam_action: no action X-Debbugs-Envelope-To: submit X-Mailman-Approved-At: Wed, 09 Feb 2022 14:24:46 -0500 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" --=-=-= Content-Type: text/x-diff; charset=utf-8 Content-Disposition: inline; filename=0001-Back-out-scratch-correct-warning-pos.patch Content-Transfer-Encoding: quoted-printable >From 6cbe8e1baafda4304ca8905808e1a9a3db10d154 Mon Sep 17 00:00:00 2001 From: dickmao Date: Wed, 9 Feb 2022 13:54:35 -0500 Subject: [PATCH] Back out scratch/correct-warning-pos Prefer giving up some diagnostic precision to avoid vitiating the lisp implementation. * doc/lispref/elisp.texi (Top): Back out. * doc/lispref/streams.texi (Input Functions): Back out. * doc/lispref/symbols.texi (Symbols): Back out. * lisp/Makefile.in (cldefs .PHONY): Deal with Bug#30635. (%.elc): Recompile the world after bytecomp.el changes. * lisp/cedet/semantic/fw.el (semantic-alias-obsolete): Back out. (semantic-varalias-obsolete): Back out. * lisp/emacs-lisp/bindat.el (bindat--type): Back out. * lisp/emacs-lisp/byte-opt.el (byte-compile-inline-expand): Back out. (byte-optimize-form-code-walker): Back out. (byte-optimize-let-form): Back out. (byte-optimize-while): Back out. (byte-optimize-apply): Back out. * lisp/emacs-lisp/byte-run.el (byte-run--ssp-seen): Back out. (byte-run--circular-list-p): Back out. (byte-run--strip-s-p-1): Back out. (byte-run-strip-symbol-positions): Back out. (function-put): Back out. (defmacro): Back out. (defun): Back out. (defsubst): Back out. (byte-run--unescaped-character-literals-warning): De-obfuscate. * lisp/emacs-lisp/bytecomp.el (require): Deal with Bug#30635. (byte-compiler-base-file-name): De-obfuscate. (byte-compile-recurse-toplevel): Renamed to maybe-expand. (byte-compile-maybe-expand): Renamed from recurse-toplevel. (byte-compile-initial-macro-environment): Accommodate renames. (byte-defop): Whitespace. (byte-compile-eval-before-compile): Muse to yourself. (byte-compile-current-form): Globals make programming easy. (byte-compile-current-annotations): Globals make programming easy. (byte-compile-current-charpos): Globals make programming easy. (byte-compile-log-1): Add docstring. (byte-compile-last-warned-form): Renamed to func. (byte-compile-last-warned-func): Renamed from form. (byte-compile--first-symbol): Back out. (byte-compile--warning-source-offset): Back out. (byte-compile-warning-prefix): Abbreviate comment. (byte-compile-log-file): Accommodate renames. (byte-compile-log-warning-function): Docstring. (byte-compile-log-warning): Docstring. (byte-compile--log-warning-for-byte-compile): Whitespace. (byte-compile-warn): Whitespace. (byte-compile-warn-x): Back out. (byte-compile-warn-obsolete): De Morgan's. (byte-compile-report-error): Whitespace. (byte-compile-fdefinition): Docstring. (byte-compile-fuzzy-charpos): Divine charpos of compiler warning. (byte-compile-function-warn): Docstring and de-obfuscate. (byte-compile-emit-callargs-warn): Back out. (byte-compile-format-warn): Back out. (byte-compile-nogroup-warn): Back out. (byte-compile-arglist-warn): Back out. (byte-compile-docstring-length-warn): Back out. (byte-compile-warn-about-unresolved-functions): Back out. (byte-compile--outbuffer): Back out. (byte-compile-close-variables): Back out. (displaying-byte-compile-warnings): Back out. (byte-compile-file): Prefer `when`. (compile-defun): Back out. (byte-compile-from-buffer): Back out. (byte-compile-output-file-form): Back out. (byte-compile-output-docform): Back out. (byte-compile-keep-pending): Use `prog1` to emphasize return value. (byte-compile-flush-pending): Back out. (byte-compile-preprocess): Back out. (byte-compile-toplevel-file-form): De-obfuscate. (byte-compile-file-form): De-obfuscate. (byte-compile-file-form-autoload): Prefer `when`. (byte-compile--check-prefixed-var): Back out. (byte-compile--declare-var): Back out. (byte-compile-file-form-defvar): Prefer `when`. (byte-compile-file-form-defvar-function): Prefer `when`. (byte-compile-file-form-require): De-obfuscate. (byte-compile-file-form-progn): Use `prog1` to emphasize return value. (byte-compile-file-form-with-no-warnings): Refactor. (byte-compile-file-form-with-suppressed-warnings): Refactor. (byte-compile-file-form-make-obsolete): Function quote. (byte-compile-file-form-defmumble): Renamed to defalias*. (byte-compile-file-form-defalias*): Renamed from defmumble. (byte-compile-output-as-comment): Whitespace. (byte-compile): Docstring. (byte-compile-check-lambda-list): Back out. (byte-compile--warn-lexical-dynamic): Back out. (byte-compile-lambda): Rename "csts" to "constants". (byte-compile-top-level): Accommodate renames. (byte-compile-out-toplevel): Rename to "top-level". (byte-compile-out-top-level): Rename from "toplevel". (byte-compile-top-level-body): Delete unused function. (byte-compile-macroexpand-declare-function): Whitespace. (byte-compile--decouple-cell): Separate out annotation. (byte-compile--decouple): Separate out annotations. (byte-compile-form): Let-bind `byte-compile-current-form`. (byte-compile-normal-call): Prefer `when`. (byte-compile-unfold-bcf): Rename to byte-code-function. (byte-compile-unfold-byte-code-function): Rename from bcf. (byte-compile-check-variable): Back out. (byte-compile-dynamic-variable-op): Back out. (byte-compile-free-vars-warn): Back out. (byte-compile-variable-ref): Back out. (byte-compile-variable-set): Back out. (byte-compile-constant): Remove `inline`. (byte-compile-push-constant): Back out. (byte-defop-compiler): Docstring. (byte-compile-subr-wrong-args): Back out. (byte-compile-and-folded): Allow cl-lib in bytecomp.el. (byte-compile-discard): Prefer `not`. (byte-compile-make-closure): Brevity is clarity. (byte-compile-get-closed-var): Brevity is clarity. (byte-compile-char-before): Docstring. (byte-compile-backward-char): Docstring. (byte-compile-list): Function quote. (byte-compile-concat): Function quote. (byte-compile-fset): Docstring. (byte-compile-function-form): Docstring. (byte-compile-insert): Function quote. (byte-compile-set-default): Back out. (byte-compile-find-bound-condition): Docstring. (byte-compile-funcall): Function quote. (byte-compile-condition-case): Back out. (byte-compile-save-excursion): Back out. (byte-compile-defvar): Back out. (byte-compile-autoload): Back out. (byte-compile-lambda-form): Docstring. (byte-compile-file-form-defalias): Docstring. (byte-compile-make-variable-buffer-local): Back out. (byte-compile-define-symbol-prop): Remove unused retval. (byte-compile-out): Brevity is clarity. (byte-compile-annotate-call-tree): Back out. (display-call-tree): Back out. (prog1): Use `prog1` to emphasize return value. * lisp/emacs-lisp/cconv.el (cconv--warn-unused-msg): Back out. (cconv--convert-funcbody): Back out. (cconv-convert): Back out. (cconv--analyze-use): Back out. (cconv--analyze-function): Back out. (cconv-analyze-form): Back out. * lisp/emacs-lisp/cl-generic.el (cl-defmethod): Back out. * lisp/emacs-lisp/cl-macs.el (cl-load-time-value): Accommodate renames. (cl-symbol-macrolet): Back out. (cl-defstruct): Back out. * lisp/emacs-lisp/cldefs.el.in (gv): Allow cl-lib in bytecomp.el. (cldefs--cl-lib-functions): Allow cl-lib in bytecomp.el. * lisp/emacs-lisp/comp.el (comp-finalize-relocs): Back out. (comp--native-compile): Back out. * lisp/emacs-lisp/easy-mmode.el (define-minor-mode): Back out. * lisp/emacs-lisp/eieio-core.el (eieio-oref): Back out. (eieio-oref-default): Back out. (eieio-oset-default): Back out. * lisp/emacs-lisp/eieio.el (defclass): Back out. * lisp/emacs-lisp/gv.el (gv-ref): Back out. * lisp/emacs-lisp/macroexp.el (byte-compile-form-stack): Back out. (macroexp--compiler-macro): Back out. (macroexp--warn-wrap): Back out. (macroexp-warn-and-return): Back out. (macroexp-macroexpand): Back out. (macroexp--unfold-lambda): Back out. (macroexp--expand-all): Back out. (macroexpand--all-toplevel): Back out. (macroexpand--all-top-level): Back out. (internal-macroexpand-for-load): Back out. * lisp/emacs-lisp/pcase.el (pcase-compile-patterns): Back out. (pcase--u1): Back out. * lisp/help.el (help--make-usage): Back out. * lisp/keymap.el (define-keymap--compile): Back out. * lisp/minibuffer.el (read-file-name-completion-ignore-case): Prefer `when`. * src/Makefile.in (all): Add cldefs.el target. (../native-lisp): Add cldefs.el target. ($(lispsource)/emacs-lisp/cldefs.el): Add cldefs.el target. * src/alloc.c (XPNTR): Back out. (set_symbol_name): Back out. (init_symbol): Back out. (valid_lisp_object_p): Back out. (purecopy): Back out. (Fgarbage_collect): Back out. (mark_char_table): Back out. (mark_object): Back out. (survives_gc_p): Back out. (symbol_uses_obj): Back out. * src/comp.c (comp_t): Back out. (helper_link_table): Back out. (emit_BASE_EQ): Back out. (emit_EQ): Back out. (emit_AND): Back out. (emit_OR): Back out. (emit_BARE_SYMBOL_P): Back out. (emit_SYMBOL_WITH_POS_P): Back out. (emit_SYMBOL_WITH_POS_SYM): Back out. (emit_NILP): Back out. (emit_CHECK_SYMBOL_WITH_POS): Back out. (emit_limple_insn): Back out. (declare_runtime_imported_funcs): Back out. (emit_ctxt_code): Back out. (define_lisp_symbol_with_position): Back out. (define_GET_SYMBOL_WITH_POSITION): Back out. (define_SYMBOL_WITH_POS_SYM): Back out. (Fcomp__init_ctxt): Back out. (Fcomp__compile_ctxt_to_file): Back out. (helper_GET_SYMBOL_WITH_POSITION): Back out. (load_comp_unit): Back out. (syms_of_comp): Back out. * src/data.c (Ftype_of): Back out. (Fbare_symbol_p): Back out. (Fsymbol_with_pos_p): Back out. (Fbare_symbol): Back out. (Fsymbol_with_pos_pos): (Fremove_pos_from_symbol): Back out. (Fposition_symbol): Back out. (syms_of_data): Back out. * src/fns.c (Fcircular_list_p): Not redundant with `proper-list-p`. (internal_equal): Back out. (hash_lookup): Back out. (syms_of_fns): Add circular_list_p. * src/keyboard.c (recursive_edit_1): Back out. * src/lisp.h (lisp_h_PSEUDOVECTORP): Back out. (lisp_h_BASE_EQ): Back out. (lisp_h_EQ): Back out. (lisp_h_NILP): Back out. (lisp_h_SYMBOL_WITH_POS_P): Back out. (lisp_h_SYMBOLP): Back out. (BARE_SYMBOL_P): Back out. (BASE_EQ): Back out. (EQ): Back out. (SYMBOLP): Back out. (GCALIGNED_STRUCT): Back out. (DEFINE_GDB_SYMBOL_BEGIN): Back out. * src/lread.c (ANNOTATE): Cons charpos with atom. (readchar): Zero-indexed offset to one-indexed charpos. (unreadchar): Zero-indexed offset to one-indexed charpos. (read_filtered_event): Whitespace. (load_warn_unescaped_character_literals): De-obfuscate. (Fload): Whitespace. (maybe_swap_for_eln): Whitespace. (openp): Whitespace. (build_load_history): Whitespace. (readevalloop): Whitespace. (Feval_buffer): Whitespace. (Feval_region): Whitespace. (Fread_annotated): Cons charpos with atom. (Fread_positioning_symbols): Back out. (read_internal_start): Cons charpos with atom. (read0): Cons charpos with atom. (read1): Cons charpos with atom. (substitute_object_recurse): Whitespace. (read_vector): Cons charpos with atom. (read_list): Cons charpos with atom. (load_path_check): Whitespace. (load_path_default): Whitespace. (syms_of_lread): Cons charpos with atom. * src/print.c (print_vectorlike): Back out. (print_object): Back out. (syms_of_print): Back out. * test/Makefile.in (%.elc): Recompile the world if bytecomp.el changes. * test/lisp/emacs-lisp/bytecomp-tests.el (bytecomp-tests--warnings): Use constants. (bytecomp--with-warning-test): Use constants. (bytecomp--buffer-with-warning-test): Test warning line numbers. (bytecomp-warn-absent-require-cl-lib): Test Bug#30635. (bytecomp-warn-coordinates): Test warning line numbers. (bytecomp-warn-present-require-cl-lib): Test Bug#30635. (bytecomp-read-annotated-equivalence): Test `read-annotated`. (bytecomp--define-warning-file-test): Use constants. (bytecomp-tests--test-no-warnings-with-advice): Use constants. (bytecomp-test-featurep-warnings): Use constants. (test-suppression): Use constants. * test/lisp/emacs-lisp/gv-tests.el (gv-tests--in-temp-dir): Deal with Bug#30635. (gv-define-expander-out-of-file): Whitespace. --- .gitignore | 1 + doc/lispref/elisp.texi | 1 - doc/lispref/streams.texi | 9 - doc/lispref/symbols.texi | 69 +- lisp/Makefile.in | 36 +- lisp/cedet/semantic/fw.el | 32 +- lisp/emacs-lisp/bindat.el | 1 - lisp/emacs-lisp/byte-opt.el | 58 +- lisp/emacs-lisp/byte-run.el | 108 +- lisp/emacs-lisp/bytecomp.el | 1799 +++++++++++------------- lisp/emacs-lisp/cconv.el | 39 +- lisp/emacs-lisp/cl-generic.el | 6 +- lisp/emacs-lisp/cl-macs.el | 14 +- lisp/emacs-lisp/cldefs.el.in | 17 + lisp/emacs-lisp/comp.el | 15 +- lisp/emacs-lisp/easy-mmode.el | 1 - lisp/emacs-lisp/eieio-core.el | 5 - lisp/emacs-lisp/eieio.el | 4 +- lisp/emacs-lisp/gv.el | 5 +- lisp/emacs-lisp/macroexp.el | 327 ++--- lisp/emacs-lisp/multisession.el | 2 +- lisp/emacs-lisp/pcase.el | 2 - lisp/help.el | 2 +- lisp/keymap.el | 11 +- lisp/minibuffer.el | 4 +- lisp/sqlite-mode.el | 2 +- src/Makefile.in | 9 +- src/alloc.c | 40 +- src/comp.c | 293 +--- src/data.c | 105 +- src/fns.c | 28 +- src/keyboard.c | 2 - src/lisp.h | 218 +-- src/lread.c | 483 +++---- src/pdumper.c | 4 +- src/print.c | 33 +- src/sqlite.c | 2 +- test/Makefile.in | 4 +- test/lisp/emacs-lisp/bytecomp-tests.el | 147 +- test/lisp/emacs-lisp/gv-tests.el | 5 +- 40 files changed, 1560 insertions(+), 2383 deletions(-) create mode 100644 lisp/emacs-lisp/cldefs.el.in diff --git a/.gitignore b/.gitignore index 16f449a446e..2f20ccf0dcd 100644 --- a/.gitignore +++ b/.gitignore @@ -82,6 +82,7 @@ src/verbose.mk # Lisp-level sources built by 'make'. *cus-load.el *loaddefs.el +*cldefs.el lisp/cedet/semantic/bovine/c-by.el lisp/cedet/semantic/bovine/make-by.el lisp/cedet/semantic/bovine/scm-by.el diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi index 426bb6d0176..4d75bc116a9 100644 --- a/doc/lispref/elisp.texi +++ b/doc/lispref/elisp.texi @@ -450,7 +450,6 @@ Top for recording miscellaneous information. * Shorthands:: Properly organize your symbol names but type less of them. -* Symbols with Position:: Symbol variants containing integer positions =20 Symbol Properties =20 diff --git a/doc/lispref/streams.texi b/doc/lispref/streams.texi index 8f8562cadc8..bf728ea3e93 100644 --- a/doc/lispref/streams.texi +++ b/doc/lispref/streams.texi @@ -327,15 +327,6 @@ Input Functions @end example @end defun =20 -@defun read-positioning-symbols &optional stream -This function reads one textual expression from @var{stream}, like -@code{read} does, but additionally positions the read symbols to the -positions in @var{stream} where they occurred. Only the symbol -@code{nil} is not positioned, this for efficiency reasons. -@xref{Symbols with Position}. This function is used by the byte -compiler. -@end defun - @defvar standard-input This variable holds the default input stream---the stream that @code{read} uses when the @var{stream} argument is @code{nil}. diff --git a/doc/lispref/symbols.texi b/doc/lispref/symbols.texi index 9e44348b671..18968c1d8b5 100644 --- a/doc/lispref/symbols.texi +++ b/doc/lispref/symbols.texi @@ -31,7 +31,7 @@ Symbols for recording miscellaneous information. * Shorthands:: Properly organize your symbol names but type less of them. -* Symbols with Position:: Symbol variants containing integer positio= ns + @end menu =20 @node Symbol Components @@ -751,70 +751,3 @@ Shorthands @item Symbol forms whose names start with @samp{#_} are not transformed. @end itemize - -@node Symbols with Position -@section Symbols with Position -@cindex symbol with position - -@cindex bare symbol -A @dfn{symbol with position} is a symbol, the @dfn{bare symbol}, -together with an unsigned integer called the @dfn{position}. These -objects are intended for use by the byte compiler, which records in -them the position of each symbol occurrence and uses those positions -in warning and error messages. - -The printed representation of a symbol with position uses the hash -notation outlined in @ref{Printed Representation}. It looks like -@samp{#}. It has no read syntax. You can cause -just the bare symbol to be printed by binding the variable -@code{print-symbols-bare} to non-@code{nil} around the print -operation. The byte compiler does this before writing its output to -the compiled Lisp file. - -For most purposes, when the flag variable -@code{symbols-with-pos-enabled} is non-@code{nil}, symbols with -positions behave just as bare symbols do. For example, @samp{(eq -# foo)} has a value @code{t} when that variable -is set (but nil when it isn't set). Most of the time in Emacs this -variable is @code{nil}, but the byte compiler binds it to @code{t} -when it runs. - -Typically, symbols with position are created by the byte compiler -calling the reader function @code{read-positioning-symbols} -(@pxref{Input Functions}). One can also be created with the function -@code{position-symbol}. - -@defvar symbols-with-pos-enabled -When this variable is non-@code{nil}, symbols with position behave -like the contained bare symbol. Emacs runs a little more slowly in -this case. -@end defvar - -@defvar print-symbols-bare -When bound to non-nil, the Lisp printer prints only the bare symbol of -a symbol with position, ignoring the position. -@end defvar - -@defun symbol-with-pos-p symbol. -This function returns @code{t} if @var{symbol} is a symbol with -position, @code{nil} otherwise. -@end defun - -@defun bare-symbol symbol -This function returns the bare symbol contained in @var{symbol}, or -@var{symbol} itself if it is already a bare symbol. For any other -type of object, it signals an error. -@end defun - -@defun symbol-with-pos-pos symbol -This function returns the position, a number, from a symbol with -position. For any other type of object, it signals an error. -@end defun - -@defun position-symbol sym pos -Make a new symbol with position. @var{sym} is either a bare symbol or -a symbol with position, and supplies the symbol part of the new -object. @var{pos} is either an integer which becomes the number part -of the new object, or a symbol with position whose position is used. -Emacs signals an error if either argument is invalid. -@end defun diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 308407a8bf1..658108c2848 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -72,7 +72,7 @@ LOADDEFS =3D loaddefs =3D $(shell find ${srcdir} -name '*loaddefs.el' ! -name '.*') # Elisp files auto-generated. AUTOGENEL =3D ${loaddefs} ${srcdir}/cus-load.el ${srcdir}/finder-inf.el \ - ${srcdir}/subdirs.el ${srcdir}/eshell/esh-groups.el + ${srcdir}/subdirs.el ${srcdir}/eshell/esh-groups.el ${srcdir}/emacs-lisp= /cldefs.el =20 # Set load-prefer-newer for the benefit of the non-bootstrappers. BYTE_COMPILE_FLAGS =3D \ @@ -198,6 +198,26 @@ $(lisp)/loaddefs.el: --eval '(setq generated-autoload-file (expand-file-name (unmsys--file= -name "$@")))' \ -f batch-update-autoloads ${SUBDIRS_ALMOST} =20 +cldefs .PHONY: $(lisp)/emacs-lisp/cldefs.el +$(lisp)/emacs-lisp/cldefs.el: $(lisp)/emacs-lisp/cldefs.el.in + $(AM_V_GEN)$(emacs) -l pp -l "cldefs.el.in" \ + --eval "(with-temp-file (expand-file-name (unmsys--file-name \"$@\"))= \ + (insert \";; Automatically generated from cldefs.el.in. \"= \ + \"DO NOT EDIT.\n\" \ + \"(defconst cldefs-cl-lib-functions\n\" \ + \"(quote \" \ + (pp-to-string cldefs--cl-lib-functions) \ + \"))\n\" \ + \"(provide (quote cldefs))\n\" \ + \";; Local Variables:\n\" \ + \";; version-control: never\n\" \ + \";; no-byte-compile: t\n\" \ + \";; no-update-autoloads: t\n\" \ + \";; coding: utf-8-emacs-unix\n\" \ + \";; End:\n\" \ + \";;; cldefs.el ends here\n\" \ + ))" + # autoloads only runs when loaddefs.el is nonexistent, although it # generates a number of different files. Provide a force option to enable # regeneration of all these files. @@ -241,7 +261,7 @@ FORCE: .PHONY: FORCE =20 tagsfiles =3D $(shell find ${srcdir} -name '*.el' \ - ! -name '.*' ! -name '*loaddefs.el') + ! -name '.*' ! -name '*loaddefs.el' ! -name '*cldefs.el') tagsfiles :=3D $(filter-out ${srcdir}/ldefs-boot.el,${tagsfiles}) tagsfiles :=3D $(filter-out ${srcdir}/eshell/esh-groups.el,${tagsfiles}) =20 @@ -300,10 +320,6 @@ $(THEFILE)n: # subdirectories, to make sure require's and load's in the files being # compiled find the right files. =20 -.SUFFIXES: .elc .el - -# An old-fashioned suffix rule, which, according to the GNU Make manual, -# cannot have prerequisites. ifeq ($(HAVE_NATIVE_COMP),yes) ifeq ($(ANCIENT),yes) # The first compilation of compile-first, using an interpreted compiler: @@ -313,17 +329,17 @@ .SUFFIXES: # using these .elc's. This is faster than just compiling the native code # directly using the interpreted compile-first files. (Note: 1970-01-01 # fails on some systems.) -.el.elc: +%.elc: %.el $(COMPILE_FIRST:.elc=3D.el) $(top_srcdir)/src/lread.c $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \ -l comp -f batch-byte-compile $< touch -t 197101010000 $@ else -.el.elc: +%.elc: %.el $(COMPILE_FIRST:.elc=3D.el) $(top_srcdir)/src/lread.c $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \ -l comp -f batch-byte+native-compile $< endif else -.el.elc: +%.elc: %.el $(COMPILE_FIRST:.elc=3D.el) $(top_srcdir)/src/lread.c $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $< endif =20 @@ -512,7 +528,7 @@ bootstrap-clean: rm -f $(AUTOGENEL) =20 distclean: - -rm -f ./Makefile $(lisp)/loaddefs.el + -rm -f ./Makefile $(lisp)/loaddefs.el $(lisp)/emacs-lisp/cldefs.el =20 maintainer-clean: distclean bootstrap-clean rm -f TAGS diff --git a/lisp/cedet/semantic/fw.el b/lisp/cedet/semantic/fw.el index b7c3461a4d7..fd61751cb50 100644 --- a/lisp/cedet/semantic/fw.el +++ b/lisp/cedet/semantic/fw.el @@ -191,20 +191,12 @@ semantic-alias-obsolete (not (string-match "cedet" (macroexp-file-name))) ) (make-obsolete-overload oldfnalias newfn when) - (if (fboundp 'byte-compile-warn-x) - (byte-compile-warn-x - newfn - "%s: `%s' obsoletes overload `%s'" - (macroexp-file-name) - newfn - (with-suppressed-warnings ((obsolete semantic-overload-symbol-fro= m-function)) - (semantic-overload-symbol-from-function oldfnalias))) - (byte-compile-warn - "%s: `%s' obsoletes overload `%s'" - (macroexp-file-name) - newfn - (with-suppressed-warnings ((obsolete semantic-overload-symbol-from-= function)) - (semantic-overload-symbol-from-function oldfnalias)))))) + (byte-compile-warn + "%s: `%s' obsoletes overload `%s'" + (macroexp-file-name) + newfn + (with-suppressed-warnings ((obsolete semantic-overload-symbol-from-fu= nction)) + (semantic-overload-symbol-from-function oldfnalias))))) =20 (defun semantic-varalias-obsolete (oldvaralias newvar when) "Make OLDVARALIAS an alias for variable NEWVAR. @@ -217,14 +209,10 @@ semantic-varalias-obsolete (error ;; Only throw this warning when byte compiling things. (when (macroexp-compiling-p) - (if (fboundp 'byte-compile-warn-x) - (byte-compile-warn-x - newvar - "variable `%s' obsoletes, but isn't alias of `%s'" - newvar oldvaralias) - (byte-compile-warn - "variable `%s' obsoletes, but isn't alias of `%s'" - newvar oldvaralias)))))) + (byte-compile-warn + "variable `%s' obsoletes, but isn't alias of `%s'" + newvar oldvaralias) + )))) ;;; Help debugging ;; diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index 04c5b9f0808..c6d64975eca 100644 --- a/lisp/emacs-lisp/bindat.el +++ b/lisp/emacs-lisp/bindat.el @@ -804,7 +804,6 @@ bindat--type (if (or (eq label '_) (not (assq label labels))) code (macroexp-warn-and-return - code (format "Duplicate label: %S" label) code)))) (`(,_ ,val) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 25898285faa..3a5c5b41c80 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -150,29 +150,26 @@ byte-compile-inline-expand (cdr (assq name byte-compile-function-environment))))) (pcase fn ('nil - (byte-compile-warn-x name - "attempt to inline `%s' before it was defined" - name) + (byte-compile-warn "attempt to inline `%s' before it was defined" + name) form) (`(autoload . ,_) (error "File `%s' didn't define `%s'" (nth 1 fn) name)) ((and (pred symbolp) (guard (not (eq fn t)))) ;A function alias. (byte-compile-inline-expand (cons fn (cdr form)))) ((pred byte-code-function-p) - ;; (message "Inlining byte-code for %S!" name) - ;; The byte-code will be really inlined in byte-compile-unfold-bcf. (byte-compile--check-arity-bytecode form fn) `(,fn ,@(cdr form))) ((or `(lambda . ,_) `(closure . ,_)) - ;; While byte-compile-unfold-bcf can inline dynbind byte-code into - ;; letbind byte-code (or any other combination for that matter), we - ;; can only inline dynbind source into dynbind source or letbind - ;; source into letbind source. - ;; When the function comes from another file, we byte-compile - ;; the inlined function first, and then inline its byte-code. - ;; This also has the advantage that the final code does not - ;; depend on the order of compilation of ELisp files, making - ;; the build more reproducible. + ;; While byte-compile-unfold-byte-code-function can inline + ;; dynbind byte-code into letbind byte-code (or any other + ;; combination for that matter), we can only inline dynbind + ;; source into dynbind source or letbind source into letbind + ;; source. When the function comes from another file, we + ;; byte-compile the inlined function first, and then inline its + ;; byte-code. This also has the advantage that the final code + ;; does not depend on the order of compilation of ELisp files, + ;; making the build more reproducible. (if (eq fn localfn) ;; From the same file =3D> same mode. (macroexp--unfold-lambda `(,fn ,@(cdr form))) @@ -308,8 +305,8 @@ byte-optimize-form-code-walker (t form))) (`(quote . ,v) (if (or (not v) (cdr v)) - (byte-compile-warn-x form "malformed quote form: `%s'" - form)) + (byte-compile-warn "malformed quote form: `%s'" + (prin1-to-string form))) ;; Map (quote nil) to nil to simplify optimizer logic. ;; Map quoted constants to nil if for-effect (just because). (and (car v) @@ -327,9 +324,8 @@ byte-optimize-form-code-walker (cons (byte-optimize-form (car clause) nil) (byte-optimize-body (cdr clause) for-effect)) - (byte-compile-warn-x - clause "malformed cond form: `%s'" - clause) + (byte-compile-warn "malformed cond form: `%s'" + (prin1-to-string clause)) clause)) clauses))) (`(progn . ,exps) @@ -405,7 +401,8 @@ byte-optimize-form-code-walker `(while ,condition . ,body))) =20 (`(interactive . ,_) - (byte-compile-warn-x form "misplaced interactive spec: `%s'" form) + (byte-compile-warn "misplaced interactive spec: `%s'" + (prin1-to-string form)) nil) =20 (`(function . ,_) @@ -473,7 +470,7 @@ byte-optimize-form-code-walker (while args (unless (and (consp args) (symbolp (car args)) (consp (cdr args))) - (byte-compile-warn-x form "malformed setq form: %S" form)) + (byte-compile-warn "malformed setq form: %S" form)) (let* ((var (car args)) (expr (cadr args)) (lexvar (assq var byte-optimize--lexvars)) @@ -506,7 +503,8 @@ byte-optimize-form-code-walker (cons fn (mapcar #'byte-optimize-form exps))) =20 (`(,(pred (not symbolp)) . ,_) - (byte-compile-warn-x fn "`%s' is a malformed function" fn) + (byte-compile-warn "`%s' is a malformed function" + (prin1-to-string fn)) form) =20 ((guard (when for-effect @@ -514,10 +512,8 @@ byte-optimize-form-code-walker (or byte-compile-delete-errors (eq tmp 'error-free) (progn - (byte-compile-warn-x - form - "value returned from %s is unused" - form) + (byte-compile-warn "value returned from %s is unused" + (prin1-to-string form)) nil))))) (byte-compile-log " %s called for effect; deleted" fn) ;; appending a nil here might not be necessary, but it can't hurt. @@ -713,8 +709,7 @@ byte-optimize-let-form (if (symbolp binding) binding (when (or (atom binding) (cddr binding)) - (byte-compile-warn-x - binding "malformed let binding: `%S'" binding)) + (byte-compile-warn "malformed let binding: `%S'" binding)) (list (car binding) (byte-optimize-form (nth 1 binding) nil)))) (car form)) @@ -1197,7 +1192,7 @@ byte-optimize-if =20 (defun byte-optimize-while (form) (when (< (length form) 2) - (byte-compile-warn-x form "too few arguments for `while'")) + (byte-compile-warn "too few arguments for `while'")) (if (nth 1 form) form)) =20 @@ -1235,10 +1230,9 @@ byte-optimize-apply (let ((butlast (nreverse (cdr (reverse (cdr (cdr form))))))) (nconc (list 'funcall fn) butlast (mapcar (lambda (x) (list 'quote x)) (nth 1 last)))) - (byte-compile-warn-x - last + (byte-compile-warn "last arg to apply can't be a literal atom: `%s'" - last) + (prin1-to-string last)) nil)) form)))) =20 diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 110f7e4abf4..e1fc5513091 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -30,83 +30,6 @@ =20 ;;; Code: =20 -(defvar byte-run--ssp-seen nil - "Which conses/vectors/records have been processed in strip-symbol-positi= ons? -The value is a hash table, the key being the old element and the value bei= ng -the corresponding new element of the same type. - -The purpose of this is to detect circular structures.") - -(defalias 'byte-run--circular-list-p - #'(lambda (l) - "Return non-nil when the list L is a circular list. -Note that this algorithm doesn't check any circularity in the -CARs of list elements." - (let ((hare l) - (tortoise l)) - (condition-case err - (progn - (while (progn - (setq hare (cdr (cdr hare)) - tortoise (cdr tortoise)) - (not (or (eq tortoise hare) - (null hare))))) - (eq tortoise hare)) - (wrong-type-argument nil) - (error (signal (car err) (cdr err))))))) - -(defalias 'byte-run--strip-s-p-1 - #'(lambda (arg) - "Strip all positions from symbols in ARG, modifying ARG. -Return the modified ARG." - (cond - ((symbol-with-pos-p arg) - (bare-symbol arg)) - - ((consp arg) - (let* ((round (byte-run--circular-list-p arg)) - (hash (and round (gethash arg byte-run--ssp-seen)))) - (or hash - (let ((a arg) new) - (while - (progn - (when round - (puthash a new byte-run--ssp-seen)) - (setq new (byte-run--strip-s-p-1 (car a))) - (when (not (eq new (car a))) ; For read-only things. - (setcar a new)) - (and (consp (cdr a)) - (not - (setq hash - (and round - (gethash (cdr a) byte-run--ssp-seen= )))))) - (setq a (cdr a))) - (setq new (byte-run--strip-s-p-1 (cdr a))) - (when (not (eq new (cdr a))) - (setcdr a (or hash new))) - arg)))) - - ((or (vectorp arg) (recordp arg)) - (let ((hash (gethash arg byte-run--ssp-seen))) - (or hash - (let* ((len (length arg)) - (i 0) - new) - (puthash arg arg byte-run--ssp-seen) - (while (< i len) - (setq new (byte-run--strip-s-p-1 (aref arg i))) - (when (not (eq new (aref arg i))) - (aset arg i new)) - (setq i (1+ i))) - arg)))) - - (t arg)))) - -(defalias 'byte-run-strip-symbol-positions - #'(lambda (arg) - (setq byte-run--ssp-seen (make-hash-table :test 'eq)) - (byte-run--strip-s-p-1 arg))) - (defalias 'function-put ;; We don't want people to just use `put' because we can't conveniently ;; hook into `put' to remap old properties to new ones. But for now, th= ere's @@ -115,9 +38,7 @@ 'function-put "Set FUNCTION's property PROP to VALUE. The namespace for PROP is shared with symbols. So far, FUNCTION can only be a symbol, not a lambda expression." - (put (bare-symbol function) - (byte-run-strip-symbol-positions prop) - (byte-run-strip-symbol-positions value)))) + (put function prop value))) (function-put 'defmacro 'doc-string-elt 3) (function-put 'defmacro 'lisp-indent-function 2) =20 @@ -334,7 +255,6 @@ 'defmacro (let ((f (cdr (assq (car x) macro-declarations-alist)))) (if f (apply (car f) name arglist (cdr x)) (macroexp-warn-and-return - (car x) (format-message "Unknown macro property %S in %S" (car x) name) @@ -408,7 +328,6 @@ defun nil) (t (macroexp-warn-and-return - (car x) (format-message "Unknown defun property `%S' in %S" (car x) name) nil))))) @@ -422,7 +341,7 @@ defun (cons 'prog1 (cons def declarations)) def)))) =20 - + ;; Redefined in byte-opt.el. ;; This was undocumented and unused for decades. (defalias 'inline 'progn @@ -470,8 +389,8 @@ defsubst (defun ,name ,arglist ,@body) (eval-and-compile ;; Never native-compile defsubsts as we need the byte - ;; definition in `byte-compile-unfold-bcf' to perform the - ;; inlining (Bug#42664, Bug#43280, Bug#44209). + ;; definition in `byte-compile-unfold-byte-code-function' to + ;; perform the inlining (Bug#42664, Bug#43280, Bug#44209). ,(byte-run--set-speed name nil -1) (put ',name 'byte-optimizer 'byte-compile-inline-expand)))) =20 @@ -595,7 +514,7 @@ dont-compile (declare (debug t) (indent 0) (obsolete nil "24.4")) (list 'eval (list 'quote (if (cdr body) (cons 'progn body) (car body))))) =20 - + ;; interface to evaluating things at compile time and/or load time ;; these macro must come after any uses of them in this file, as their ;; definition in the file overrides the magic definitions on the @@ -670,20 +589,20 @@ with-suppressed-warnings (append warnings byte-compile--suppressed-warnings))) (macroexpand-all (macroexp-progn body) macroexpand-all-environment)))) - + (defun byte-run--unescaped-character-literals-warning () "Return a warning about unescaped character literals. If there were any unescaped character literals in the last form read, return an appropriate warning message as a string. Otherwise, return nil. For internal use only." ;; This is called from lread.c and therefore needs to be preloaded. - (if lread--unescaped-character-literals - (let ((sorted (sort lread--unescaped-character-literals #'<))) - (format-message "unescaped character literals %s detected, %s expe= cted!" - (mapconcat (lambda (char) (format "`?%c'" char)) - sorted ", ") - (mapconcat (lambda (char) (format "`?\\%c'" char)) - sorted ", "))))) + (let ((sorted (sort lread--unescaped-character-literals #'<))) + (when sorted + (format-message "unescaped character literals %s detected, %s expect= ed!" + (mapconcat (lambda (char) (format "`?%c'" char)) + sorted ", ") + (mapconcat (lambda (char) (format "`?\\%c'" char)) + sorted ", "))))) =20 (defun byte-compile-info (string &optional message type) "Format STRING in a way that looks pleasing in the compilation output. @@ -706,7 +625,6 @@ byte-compile-info-message (declare (obsolete byte-compile-info "28.1")) (byte-compile-info (apply #'format args) t)) =20 - ;; I nuked this because it's not a good idea for users to think of using i= t. ;; These options are a matter of installation preference, and have nothing= to ;; with particular source files; it's a mistake to suggest to users diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index ff372151e1b..6252786662b 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -121,14 +121,20 @@ ;; o byte-compiled files now start with the string `;ELC'. ;; Some versions of `file' can be customized to recognize that. =20 +(eval-when-compile (require 'compile)) +(eval-when-compile (require 'cl-lib)) +(require 'cldefs nil t) ;; bootstrap-emacs won't have it in time (require 'backquote) (require 'macroexp) (require 'cconv) -(eval-when-compile (require 'compile)) -;; Refrain from using cl-lib at run-time here, since it otherwise prevents -;; us from emitting warnings when compiling files which use cl-lib without -;; requiring it! (bug#30635) -(eval-when-compile (require 'cl-lib)) + +(autoload 'cl-every "cl-extra") +(autoload 'cl-tailp "cl-extra") +(autoload 'cl-loop "cl-macs") +(autoload 'cl-some "cl-extra") +(autoload 'cl-destructuring-bind "cl-macs") +(autoload 'cl-find-if "cl-seq") +(autoload 'cl-labels "cl-macs") =20 ;; The feature of compiling in a specific target Emacs version ;; has been turned off because compile time options are a bad idea. @@ -154,15 +160,15 @@ byte-compile-dest-file-function :type '(choice (const nil) function) :version "23.2") =20 -;; This enables file name handlers such as jka-compr -;; to remove parts of the file name that should not be copied -;; through to the output file name. (defun byte-compiler-base-file-name (filename) - (let ((handler (find-file-name-handler filename - 'byte-compiler-base-file-name))) - (if handler - (funcall handler 'byte-compiler-base-file-name filename) - filename))) + "This enables file name handlers such as jka-compr +to remove parts of the file name that should not be copied +through to the output file name." + (if-let ((handler (find-file-name-handler + filename + 'byte-compiler-base-file-name))) + (funcall handler 'byte-compiler-base-file-name filename) + filename)) =20 ;; Sadly automake relies on this misfeature up to at least version 1.15.1. (if (fboundp 'byte-compile-dest-file) @@ -460,61 +466,46 @@ byte-compile-free-assignments =20 (defvar byte-compiler-error-flag) =20 -(defun byte-compile-recurse-toplevel (form non-toplevel-case) - "Implement `eval-when-compile' and `eval-and-compile'. -Return the compile-time value of FORM." - ;; Macroexpand (not macroexpand-all!) form at toplevel in case it - ;; expands into a toplevel-equivalent `progn'. See CLHS section - ;; 3.2.3.1, "Processing of Top Level Forms". The semantics are very - ;; subtle: see test/lisp/emacs-lisp/bytecomp-tests.el for interesting - ;; cases. - (let ((print-symbols-bare t)) ; Possibly redundant binding. - (setf form (macroexp-macroexpand form byte-compile-macro-environment))) - (if (eq (car-safe form) 'progn) - (cons 'progn - (mapcar (lambda (subform) - (byte-compile-recurse-toplevel - subform non-toplevel-case)) - (cdr form))) - (funcall non-toplevel-case form))) +(defun byte-compile-maybe-expand (form func) + "Macroexpansion of top-level FORM could yield a progn. +See CLHS section 3.2.3.1, *Processing of Top Level Forms*, and +bytecomp-tests.el for interesting cases." + (let ((form* (macroexp-macroexpand form byte-compile-macro-environment))) + (if (eq (car-safe form*) 'progn) + (cons 'progn + (mapcar (lambda (sexpr) + (byte-compile-maybe-expand sexpr func)) + (cdr form*))) + (funcall func form*)))) =20 (defconst byte-compile-initial-macro-environment - `( - ;; (byte-compiler-options . (lambda (&rest forms) - ;; (apply 'byte-compiler-options-handler forms))) - (declare-function . byte-compile-macroexpand-declare-function) + `((declare-function . byte-compile-macroexpand-declare-function) (eval-when-compile . ,(lambda (&rest body) - (let ((result nil)) - (byte-compile-recurse-toplevel + (let (result) + (byte-compile-maybe-expand (macroexp-progn body) (lambda (form) - ;; Insulate the following variables - ;; against changes made in the - ;; subsidiary compilation. This - ;; prevents spurious warning - ;; messages: "not defined at runtime" - ;; etc. + ;; Sandbox these defvars to forestall "not + ;; defined at runtime" errors (let ((byte-compile-unresolved-functions byte-compile-unresolved-functions) (byte-compile-new-defuns byte-compile-new-defuns)) (setf result (byte-compile-eval - (byte-compile-top-level - (byte-compile-preprocess form)= )))))) + (byte-compile-top-level + (byte-compile-preprocess form))= ))))) (list 'quote result)))) (eval-and-compile . ,(lambda (&rest body) - (byte-compile-recurse-toplevel + (byte-compile-maybe-expand (macroexp-progn body) (lambda (form) - ;; Don't compile here, since we don't know - ;; whether to compile as byte-compile-form - ;; or byte-compile-file-form. - (let* ((print-symbols-bare t) ; Possibly red= undant binding. - (expanded - (macroexpand--all-toplevel - form - macroexpand-all-environment))) + ;; Don't compile since we don't know + ;; byte-compile-form or byte-compile-file-fo= rm. + (let ((expanded + (macroexpand--all-top-level + form + macroexpand-all-environment))) (eval expanded lexical-binding) expanded))))) (with-suppressed-warnings @@ -592,7 +583,7 @@ byte-compile-maxdepth ;; - `byte-compile-lambda' to obtain arglist doc and interactive spec ;; af any lambda compiled (including anonymous). ;; -;; - `byte-compile-file-form-defmumble' to obtain the list of +;; - `byte-compile-file-form-defalias*' to obtain the list of ;; top-level forms as they would be outputted in the .elc file. ;; =20 @@ -622,7 +613,7 @@ byte-to-native-output-buffer-file (defvar byte-to-native-plist-environment nil "To spill `overriding-plist-environment'.") =20 - + ;;; The byte codes; this information is duplicated in bytecomp.c =20 (defvar byte-code-vector nil @@ -649,7 +640,7 @@ byte-defop (aset v2 opcode stack-adjust)) (if docstring (list 'defconst opname opcode (concat "Byte code opcode " docstring = ".")) - (list 'defconst opname opcode))) + (list 'defconst opname opcode))) =20 (defmacro byte-extrude-byte-code-vectors () (prog1 (list 'setq 'byte-code-vector @@ -861,7 +852,7 @@ byte-goto-ops (defconst byte-goto-always-pop-ops '(byte-goto-if-nil byte-goto-if-not-nil= )) =20 (byte-extrude-byte-code-vectors) - + ;;; lapcode generator ;; ;; the byte-compiler now does source -> lapcode -> bytecode instead of @@ -1021,7 +1012,7 @@ byte-compile-lapcode byte-to-native-lambdas-h)) bytecode))) =20 - + ;;; compile-time evaluation =20 (defun byte-compile-eval (form) @@ -1053,13 +1044,10 @@ byte-compile-eval-before-compile "Evaluate FORM for `eval-and-compile'." (let ((hist-nil-orig current-load-list)) (prog1 (eval form lexical-binding) - ;; (eval-and-compile (require 'cl) turns off warnings for cl functio= ns. - ;; FIXME Why does it do that - just as a hack? - ;; There are other ways to do this nowadays. (let ((tem current-load-list)) (while (not (eq tem hist-nil-orig)) (setq tem (cdr tem))))))) - + ;;; byte compiler messages =20 (defun emacs-lisp-compilation-file-name-or-buffer (str) @@ -1106,11 +1094,16 @@ emacs-lisp-compilation-recompile (error "Only files can be recompiled")) (byte-compile-file emacs-lisp-compilation--current-file)) =20 -(defvar byte-compile-current-form nil) +;; Single thread makes global variables possible. +;; Global variables make programming easy. +(defvar byte-compile-current-func nil) (defvar byte-compile-dest-file nil) (defvar byte-compile-current-file nil) (defvar byte-compile-current-group nil) (defvar byte-compile-current-buffer nil) +(defvar byte-compile-current-annotations nil) +(defvar byte-compile-current-form nil) +(defvar byte-compile-current-charpos nil) =20 ;; Log something that isn't a warning. (defmacro byte-compile-log (format-string &rest args) @@ -1127,8 +1120,8 @@ byte-compile-log (lambda (x) (if (symbolp x) (list 'prin1-to-string x) x)) args)))))) =20 -;; Log something that isn't a warning. (defun byte-compile-log-1 (string) + "Log something that isn't a warning." (with-current-buffer byte-compile-log-buffer (let ((inhibit-read-only t)) (goto-char (point-max)) @@ -1150,55 +1143,16 @@ byte-compile-delete-first (setcdr list (cddr list))) total))) =20 -(defvar byte-compile-last-warned-form nil) +(defvar byte-compile-last-warned-func nil) (defvar byte-compile-last-logged-file nil) (defvar byte-compile-root-dir nil "Directory relative to which file names in error messages are written.") =20 -;; FIXME: We should maybe extend abbreviate-file-name with an optional DIR -;; argument to try and use a relative file-name. (defun byte-compile-abbreviate-file (file &optional dir) (let ((f1 (abbreviate-file-name file)) (f2 (file-relative-name file dir))) (if (< (length f2) (length f1)) f2 f1))) =20 -(defun byte-compile--first-symbol (form) - "Return the \"first\" symbol found in form, or 0 if there is none. -Here, \"first\" is by a depth first search." - (let (sym) - (cond - ((symbolp form) form) - ((consp form) - (or (and (symbolp (setq sym (byte-compile--first-symbol (car form)))) - sym) - (and (symbolp (setq sym (byte-compile--first-symbol (cdr form)))) - sym) - 0)) - ((and (vectorp form) - (> (length form) 0)) - (let ((i 0) - (len (length form)) - elt) - (catch 'sym - (while (< i len) - (when (symbolp - (setq elt (byte-compile--first-symbol (aref form i)))) - (throw 'sym elt)) - (setq i (1+ i))) - 0))) - (t 0)))) - -(defun byte-compile--warning-source-offset () - "Return a source offset from `byte-compile-form-stack'. -Return nil if such is not found." - (catch 'offset - (dolist (form byte-compile-form-stack) - (let ((s (byte-compile--first-symbol form))) - (if (symbol-with-pos-p s) - (throw 'offset (symbol-with-pos-pos s))))))) - -;; This is used as warning-prefix for the compiler. -;; It is always called with the warnings buffer current. (defun byte-compile-warning-prefix (level entry) (let* ((inhibit-read-only t) (dir (or byte-compile-root-dir default-directory)) @@ -1208,36 +1162,36 @@ byte-compile-warning-prefix ((bufferp byte-compile-current-file) (format "Buffer %s:" (buffer-name byte-compile-current-file))) - ;; We might be simply loading a file that - ;; contains explicit calls to byte-compile functions. ((stringp load-file-name) + ;; a file containing explicit calls to compiled functions. (format "%s:" (byte-compile-abbreviate-file load-file-name dir))) (t ""))) - (offset (byte-compile--warning-source-offset)) - (pos (if (and byte-compile-current-file - (or offset (not symbols-with-pos-enabled))) - (with-current-buffer byte-compile-current-buffer - (let (new-l new-c) - (save-excursion - (goto-char offset) - (setq new-l (1+ (count-lines (point-min) (point-at= -bol))) - new-c (1+ (current-column))) - (format "%d:%d:" new-l new-c)))) - "")) - (form (if (eq byte-compile-current-form :end) "end of data" - (or byte-compile-current-form "toplevel form")))) + (annot (if-let ((byte-compile-current-file byte-compile-current-file) + (charpos (or byte-compile-current-charpos + (byte-compile-fuzzy-charpos)))) + (with-current-buffer byte-compile-current-buffer + (apply #'format "%d:%d:" + (save-excursion + (goto-char charpos) + (list (1+ (count-lines (point-min) (point-at-bol))) + ;; `next-error' uses one-indexed colu= mn + (1+ (current-column)))))) + "")) + (form (if (eq byte-compile-current-func :end) + "end of data" + (or byte-compile-current-func "toplevel form")))) (when (or (and byte-compile-current-file (not (equal byte-compile-current-file byte-compile-last-logged-file))) - (and byte-compile-current-form - (not (eq byte-compile-current-form - byte-compile-last-warned-form)))) + (and byte-compile-current-func + (not (eq byte-compile-current-func + byte-compile-last-warned-func)))) (insert (format "\nIn %s:\n" form))) (when level - (insert (format "%s%s " file pos)))) + (insert (format "%s%s " file annot)))) (setq byte-compile-last-logged-file byte-compile-current-file - byte-compile-last-warned-form byte-compile-current-form) + byte-compile-last-warned-func byte-compile-current-func) entry) =20 ;; This no-op function is used as the value of warning-series @@ -1283,7 +1237,7 @@ byte-compile-log-file (insert (format-message "Entering directory `%s'\n" default-directory)))) (setq byte-compile-last-logged-file byte-compile-current-file - byte-compile-last-warned-form nil) + byte-compile-last-warned-func nil) ;; Do this after setting default-directory. (unless (derived-mode-p 'compilation-mode) (emacs-lisp-compilation-mode)) @@ -1298,49 +1252,39 @@ byte-compile-log-warning-function message describing the problem. POSITION is a buffer position where the problem was detected. FILL is a prefix as in `warning-fill-prefix'. LEVEL is the level of the -problem (`:warning' or `:error'). FILL and LEVEL may be nil.") +problem (`:warning' or `:error'). POSITION, FILL and LEVEL may +be nil.") =20 (defun byte-compile-log-warning (string &optional fill level) "Log a byte-compilation warning. -STRING, FILL and LEVEL are as described in -`byte-compile-log-warning-function', which see." +SYM, STRING, FILL and LEVEL are as described in +`byte-compile-log-warning-function'." (funcall byte-compile-log-warning-function string - (or (byte-compile--warning-source-offset) - (point)) + 'unused fill level)) =20 -(defun byte-compile--log-warning-for-byte-compile (string _position - &optional - fill - level) +(defun byte-compile--log-warning-for-byte-compile + (string &optional _position fill level) "Log a message STRING in `byte-compile-log-buffer'. Also log the current function and file if not already done. If FILL is non-nil, set `warning-fill-prefix' to four spaces. LEVEL is the warning level (`:warning' or `:error'). Do not call this function directly; use `byte-compile-warn' or `byte-compile-report-error' instead." - (let ((warning-prefix-function 'byte-compile-warning-prefix) - (warning-type-format "") - (warning-fill-prefix (if fill " "))) + (let* ((warning-prefix-function #'byte-compile-warning-prefix) + (warning-type-format "") + (warning-fill-prefix (when fill " "))) (display-warning 'bytecomp string level byte-compile-log-buffer))) =20 (defun byte-compile-warn (format &rest args) "Issue a byte compiler warning; use (format-message FORMAT ARGS...) for = message." (setq format (apply #'format-message format args)) (if byte-compile-error-on-warn - (error "%s" format) ; byte-compile-file catches and logs it + (error "%s" format) (byte-compile-log-warning format t :warning))) =20 -(defun byte-compile-warn-x (arg format &rest args) - "Issue a byte compiler warning. -ARG is the source element (likely a symbol with position) central to - the warning, intended to supply source position information. -FORMAT and ARGS are as in `byte-compile-warn'." - (let ((byte-compile-form-stack (cons arg byte-compile-form-stack))) - (apply #'byte-compile-warn format args))) - (defun byte-compile-warn-obsolete (symbol) "Warn that SYMBOL (a variable or function) is obsolete." (when (byte-compile-warning-enabled-p 'obsolete symbol) @@ -1349,27 +1293,29 @@ byte-compile-warn-obsolete symbol (or funcp (get symbol 'byte-obsolete-variable)) (if funcp "function" "variable")))) - (unless (and funcp (memq symbol byte-compile-not-obsolete-funcs)) - (byte-compile-warn-x symbol "%s" msg))))) + (when (or (not funcp) + (not (memq symbol byte-compile-not-obsolete-funcs))) + (byte-compile-warn "%s" msg))))) =20 -(defun byte-compile-report-error (error-info &optional fill) +(defun byte-compile-report-error (err &optional fill) "Report Lisp error in compilation. -ERROR-INFO is the error data, in the form of either (ERROR-SYMBOL . DATA) +ERR is the error data, in the form of either (ERROR-SYMBOL . DATA) or STRING. If FILL is non-nil, set `warning-fill-prefix' to four spaces when printing the error message." (setq byte-compiler-error-flag t) (byte-compile-log-warning - (if (stringp error-info) error-info - (error-message-string error-info)) + (if (stringp err) + err + (error-message-string err)) fill :error)) - + ;;; sanity-checking arglists =20 (defun byte-compile-fdefinition (name macro-p) - ;; If a function has an entry saying (FUNCTION . t). - ;; that means we know it is defined but we don't know how. - ;; If a function has an entry saying (FUNCTION . nil), - ;; that means treat it as not defined. + "If a function has an entry saying (FUNCTION . t). +that means we know it is defined but we don't know how. +If a function has an entry saying (FUNCTION . nil), +that means treat it as not defined." (let* ((list (if macro-p byte-compile-macro-environment byte-compile-function-environment)) @@ -1452,33 +1398,93 @@ byte-compile-arglist-signature-string (format "%d" (car signature))) (t (format "%d-%d" (car signature) (cdr signature))))) =20 +(defun byte-compile-fuzzy-charpos () + "Hack prevailing globals for prevailing charpos." + (let ((memo-count (make-hash-table :test #'equal))) + (cl-labels ((recurse-count + (form) + (with-memoization + (gethash form memo-count) + (cond ((circular-list-p form) (safe-length form)) + ((or (atom form) + (or (eq 'quote (car form)) + (eq 'backquote (car form)) + (eq '\` (car form)) + (eq 'function (car form)))) + 1) + (t (cl-loop for element in form + collect (recurse-count element) into= result + finally return (apply #'+ result))))= ))) + (let ((match-count (recurse-count byte-compile-current-form))) + (cl-labels ((recurse + (form) + (cl-loop for element in form + for count =3D (recurse-count + (byte-compile--decouple elemen= t #'cdr)) + if (>=3D match-count count) + collect element + else + append (recurse element) + end)) + (first-atom + (form) + (cond ((atom form) form) + (t (cl-some #'first-atom form)))) + (listify + (form) + (if (atom form) + (list form) + (unless (circular-list-p form) + (cl-loop for element in form + collect element))))) + (cl-loop with result + with best-score =3D 0 + with best-milieu =3D 0 + with matches =3D + (sort (recurse (list byte-compile-current-annotations)) + (lambda (x y) + (> (safe-length x) (safe-length y)))) + for match in matches + for match* =3D (byte-compile--decouple match #'cdr) + for cand-milieu =3D (if (atom match*) 1 (safe-length ma= tch*)) + for cand-score =3D + (cl-loop for w in (listify match*) + count (member w (listify byte-compile-current-= form))) + when (and (>=3D cand-score best-score) + (or (not (=3D cand-milieu best-milieu)) + (not (=3D cand-score best-score)))) + do (setq result match + best-score cand-score + best-milieu cand-milieu) + finally return (or (first-atom result) + (first-atom byte-compile-current-ann= otations)))))))) + (defun byte-compile-function-warn (f nargs def) + "Record unresolved F or inconsistent arity NARGS. +F is considered resolved if auxiliary DEF includes it." (when (and (get f 'byte-obsolete-info) (byte-compile-warning-enabled-p 'obsolete f)) (byte-compile-warn-obsolete f)) - - ;; Check to see if the function will be available at runtime - ;; and/or remember its arity if it's unknown. - (or (and (or def (fboundp f)) ; might be a subr or autoload. - (not (memq f byte-compile-noruntime-functions))) - (eq f byte-compile-current-form) ; ## This doesn't work - ; with recursion. - ;; It's a currently-undefined function. - ;; Remember number of args in call. - (let ((cons (assq f byte-compile-unresolved-functions))) - (if cons - (or (memq nargs (cddr cons)) - (push nargs (cddr cons))) - (push (list f - (if (symbol-with-pos-p f) - (symbol-with-pos-pos f) - 1) ; Should never happen. - nargs) - byte-compile-unresolved-functions))))) + (when (and (or (and (not def) (not (fboundp f))) + (and (boundp 'cldefs-cl-lib-functions) + (memq f cldefs-cl-lib-functions) + ;; consider defining cl-incf as resolving all cl-lib + (not (memq 'cl-incf byte-compile-new-defuns))) + (memq f byte-compile-noruntime-functions)) + (not (eq f byte-compile-current-func))) + (let ((cell (assq f byte-compile-unresolved-functions))) + (if cell + (unless (memq nargs (cddr cell)) + ;; flag an inconsistent arity + (push nargs (cddr cell))) + (push (list f + (let ((byte-compile-current-form f)) + (byte-compile-fuzzy-charpos)) + nargs) + byte-compile-unresolved-functions))))) =20 (defun byte-compile-emit-callargs-warn (name actual-args min-args max-args) - (byte-compile-warn-x - name + (byte-compile-warn "%s called with %d argument%s, but %s %s" name actual-args (if (=3D 1 actual-args) "" "s") @@ -1544,21 +1550,21 @@ byte-compile-format-warn n))) (nargs (- (length form) 2))) (unless (=3D nargs nfields) - (byte-compile-warn-x (car form) + (byte-compile-warn "`%s' called with %d args to fill %d format field(s)" (car form) nargs nfields))))) =20 (dolist (elt '(format message error)) (put elt 'byte-compile-format-like t)) =20 -;; Warn if a custom definition fails to specify :group, or :type. (defun byte-compile-nogroup-warn (form) + "Warn if a custom definition fails to specify :group, or :type." (let ((keyword-args (cdr (cdr (cdr (cdr form))))) (name (cadr form))) (when (eq (car-safe name) 'quote) (or (not (eq (car form) 'custom-declare-variable)) (plist-get keyword-args :type) - (byte-compile-warn-x (cadr name) + (byte-compile-warn "defcustom for `%s' fails to specify type" (cadr name))) (if (and (memq (car form) '(custom-declare-face custom-declare-varia= ble)) byte-compile-current-group) @@ -1567,7 +1573,7 @@ byte-compile-nogroup-warn (or (and (eq (car form) 'custom-declare-group) (equal name ''emacs)) (plist-get keyword-args :group) - (byte-compile-warn-x (cadr name) + (byte-compile-warn "%s for `%s' fails to specify containing group" (cdr (assq (car form) '((custom-declare-group . defgroup) @@ -1575,35 +1581,33 @@ byte-compile-nogroup-warn (custom-declare-variable . defcustom)))) (cadr name))) ;; Update the current group, if needed. - (if (and byte-compile-current-file ;Only when compiling a whole file. - (eq (car form) 'custom-declare-group)) - (setq byte-compile-current-group (cadr name))))))) + (when (and byte-compile-current-file ;Only when compiling a whole file. + (eq (car form) 'custom-declare-group)) + (setq byte-compile-current-group (cadr name))))))) =20 -;; Warn if the function or macro is being redefined with a different -;; number of arguments. (defun byte-compile-arglist-warn (name arglist macrop) - ;; This is the first definition. See if previous calls are compatible. + "Warn if the function or macro is being redefined with a different +number of arguments." (let ((calls (assq name byte-compile-unresolved-functions)) nums sig min max) (when (and calls macrop) - (byte-compile-warn-x name "macro `%s' defined too late" name)) + (byte-compile-warn "macro `%s' defined too late" name)) (setq byte-compile-unresolved-functions (delq calls byte-compile-unresolved-functions)) - (setq calls (delq t calls)) ;Ignore higher-order uses of the func= tion. + (setq calls (delq t calls)) ; Ignore higher-order uses of the function. (when (cddr calls) (when (and (symbolp name) (eq (function-get name 'byte-optimizer) 'byte-compile-inline-expand)) - (byte-compile-warn-x name "defsubst `%s' was used before it was de= fined" - name)) + (byte-compile-warn "defsubst `%s' was used before it was defined" + name)) (setq sig (byte-compile-arglist-signature arglist) nums (sort (copy-sequence (cddr calls)) (function <)) min (car nums) max (car (nreverse nums))) (when (or (< min (car sig)) (and (cdr sig) (> max (cdr sig)))) - (byte-compile-warn-x - name + (byte-compile-warn "%s being defined to take %s%s, but was previously called with %s" name (byte-compile-arglist-signature-string sig) @@ -1613,16 +1617,15 @@ byte-compile-arglist-warn (initial (and macrop (cdr (assq name byte-compile-initial-macro-environment))= ))) - ;; Assumes an element of b-c-i-macro-env that is a symbol points - ;; to a defined function. (Bug#8646) - (and initial (symbolp initial) - (setq old (byte-compile-fdefinition initial nil))) + (when (and initial (symbolp initial)) + ;; Assume a symbol in byte-compile-initial-macro-env points to a + ;; defined function. (Bug#8646) + (setq old (byte-compile-fdefinition initial nil))) (when (and old (not (eq old t))) (let ((sig1 (byte-compile--function-signature old)) (sig2 (byte-compile-arglist-signature arglist))) (unless (byte-compile-arglist-signatures-congruent-p sig1 sig2) - (byte-compile-warn-x - name + (byte-compile-warn "%s %s used to take %s %s, now takes %s" (if macrop "macro" "function") name @@ -1711,41 +1714,35 @@ byte-compile-docstring-length-warn (setq name (if name (format " `%s' " name) "")) (when (and kind docs (stringp docs) (byte-compile--wide-docstring-p docs col)) - (byte-compile-warn-x - name - "%s%sdocstring wider than %s characters" - kind name col)))) + (byte-compile-warn "%s%sdocstring wider than %s characters" + kind name col)))) form) =20 -;; If we have compiled any calls to functions which are not known to be -;; defined, issue a warning enumerating them. -;; `unresolved' in the list `byte-compile-warnings' disables this. (defun byte-compile-warn-about-unresolved-functions () - (when (byte-compile-warning-enabled-p 'unresolved) - (let ((byte-compile-current-form :end)) - ;; Separate the functions that will not be available at runtime - ;; from the truly unresolved ones. - (dolist (urf byte-compile-unresolved-functions) - (let ((f (car urf))) - (when (not (memq f byte-compile-new-defuns)) - (byte-compile-warn-x - f - (if (fboundp f) "the function `%s' might not be defined at ru= ntime." "the function `%s' is not known to be defined.") - (car urf))))))) - nil) - - -;; Dynamically bound in byte-compile-from-buffer. -;; NB also used in cl.el and cl-macs.el. -(defvar byte-compile--outbuffer) + "Separate the functions that will not be available at runtime +from the truly unresolved ones." + (prog1 nil + (when (byte-compile-warning-enabled-p 'unresolved) + (let ((byte-compile-current-func :end)) + (dolist (urf byte-compile-unresolved-functions) + (cl-destructuring-bind (f charpos &rest args) + urf + (unless (memq f byte-compile-new-defuns) + (let ((byte-compile-current-charpos charpos)) + (byte-compile-warn + (if (fboundp f) + "the function `%s' might not be defined at runtime." + "the function `%s' is not known to be defined.") + f))))))))) + + +(defvar byte-compile--outbuffer + "Dynamically bound in byte-compile-from-buffer, and used in cl.el +and cl-macs.el.") =20 (defmacro byte-compile-close-variables (&rest body) (declare (debug t)) - `(let (;; - ;; Close over these variables to encapsulate the - ;; compilation state - ;; - (byte-compile-macro-environment + `(let ((byte-compile-macro-environment ;; Copy it because the compiler may patch into the ;; macroenvironment. (copy-alist byte-compile-initial-macro-environment)) @@ -1787,8 +1784,7 @@ displaying-byte-compile-warnings (warning-series-started (and (markerp warning-series) (eq (marker-buffer warning-series) - (get-buffer byte-compile-log-buffer)))) - (byte-compile-form-stack byte-compile-form-stack)) + (get-buffer byte-compile-log-buffer))))) (if (or (eq warning-series 'byte-compile-warning-series) warning-series-started) ;; warning-series does come from compilation, @@ -1800,19 +1796,19 @@ displaying-byte-compile-warnings (setq warning-series (or tem 'byte-compile-warning-series))) (if byte-compile-debug (funcall --displaying-byte-compile-warnings-fn) - (condition-case error-info + (condition-case err (funcall --displaying-byte-compile-warnings-fn) - (error (byte-compile-report-error error-info))))) + (error (byte-compile-report-error err))))) ;; warning-series does not come from compilation, so bind it. (let ((warning-series ;; Log the file name. Record position of that text. (or (byte-compile-log-file) 'byte-compile-warning-series))) (if byte-compile-debug (funcall --displaying-byte-compile-warnings-fn) - (condition-case error-info + (condition-case err (funcall --displaying-byte-compile-warnings-fn) - (error (byte-compile-report-error error-info)))))))) - + (error (byte-compile-report-error err)))))))) + ;;;###autoload (defun byte-force-recompile (directory) "Recompile every `.el' file in DIRECTORY that already has a `.elc' file. @@ -2169,12 +2165,12 @@ byte-compile-file target-file)))))) (unless byte-native-compiling (kill-buffer (current-buffer)))) - (if (and byte-compile-generate-call-tree - (or (eq t byte-compile-generate-call-tree) - (y-or-n-p (format "Report call tree for %s? " - filename)))) - (save-excursion - (display-call-tree filename))) + (when (and byte-compile-generate-call-tree + (or (eq t byte-compile-generate-call-tree) + (y-or-n-p (format "Report call tree for %s? " + filename)))) + (save-excursion + (display-call-tree filename))) (let ((gen-dynvars (getenv "EMACS_GENERATE_DYNVARS"))) (when (and gen-dynvars (not (equal gen-dynvars "")) byte-compile--seen-defvars) @@ -2184,8 +2180,8 @@ byte-compile-file (dolist (var (delete-dups byte-compile--seen-defvars)) (insert (format "%S\n" (cons var filename)))) (write-region (point-min) (point-max) dynvar-file))))) - (if load - (load target-file)) + (when load + (load target-file)) t)))) =20 ;;; compiling a single function @@ -2198,39 +2194,34 @@ compile-defun (save-excursion (end-of-defun) (beginning-of-defun) - (let* ((print-symbols-bare t) ; For the final `message'. - (byte-compile-current-file (current-buffer)) + (let* ((byte-compile-current-file (current-buffer)) (byte-compile-current-buffer (current-buffer)) - (start-read-position (point)) - (byte-compile-last-warned-form 'nothing) - (symbols-with-pos-enabled t) + (point (point)) + (byte-compile-last-warned-func 'nothing) (value (eval (displaying-byte-compile-warnings - (byte-compile-sexp - (let ((form (read-positioning-symbols (current-buffer= )))) - (push form byte-compile-form-stack) - (eval-sexp-add-defvars - form - start-read-position)))) + (let* ((byte-compile-current-annotations + (read-annotated (current-buffer))) + (form (byte-compile--decouple + byte-compile-current-annotations + #'cdr))) + (byte-compile-sexp (eval-sexp-add-defvars form point)))) lexical-binding))) (cond (arg (message "Compiling from buffer... done.") (prin1 value (current-buffer)) (insert "\n")) - ((message "%s" (prin1-to-string value))))))) + (t + (message "%s" (prin1-to-string value))))))) =20 (defun byte-compile-from-buffer (inbuffer) (let ((byte-compile-current-buffer inbuffer) - ;; Prevent truncation of flonums and lists as we read and print them - (float-output-format nil) (case-fold-search nil) - (print-length nil) + ;; Prevent truncation flonums + (float-output-format nil) + ;; Prevent truncation lists (print-level nil) - (print-symbols-bare t) - ;; Prevent edebug from interfering when we compile - ;; and put the output into a file. -;; (edebug-all-defs nil) -;; (edebug-all-forms nil) + (print-length nil) ;; Simulate entry to byte-compile-top-level (byte-compile-jump-tables nil) (byte-compile-constants nil) @@ -2238,10 +2229,7 @@ byte-compile-from-buffer (byte-compile-tag-number 0) (byte-compile-depth 0) (byte-compile-maxdepth 0) - (byte-compile-output nil) - ;; #### This is bound in b-c-close-variables. - ;; (byte-compile-warnings byte-compile-warnings) - (symbols-with-pos-enabled t)) + (byte-compile-output nil)) (byte-compile-close-variables (with-current-buffer (setq byte-compile--outbuffer @@ -2251,21 +2239,19 @@ byte-compile-from-buffer (format "-%s" (1- byte-compile-level)))))) (set-buffer-multibyte t) (erase-buffer) - ;; (emacs-lisp-mode) (setq case-fold-search nil)) (displaying-byte-compile-warnings (with-current-buffer inbuffer - (and byte-compile-current-file - (byte-compile-insert-header byte-compile-current-file - byte-compile--outbuffer)) + (when byte-compile-current-file + (byte-compile-insert-header byte-compile-current-file + byte-compile--outbuffer)) (goto-char (point-min)) - ;; Should we always do this? When calling multiple files, it - ;; would be useful to delay this warning until all have been - ;; compiled. A: Yes! b-c-u-f might contain dross from a - ;; previous byte-compile. + + ;; Reset globals from previous byte-compile. (setq byte-compile-unresolved-functions nil) (setq byte-compile-noruntime-functions nil) (setq byte-compile-new-defuns nil) + (when byte-native-compiling (defvar native-comp-speed) (push `(native-comp-speed . ,native-comp-speed) byte-native-qual= ities) @@ -2281,22 +2267,20 @@ byte-compile-from-buffer (push `(no-native-compile . ,no-native-compile) byte-native-qualities)) =20 - ;; Compile the forms from the input buffer. - (while (progn + (while (progn (while (progn (skip-chars-forward " \t\n\^l") (=3D (following-char) ?\;)) (forward-line 1)) (not (eobp))) - (let* ((lread--unescaped-character-literals nil) - ;; Don't bind `load-read-function' to - ;; `read-positioning-symbols' here. Calls to `read' - ;; at a lower level must not get symbols with - ;; position. - (form (read-positioning-symbols inbuffer)) - (warning (byte-run--unescaped-character-literals-warning)= )) - (when warning (byte-compile-warn-x form "%s" warning)) - (byte-compile-toplevel-file-form form))) - ;; Compile pending forms at end of file. + (let* ((byte-compile-current-annotations (read-annotated inbuffe= r)) + (form (byte-compile--decouple byte-compile-current-annota= tions + #'cdr))) + (byte-compile-maybe-expand + form + (lambda (form*) + (let (byte-compile-current-func) + (byte-compile-file-form + (byte-compile-preprocess form*))))))) (byte-compile-flush-pending) (byte-compile-warn-about-unresolved-functions))) byte-compile--outbuffer))) @@ -2345,24 +2329,20 @@ byte-compile-insert-header "\n\n")))) =20 (defun byte-compile-output-file-form (form) - ;; Write the given form to the output buffer, being careful of docstrings - ;; in defvar, defvaralias, defconst, autoload and - ;; custom-declare-variable because make-docfile is so amazingly stupid. - ;; defalias calls are output directly by byte-compile-file-form-defmumbl= e; - ;; it does not pay to first build the defalias in defmumble and then par= se - ;; it here. + "Write FORM to output buffer, being careful of +docstrings in defvar, defvaralias, defconst, autoload and +custom-declare-variable because make-docfile is so amazingly +stupid (and also obsolete)." (when byte-native-compiling ;; Spill output for the native compiler here (push (make-byte-to-native-top-level :form form :lexical lexical-bindi= ng) byte-to-native-top-level-forms)) - (let ((print-symbols-bare t) ; Possibly redundant binding. - (print-escape-newlines t) + (let ((print-escape-newlines t) (print-length nil) (print-level nil) (print-quoted t) (print-gensym t) - (print-circle ; Handle circular data structures. - (not byte-compile-disable-print-circle))) + (print-circle (not byte-compile-disable-print-circle))) (if (and (memq (car-safe form) '(defvar defvaralias defconst autoload custom-declare-variable)) (stringp (nth 3 form))) @@ -2371,8 +2351,7 @@ byte-compile-output-file-form '(defvaralias autoload custom-declare-variable))) (princ "\n" byte-compile--outbuffer) - (prin1 form byte-compile--outbuffer) - nil))) + (prin1 form byte-compile--outbuffer)))) =20 (defvar byte-compile--for-effect) =20 @@ -2386,13 +2365,14 @@ byte-compile-output-docform \(the constants vector) together, for lazy loading. QUOTED says that we have to put a quote before the list that represents a doc string reference. -`defvaralias', `autoload' and `custom-declare-variable' need that." - ;; We need to examine byte-compile-dynamic-docstrings - ;; in the input buffer (now current), not in the output buffer. +`defvaralias', `autoload' and `custom-declare-variable' need that. + +We need to examine byte-compile-dynamic-docstrings +in the input buffer (now current), not in the output buffer." (let ((dynamic-docstrings byte-compile-dynamic-docstrings)) (with-current-buffer byte-compile--outbuffer - (let (position - (print-symbols-bare t)) ; Possibly redundant binding. + (let (position) + ;; Insert the doc string, and make it a comment with #@LENGTH. (and (>=3D (nth 1 info) 0) dynamic-docstrings @@ -2400,9 +2380,8 @@ byte-compile-output-docform ;; Make the doc string start at beginning of line ;; for make-docfile's sake. (insert "\n") - (setq position - (byte-compile-output-as-comment - (nth (nth 1 info) form) nil)) + (setq position (byte-compile-output-as-comment + (nth (nth 1 info) form) nil)) ;; If the doc string starts with * (a user variable), ;; negate POSITION. (if (and (stringp (nth (nth 1 info) form)) @@ -2411,46 +2390,37 @@ byte-compile-output-docform (setq position (- position))))) =20 (let ((print-continuous-numbering t) - print-number-table + (print-number-table nil) (index 0) - ;; FIXME: The bindings below are only needed for when we're - ;; called from ...-defmumble. (print-escape-newlines t) (print-length nil) (print-level nil) (print-quoted t) (print-gensym t) - (print-circle ; Handle circular data structures. - (not byte-compile-disable-print-circle))) - (if preface - (progn - ;; FIXME: We don't handle uninterned names correctly. - ;; E.g. if cl-define-compiler-macro uses uninterned name w= e get: - ;; (defalias '#1=3D#:foo--cmacro #[514 ...]) - ;; (put 'foo 'compiler-macro '#:foo--cmacro) - (insert preface) - (prin1 name byte-compile--outbuffer))) + (print-circle (not byte-compile-disable-print-circle))) + (when preface + ;; FIXME: If cl-define-compiler-macro uses uninterned + ;; "#:foo", we get: + ;; (defalias '#1=3D#:foo--cmacro #[514 ...]) + ;; (put 'foo 'compiler-macro '#:foo--cmacro) + (insert preface) + (prin1 name byte-compile--outbuffer)) (insert (car info)) (prin1 (car form) byte-compile--outbuffer) (while (setq form (cdr form)) (setq index (1+ index)) (insert " ") (cond ((and (numberp specindex) (=3D index specindex) - ;; Don't handle the definition dynamically - ;; if it refers (or might refer) - ;; to objects already output - ;; (for instance, gensyms in the arg list). - (let (non-nil) - (when (hash-table-p print-number-table) - (maphash (lambda (_k v) (if v (setq non-nil t)= )) - print-number-table)) - (not non-nil))) + ;; gensyms in the arglist might + ;; already be output; don't proceed + (or (not (hash-table-p print-number-table)) + (not (catch 'already + (maphash (lambda (_k v) (when v (throw = 'already t))) + print-number-table))))) ;; Output the byte code and constants specially ;; for lazy dynamic loading. - (let ((position - (byte-compile-output-as-comment - (cons (car form) (nth 1 form)) - t))) + (let ((position (byte-compile-output-as-comment + (cons (car form) (nth 1 form)) t))) (princ (format "(#$ . %d) nil" position) byte-compile--outbuffer) (setq form (cdr form)) @@ -2468,85 +2438,60 @@ byte-compile-output-docform (goto-char (point-max))))) (t (prin1 (car form) byte-compile--outbuffer))))) - (insert (nth 2 info))))) - nil) + (insert (nth 2 info)))))) =20 (defun byte-compile-keep-pending (form &optional handler) - (if (memq byte-optimize '(t source)) - (setq form (byte-optimize-one-form form t))) - (if handler - (let ((byte-compile--for-effect t)) - ;; To avoid consing up monstrously large forms at load time, we split - ;; the output regularly. - (and (memq (car-safe form) '(fset defalias)) - (nthcdr 300 byte-compile-output) - (byte-compile-flush-pending)) - (funcall handler form) - (if byte-compile--for-effect - (byte-compile-discard))) - (byte-compile-form form t)) - nil) + (when (memq byte-optimize '(t source)) + (setq form (byte-optimize-one-form form t))) + (prog1 nil + (if handler + (let ((byte-compile--for-effect t)) + (when (and (memq (car-safe form) '(fset defalias)) + (nthcdr 300 byte-compile-output)) + ;; To avoid consing frenzy at load time, split here + (byte-compile-flush-pending)) + (funcall handler form) + (when byte-compile--for-effect + (byte-compile-discard))) + (byte-compile-form form t)))) =20 (defun byte-compile-flush-pending () - (if byte-compile-output - (let ((form (byte-compile-out-toplevel t 'file))) - (cond ((eq (car-safe form) 'progn) - (mapc 'byte-compile-output-file-form (cdr form))) - (form - (byte-compile-output-file-form form))) - (setq byte-compile-constants nil - byte-compile-variables nil - byte-compile-depth 0 - byte-compile-maxdepth 0 - byte-compile-output nil - byte-compile-jump-tables nil)))) - -(defun byte-compile-preprocess (form &optional _for-effect) - (let ((print-symbols-bare t)) ; Possibly redundant binding. - (setq form (macroexpand-all form byte-compile-macro-environment))) - ;; FIXME: We should run byte-optimize-form here, but it currently does n= ot - ;; recurse through all the code, so we'd have to fix this first. - ;; Maybe a good fix would be to merge byte-optimize-form into - ;; macroexpand-all. - ;; (if (memq byte-optimize '(t source)) - ;; (setq form (byte-optimize-form form for-effect))) - (cond - (lexical-binding (cconv-closure-convert form)) - (t form))) - -;; byte-hunk-handlers cannot call this! -(defun byte-compile-toplevel-file-form (top-level-form) - ;; (let ((byte-compile-form-stack - ;; (cons top-level-form byte-compile-form-stack))) - (push top-level-form byte-compile-form-stack) - (prog1 - (byte-compile-recurse-toplevel - top-level-form - (lambda (form) - (let ((byte-compile-current-form nil)) ; close over this for warn= ings. - (byte-compile-file-form (byte-compile-preprocess form t))))) - (pop byte-compile-form-stack))) + "Compile pending forms at end of file." + (when byte-compile-output + (let ((form (byte-compile-out-top-level t 'file))) + (cond ((eq (car-safe form) 'progn) + (mapc #'byte-compile-output-file-form (cdr form))) + (form + (byte-compile-output-file-form form))) + (setq byte-compile-constants nil + byte-compile-variables nil + byte-compile-depth 0 + byte-compile-maxdepth 0 + byte-compile-output nil + byte-compile-jump-tables nil)))) + +(defun byte-compile-preprocess (form) + (let ((form* (macroexpand-all form byte-compile-macro-environment))) + (if lexical-binding + (cconv-closure-convert form*) + form*))) =20 ;; byte-hunk-handlers can call this. (defun byte-compile-file-form (form) - (let (handler) - (cond ((and (consp form) - (symbolp (car form)) - (setq handler (get (car form) 'byte-hunk-handler))) - (cond ((setq form (funcall handler form)) - (byte-compile-flush-pending) - (byte-compile-output-file-form form)))) - (t - (byte-compile-keep-pending form))))) - -;; Functions and variables with doc strings must be output separately, -;; so make-docfile can recognize them. Most other things can be output -;; as byte-code. + (if-let ((handler (and (consp form) + (symbolp (car form)) + (get (car form) 'byte-hunk-handler)))) + (let* ((byte-compile-current-form form) + (form* (funcall handler form))) + (byte-compile-flush-pending) + (byte-compile-output-file-form form*)) + (byte-compile-keep-pending form))) =20 (put 'autoload 'byte-hunk-handler 'byte-compile-file-form-autoload) (defun byte-compile-file-form-autoload (form) (and (let ((form form)) - (while (if (setq form (cdr form)) (macroexp-const-p (car form)))) + (while (when (setq form (cdr form)) + (macroexp-const-p (car form)))) (null form)) ;Constants only (memq (eval (nth 5 form)) '(t macro)) ;Macro (eval form)) ;Define the autoload. @@ -2574,21 +2519,19 @@ byte-compile-file-form-autoload (delq (assq funsym byte-compile-unresolved-functions) byte-compile-unresolved-functions))))) (if (stringp (nth 3 form)) - (prog1 - form + (prog1 form (byte-compile-docstring-length-warn form)) ;; No doc string, so we can compile this as a normal form. (byte-compile-keep-pending form 'byte-compile-normal-call))) =20 -(put 'defvar 'byte-hunk-handler 'byte-compile-file-form-defvar) +(put 'defvar 'byte-hunk-handler 'byte-compile-file-form-defvar) (put 'defconst 'byte-hunk-handler 'byte-compile-file-form-defvar) =20 (defun byte-compile--check-prefixed-var (sym) (when (and (symbolp sym) (not (string-match "[-*/:$]" (symbol-name sym))) (byte-compile-warning-enabled-p 'lexical sym)) - (byte-compile-warn-x - sym "global/dynamic var `%s' lacks a prefix" sym))) + (byte-compile-warn "global/dynamic var `%s' lacks a prefix" sym))) =20 (defun byte-compile--declare-var (sym) (byte-compile--check-prefixed-var sym) @@ -2596,29 +2539,21 @@ byte-compile--declare-var (setq byte-compile-lexical-variables (delq sym byte-compile-lexical-variables)) (when (byte-compile-warning-enabled-p 'lexical sym) - (byte-compile-warn-x sym "Variable `%S' declared after its first use= " sym))) + (byte-compile-warn "Variable `%S' declared after its first use" sym)= )) (push sym byte-compile-bound-variables) (push sym byte-compile--seen-defvars)) =20 (defun byte-compile-file-form-defvar (form) (let ((sym (nth 1 form))) (byte-compile--declare-var sym) - (if (eq (car form) 'defconst) - (push sym byte-compile-const-variables))) - (if (and (null (cddr form)) ;No `value' provided. - (eq (car form) 'defvar)) ;Just a declaration. - nil + (when (eq (car form) 'defconst) + (push sym byte-compile-const-variables))) + (when (or (cddr form) (not (eq (car form) 'defvar))) (byte-compile-docstring-length-warn form) - (setq form (copy-sequence form)) (cond ((consp (nth 2 form)) + (setq form (copy-sequence form)) (setcar (cdr (cdr form)) - (byte-compile-top-level (nth 2 form) nil 'file))) - ((symbolp (nth 2 form)) - (setcar (cddr form) (bare-symbol (nth 2 form)))) - (t (setcar (cddr form) (nth 2 form)))) - (setcar form (bare-symbol (car form))) - (if (symbolp (nth 1 form)) - (setcar (cdr form) (bare-symbol (nth 1 form)))) + (byte-compile-top-level (nth 2 form) nil 'file)))) form)) =20 (put 'define-abbrev-table 'byte-hunk-handler @@ -2627,7 +2562,7 @@ byte-compile-file-form-defvar =20 (defun byte-compile-file-form-defvar-function (form) (pcase-let (((or `',name (let name nil)) (nth 1 form))) - (if name (byte-compile--declare-var name))) + (when name (byte-compile--declare-var name))) ;; Variable aliases are better declared before the corresponding variabl= e, ;; since it makes it more likely that only one of the two vars has a val= ue ;; before the `defvaralias' gets executed, which avoids the need to @@ -2635,10 +2570,9 @@ byte-compile-file-form-defvar-function (pcase form (`(defvaralias ,_ ',newname . ,_) (when (memq newname byte-compile-bound-variables) - (if (byte-compile-warning-enabled-p 'suspicious) - (byte-compile-warn-x - newname - "Alias for `%S' should be declared before its referent" newnam= e))))) + (when (byte-compile-warning-enabled-p 'suspicious) + (byte-compile-warn + "Alias for `%S' should be declared before its referent" newname)= )))) (byte-compile-docstring-length-warn form) (byte-compile-keep-pending form)) =20 @@ -2651,189 +2585,149 @@ byte-compile-file-form-custom-declare-variable =20 (put 'require 'byte-hunk-handler 'byte-compile-file-form-require) (defun byte-compile-file-form-require (form) - (let* ((args (mapcar 'eval (cdr form))) - ;; The following is for the byte-compile-warn in - ;; `do-after-load-evaluation' (in subr.el). - (byte-compile-form-stack (cons (car args) byte-compile-form-stack= )) - hist-new prov-cons) - (apply 'require args) - - ;; Record the functions defined by the require in `byte-compile-new-de= funs'. - (setq hist-new load-history) - (setq prov-cons (cons 'provide (car args))) + "Record functions defined by FORM in `byte-compile-new-defuns'." + (let* ((args (mapcar #'eval (cdr form))) + (hist-new (progn (apply #'require args) + load-history))) (while (and hist-new - (not (member prov-cons (car hist-new)))) + (not (member (cons 'provide (car args)) + (car hist-new)))) (setq hist-new (cdr hist-new))) - (when hist-new - (dolist (x (car hist-new)) - (when (and (consp x) - (memq (car x) '(defun t))) - (push (cdr x) byte-compile-new-defuns))))) + (dolist (x (car hist-new)) + (when (and (consp x) + (memq (car x) '(defun t))) + (push (cdr x) byte-compile-new-defuns)))) (byte-compile-keep-pending form 'byte-compile-normal-call)) =20 (put 'progn 'byte-hunk-handler 'byte-compile-file-form-progn) (put 'prog1 'byte-hunk-handler 'byte-compile-file-form-progn) (defun byte-compile-file-form-progn (form) - (mapc #'byte-compile-file-form (cdr form)) - ;; Return nil so the forms are not output twice. - nil) + (prog1 nil + (mapc #'byte-compile-file-form (cdr form)))) =20 (put 'with-no-warnings 'byte-hunk-handler 'byte-compile-file-form-with-no-warnings) (defun byte-compile-file-form-with-no-warnings (form) - ;; cf byte-compile-file-form-progn. (let (byte-compile-warnings) - (mapc 'byte-compile-file-form (cdr form)) - nil)) + (byte-compile-file-form-progn form))) =20 (put 'internal--with-suppressed-warnings 'byte-hunk-handler 'byte-compile-file-form-with-suppressed-warnings) (defun byte-compile-file-form-with-suppressed-warnings (form) - ;; cf byte-compile-file-form-progn. (let ((byte-compile--suppressed-warnings (append (cadadr form) byte-compile--suppressed-warnings))) - (mapc 'byte-compile-file-form (cddr form)) - nil)) + (byte-compile-file-form-progn (cdr form)))) =20 ;; Automatically evaluate define-obsolete-function-alias etc at top-level. (put 'make-obsolete 'byte-hunk-handler 'byte-compile-file-form-make-obsole= te) (defun byte-compile-file-form-make-obsolete (form) (prog1 (byte-compile-keep-pending form) - (apply 'make-obsolete - (mapcar 'eval (cdr form))))) - -(defun byte-compile-file-form-defmumble (name macro arglist body rest) - "Process a `defalias' for NAME. -If MACRO is non-nil, the definition is known to be a macro. -ARGLIST is the list of arguments, if it was recognized or t otherwise. -BODY of the definition, or t if not recognized. -Return non-nil if everything went as planned, or nil to imply that it deci= ded -not to take responsibility for the actual compilation of the code." - (let* ((this-kind (if macro 'byte-compile-macro-environment + (apply #'make-obsolete (mapcar #'eval (cdr form))))) + +(defun byte-compile-file-form-defalias* (name macro-p arglist body rest) + "Rather than have `byte-compile-output-file-form' analyze NAME's +defalias, output it by hand here. ARGLIST is the list of +arguments, or t if not recognized. BODY is the function +definition, or t if not recognized. Return t if compiled, nil +otherwise." + (let* ((this-kind (if macro-p + 'byte-compile-macro-environment 'byte-compile-function-environment)) - (that-kind (if macro 'byte-compile-function-environment + (that-kind (if macro-p + 'byte-compile-function-environment 'byte-compile-macro-environment)) (this-one (assq name (symbol-value this-kind))) (that-one (assq name (symbol-value that-kind))) - (bare-name (bare-symbol name)) - (byte-compile-current-form name)) ; For warnings. - - (push bare-name byte-compile-new-defuns) - ;; When a function or macro is defined, add it to the call tree so that - ;; we can tell when functions are not used. - (if byte-compile-generate-call-tree - (or (assq bare-name byte-compile-call-tree) - (setq byte-compile-call-tree - (cons (list bare-name nil nil) byte-compile-call-tree)))) - - (if (byte-compile-warning-enabled-p 'redefine name) - (byte-compile-arglist-warn name arglist macro)) - - (if byte-compile-verbose - (message "Compiling %s... (%s)" - (or byte-compile-current-file "") bare-name)) - (cond ((not (or macro (listp body))) - ;; We do not know positively if the definition is a macro - ;; or a function, so we shouldn't emit warnings. - ;; This also silences "multiple definition" warnings for defmet= hods. - nil) - (that-one - (if (and (byte-compile-warning-enabled-p 'redefine name) - ;; Don't warn when compiling the stubs in byte-run... - (not (assq bare-name byte-compile-initial-macro-enviro= nment))) - (byte-compile-warn-x - name + (do-warn (byte-compile-warning-enabled-p 'redefine name)) + (byte-compile-current-func name)) + (push name byte-compile-new-defuns) + (when byte-compile-generate-call-tree + (unless (assq name byte-compile-call-tree) + ;; Add NAME to call tree to later detect unused functions. + (setq byte-compile-call-tree + (cons (list name nil nil) byte-compile-call-tree)))) + (when do-warn + (byte-compile-arglist-warn name arglist macro-p)) + (when byte-compile-verbose + (message "Compiling %s... (%s)" + (or byte-compile-current-file "") name)) + (when (or macro-p (listp body)) + (cond (that-one + (when (and do-warn + ;; Don't warn when compiling stubs in byte-run.el + (not (assq name byte-compile-initial-macro-environ= ment))) + (byte-compile-warn "`%s' defined multiple times, as both function and macro" - bare-name)) - (setcdr that-one nil)) - (this-one - (when (and (byte-compile-warning-enabled-p 'redefine name) - ;; Hack: Don't warn when compiling the magic internal - ;; byte-compiler macros in byte-run.el... - (not (assq bare-name byte-compile-initial-macro-envi= ronment))) - (byte-compile-warn-x - name - "%s `%s' defined multiple times in this file" - (if macro "macro" "function") - bare-name))) - ((eq (car-safe (symbol-function bare-name)) - (if macro 'lambda 'macro)) - (when (byte-compile-warning-enabled-p 'redefine bare-name) - (byte-compile-warn-x - name - "%s `%s' being redefined as a %s" - (if macro "function" "macro") - bare-name - (if macro "macro" "function"))) - ;; Shadow existing definition. - (set this-kind - (cons (cons bare-name nil) - (symbol-value this-kind)))) - ) + name)) + (setcdr that-one nil)) + (this-one + (when (and do-warn + ;; Don't warn when compiling stubs in byte-run.el + (not (assq name byte-compile-initial-macro-environ= ment))) + (byte-compile-warn + "%s `%s' defined multiple times in this file" + (if macro-p "macro" "function") + name))) + ((eq (car-safe (symbol-function name)) + (if macro-p 'lambda 'macro)) + (when do-warn + (byte-compile-warn + "%s `%s' being redefined as a %s" + (if macro-p "function" "macro") + name + (if macro-p "macro" "function"))) + ;; Shadow existing definition. + (set this-kind + (cons (cons name nil) (symbol-value this-kind)))))) =20 (when (and (listp body) (stringp (car body)) (symbolp (car-safe (cdr-safe body))) (car-safe (cdr-safe body)) (stringp (car-safe (cdr-safe (cdr-safe body))))) - (byte-compile-warn-x - name "probable `\"' without `\\' in doc string of %s" bare-name)) + (byte-compile-warn "probable `\"' without `\\' in doc string of %s" + name)) =20 + ;; Final expresssion must inform caller whether we compiled. (if (not (listp body)) - ;; The precise definition requires evaluation to find out, so it - ;; will only be known at runtime. - ;; For a macro, that means we can't use that macro in the same fil= e. - (progn - (unless macro - (push (cons bare-name (if (listp arglist) `(declared ,arglist)= t)) - byte-compile-function-environment)) - ;; Tell the caller that we didn't compile it yet. - nil) - - (let* ((code (byte-compile-lambda (cons arglist body) t))) + (prog1 nil + (unless macro-p ;; macros undefined until runtime evaluation + (push (cons name (if (listp arglist) `(declared ,arglist) t)) + byte-compile-function-environment))) + (let ((code (byte-compile-lambda (cons arglist body) t))) (if this-one - ;; A definition in b-c-initial-m-e should always take preceden= ce - ;; during compilation, so don't let it be redefined. (Bug#864= 7) - (or (and macro - (assq bare-name byte-compile-initial-macro-environmen= t)) - (setcdr this-one code)) - (set this-kind - (cons (cons bare-name code) - (symbol-value this-kind)))) - - (if rest - ;; There are additional args to `defalias' (like maybe a docst= ring) - ;; that the code below can't handle: punt! - nil - ;; Otherwise, we have a bona-fide defun/defmacro definition, and= use - ;; special code to allow dynamic docstrings and byte-code. - (byte-compile-flush-pending) - (let ((index - ;; If there's no doc string, provide -1 as the "doc string - ;; index" so that no element will be treated as a doc str= ing. - (if (not (stringp (documentation code t))) -1 4))) + ;; A definition in byte-compile-initial-macro-environment + ;; cannot be redefined. (Bug#8647) + (unless (and macro-p + (assq name byte-compile-initial-macro-environment= )) + (setcdr this-one code)) + (set this-kind (cons (cons name code) (symbol-value this-kind)))) + + ;; If REST contains additional args (e.g., docstring) we don't + ;; handle below, punt back nil. + (unless rest + (prog1 t + (byte-compile-flush-pending) (when byte-native-compiling ;; Spill output for the native compiler here. - (push - (if macro - (make-byte-to-native-top-level - :form `(defalias ',name '(macro . ,code) nil) - :lexical lexical-binding) - (make-byte-to-native-func-def :name name - :byte-func code)) - byte-to-native-top-level-forms)) - ;; Output the form by hand, that's much simpler than having - ;; b-c-output-file-form analyze the defalias. - (byte-compile-output-docform - "\n(defalias '" - bare-name - (if macro `(" '(macro . #[" ,index "])") `(" #[" ,index "]")) - (append code nil) ; Turn byte-code-function-p into l= ist. - (and (atom code) byte-compile-dynamic - 1) - nil)) - (princ ")" byte-compile--outbuffer) - t))))) + (push (if macro-p + (make-byte-to-native-top-level + :form `(defalias ',name '(macro . ,code) nil) + :lexical lexical-binding) + (make-byte-to-native-func-def :name name + :byte-func code)) + byte-to-native-top-level-forms)) + (let ((doc-index (if (stringp (documentation code t)) 4 -1))) + (byte-compile-output-docform + "\n(defalias '" + name + (if macro-p + `(" '(macro . #[" ,doc-index "])") + `(" #[" ,doc-index "]")) + (append code nil) ; function vector to list + (and (atom code) byte-compile-dynamic 1) + nil)) + (princ ")" byte-compile--outbuffer))))))) =20 (defun byte-compile-output-as-comment (exp quoted) "Print Lisp object EXP in the output file, inside a comment. @@ -2841,7 +2735,6 @@ byte-compile-output-as-comment If QUOTED is non-nil, print with quoting; otherwise, print without quoting= ." (with-current-buffer byte-compile--outbuffer (let ((position (point))) - ;; Insert EXP, and make it a comment with #@LENGTH. (insert " ") (if quoted @@ -2895,11 +2788,11 @@ byte-compile--reify-function (if (null renv) `(lambda ,args ,@preamble ,@body) `(let ,renv (lambda ,args ,@preamble ,@body))))) - + ;;;###autoload (defun byte-compile (form) - "If FORM is a symbol, byte-compile its function definition. -If FORM is a lambda or a macro, byte-compile it as a function." + "If FORM is a symbol, compile its function definition. +If FORM is a lambda or a macro, compile into a function." (displaying-byte-compile-warnings (byte-compile-close-variables (let* ((lexical-binding lexical-binding) @@ -2907,40 +2800,35 @@ byte-compile (symbol-function form) form)) (macro (eq (car-safe fun) 'macro))) - (if macro - (setq fun (cdr fun))) - (prog1 - (cond - ;; Up until Emacs-24.1, byte-compile silently did nothing when = asked to - ;; compile something invalid. So let's tune down the complaint= from an - ;; error to a simple message for the known case where signaling= an error - ;; causes problems. - ((byte-code-function-p fun) - (message "Function %s is already compiled" - (if (symbolp form) form "provided")) - fun) - (t - (let (final-eval) - (when (or (symbolp form) (eq (car-safe fun) 'closure)) - ;; `fun' is a function *value*, so try to recover its corr= esponding - ;; source code. - (setq lexical-binding (eq (car fun) 'closure)) - (setq fun (byte-compile--reify-function fun)) - (setq final-eval t)) - ;; Expand macros. - (setq fun (byte-compile-preprocess fun)) - (setq fun (byte-compile-top-level fun nil 'eval)) - (if (symbolp form) - ;; byte-compile-top-level returns an *expression* equiva= lent to the - ;; `fun' expression, so we need to evaluate it, tho norm= ally - ;; this is not needed because the expression is just a c= onstant - ;; byte-code object, which is self-evaluating. - (setq fun (eval fun t))) - (if final-eval - (setq fun (eval fun t))) - (if macro (push 'macro fun)) - (if (symbolp form) (fset form fun)) - fun)))))))) + (when macro + (setq fun (cdr fun))) + (cond + ((byte-code-function-p fun) + (message "Function %s is already compiled" + (if (symbolp form) form "provided")) + fun) + (t + (let (final-eval) + (when (or (symbolp form) (eq (car-safe fun) 'closure)) + ;; FUN is a function *value*; recover its source code. + (setq lexical-binding (eq (car fun) 'closure)) + (setq fun (byte-compile--reify-function fun)) + (setq final-eval t)) + ;; Expand macros. + (setq fun (byte-compile-preprocess fun)) + (setq fun (byte-compile-top-level fun nil 'eval)) + (when (symbolp form) + ;; byte-compile-top-level returns an *expression* we need + ;; to evaluate, although it's often a constant, + ;; self-evaluating byte-code object. + (setq fun (eval fun t))) + (when final-eval + (setq fun (eval fun t))) + (when macro + (push 'macro fun)) + (when (symbolp form) + (fset form fun)) + fun))))))) =20 (defun byte-compile-sexp (sexp) "Compile and return SEXP." @@ -2969,8 +2857,7 @@ byte-compile-check-lambda-list ((and (memq arg vars) ;; Allow repetitions for unused args. (not (string-match "\\`_" (symbol-name arg)))) - (byte-compile-warn-x - arg "repeated variable %s in lambda-list" arg)) + (byte-compile-warn "repeated variable %s in lambda-list" arg)) (t (push arg vars)))) (setq list (cdr list))))) @@ -3013,8 +2900,7 @@ byte-compile-make-args-desc =20 (defun byte-compile--warn-lexical-dynamic (var context) (when (byte-compile-warning-enabled-p 'lexical-dynamic var) - (byte-compile-warn-x - var + (byte-compile-warn "`%s' lexically bound in %s here but declared dynamic in: %s" var context (mapconcat #'identity @@ -3023,10 +2909,12 @@ byte-compile--warn-lexical-dynamic byte-compile--known-dynamic-vars) ", ")))) =20 -(defun byte-compile-lambda (fun &optional add-lambda reserved-csts) +(defun byte-compile-lambda (fun &optional add-lambda num-constants) "Byte-compile a lambda-expression and return a valid function. The value is usually a compiled function but may be the original -lambda-expression." +lambda-expression. +When ADD-LAMBDA is non-nil, the symbol `lambda' is added as head +of the list FUN." (if add-lambda (setq fun (cons 'lambda fun)) (unless (eq 'lambda (car-safe fun)) @@ -3054,14 +2942,14 @@ byte-compile-lambda ;; Process the interactive spec. (when int ;; Skip (interactive) if it is in front (the most usual location). - (if (eq int (car body)) - (setq body (cdr body))) + (when (eq int (car body)) + (setq body (cdr body))) (cond ((consp (cdr int)) ; There is an `interactive' spec. ;; Check that the bit after the `interactive' spec is ;; just a list of symbols (i.e., modes). (unless (seq-every-p #'symbolp (cdr (cdr int))) - (byte-compile-warn-x int "malformed interactive specc: %s" - int)) + (byte-compile-warn "malformed interactive specc: %s" + (prin1-to-string int))) (setq command-modes (cdr (cdr int))) ;; If the interactive spec is a call to `list', don't ;; compile it, because `call-interactively' looks at the @@ -3073,43 +2961,39 @@ byte-compile-lambda (while (consp (cdr form)) (setq form (cdr form))) (setq form (car form))) - (if (or (not (eq (car-safe form) 'list)) - ;; For code using lexical-binding, form is not - ;; valid lisp, but rather an intermediate form - ;; which may include "calls" to - ;; internal-make-closure (Bug#29988). - lexical-binding) - (setq int `(interactive ,newform))))) + (when (or (not (eq (car-safe form) 'list)) + ;; For code using lexical-binding, form is not + ;; valid lisp, but rather an intermediate form + ;; which may include "calls" to + ;; internal-make-closure (Bug#29988). + lexical-binding) + (setq int `(interactive ,newform))))) ((cdr int) ; Invalid (interactive . something= ). - (byte-compile-warn-x int "malformed interactive spec: %s" - int)))) + (byte-compile-warn "malformed interactive spec: %s" + (prin1-to-string int))))) ;; Process the body. (let ((compiled (byte-compile-top-level (cons 'progn body) nil 'lambda - ;; If doing lexical binding, push a new - ;; lexical environment containing just = the - ;; args (since lambda expressions shoul= d be - ;; closed by now). - (and lexical-binding - (byte-compile-make-lambda-lexenv - arglistvars)) - reserved-csts)) - (bare-arglist arglist)) + (when lexical-binding + ;; use env containing just args (sinc= e lambda + ;; expressions will be closed by now). + (byte-compile-make-lambda-lexenv argl= istvars)) + num-constants))) ;; Build the actual byte-coded function. (cl-assert (eq 'byte-code (car-safe compiled))) (let ((out (apply #'make-byte-code (if lexical-binding (byte-compile-make-args-desc arglist) - bare-arglist) + arglist) (append ;; byte-string, constants-vector, stack depth (cdr compiled) ;; optionally, the doc string. (cond ((and lexical-binding arglist) - ;; byte-compile-make-args-desc lost the args's names, + ;; byte-compile-make-args-desc lost the argnames, ;; so preserve them in the docstring. - (list (help-add-fundoc-usage doc bare-arglist))) + (list (help-add-fundoc-usage doc arglist))) ((or doc int) (list doc))) ;; optionally, the interactive spec (and the modes the @@ -3166,14 +3050,14 @@ byte-compile-constants-vector (setq other rest)))) (apply 'vector (nreverse (mapcar 'car ret))))) =20 -;; Given an expression FORM, compile it and return an equivalent byte-code -;; expression (a call to the function byte-code). -(defun byte-compile-top-level (form &optional for-effect output-type - lexenv reserved-csts) - ;; OUTPUT-TYPE advises about how form is expected to be used: - ;; 'eval or nil -> a single form, - ;; 'lambda -> body of a lambda, - ;; 'file -> used at file-level. +(defun byte-compile-top-level (form + &optional + for-effect output-type lexenv num-constants) + "Return equivalent byte-code expression for FORM. +OUTPUT-TYPE advises how form will be used, +'eval or nil: a single form, +'lambda: body of a lambda, +'file: used at file-level." (let ((byte-compile--for-effect for-effect) (byte-compile-constants nil) (byte-compile-variables nil) @@ -3181,64 +3065,59 @@ byte-compile-top-level (byte-compile-depth 0) (byte-compile-maxdepth 0) (byte-compile--lexical-environment lexenv) - (byte-compile-reserved-constants (or reserved-csts 0)) + (byte-compile-reserved-constants (or num-constants 0)) (byte-compile-output nil) (byte-compile-jump-tables nil)) - (if (memq byte-optimize '(t source)) - (setq form (byte-optimize-one-form form byte-compile--for-effect))) - (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form)))) + (when (memq byte-optimize '(t source)) + (setq form (byte-optimize-one-form form byte-compile--for-effect))) + (while (and (eq (car-safe form) 'progn) + (not (cdr (cdr form)))) (setq form (nth 1 form))) ;; Set up things for a lexically-bound function. (when (and lexical-binding (eq output-type 'lambda)) - ;; See how many arguments there are, and set the current stack depth - ;; accordingly. + ;; Stack depth is number of arguments. (setq byte-compile-depth (length byte-compile--lexical-environment)) - ;; If there are args, output a tag to record the initial - ;; stack-depth for the optimizer. (when (> byte-compile-depth 0) + ;; Output tag to record initial stack depth for optimizer. (byte-compile-out-tag (byte-compile-make-tag)))) - ;; Now compile FORM (byte-compile-form form byte-compile--for-effect) - (byte-compile-out-toplevel byte-compile--for-effect output-type))) - -(defun byte-compile-out-toplevel (&optional for-effect output-type) - ;; OUTPUT-TYPE can be like that of `byte-compile-top-level'. - (if for-effect - ;; The stack is empty. Push a value to be returned from (byte-code .= .). - (if (eq (car (car byte-compile-output)) 'byte-discard) - (setq byte-compile-output (cdr byte-compile-output)) - (byte-compile-push-constant - ;; Push any constant - preferably one which already is used, and - ;; a number or symbol - ie not some big sequence. The return value - ;; isn't returned, but it would be a shame if some textually large - ;; constant was not optimized away because we chose to return it. - (and (not (assq nil byte-compile-constants)) ; Nil is often there. - (let ((tmp (reverse byte-compile-constants))) - (while (and tmp (not (or (symbolp (caar tmp)) - (numberp (caar tmp))))) - (setq tmp (cdr tmp))) - (caar tmp)))))) + (byte-compile-out-top-level byte-compile--for-effect output-type))) + +(defun byte-compile-out-top-level (&optional for-effect output-type) + "OUTPUT-TYPE is described in `byte-compile-top-level'." + (when for-effect + ;; Stack is empty; push a value to be returned from (byte-code ...) + (if (eq (car (car byte-compile-output)) 'byte-discard) + (setq byte-compile-output (cdr byte-compile-output)) + (byte-compile-push-constant + ;; Push a constant, preferably a previously used symbol or number + ;; which would be optimized away should we ever choose to return it. + (unless (assq nil byte-compile-constants) + (let ((tmp (reverse byte-compile-constants))) + (while (and tmp (not (or (symbolp (caar tmp)) + (numberp (caar tmp))))) + (setq tmp (cdr tmp))) + (caar tmp)))))) (byte-compile-out 'byte-return 0) (setq byte-compile-output (nreverse byte-compile-output)) - (if (memq byte-optimize '(t byte)) - (setq byte-compile-output - (byte-optimize-lapcode byte-compile-output))) - - ;; Decompile trivial functions: - ;; only constants and variables, or a single funcall except in lambdas. - ;; Except for Lisp_Compiled objects, forms like (foo "hi") - ;; are still quicker than (byte-code "..." [foo "hi"] 2). + (when (memq byte-optimize '(t byte)) + (setq byte-compile-output (byte-optimize-lapcode byte-compile-output))) + + ;; Decompile trivial constants, variables, or single funcalls + ;; excluding lambdas. Except for Lisp_Compiled objects, forms like + ;; (foo "hi") are still quicker than (byte-code "..." [foo "hi"] 2). ;; Note that even (quote foo) must be parsed just as any subr by the - ;; interpreter, so quote should be compiled into byte-code in some conte= xts. - ;; What to leave uncompiled: + ;; interpreter, so quote should be compiled into byte-code in some + ;; contexts. + + ;; What to decompile: ;; lambda -> never. The compiled form is always faster. ;; eval -> atom, quote or (function atom atom atom) ;; file -> as progn, but takes both quotes and atoms, and longer forms. - (let (rest - (maycall (not (eq output-type 'lambda))) ; t if we may make a funcall. - tmp body) + (let ((maycall (not (eq output-type 'lambda))) ;; t if we may make a fun= call. + rest tmp body) (cond - ;; #### This should be split out into byte-compile-nontrivial-functio= n-p. + ;; This should be split into byte-compile-nontrivial-function-p. ((or (eq output-type 'lambda) (nthcdr (if (eq output-type 'file) 50 8) byte-compile-output) (assq 'TAG byte-compile-output) ; Not necessary, but speeds up a bit. @@ -3267,7 +3146,7 @@ byte-compile-out-toplevel (eql (length body) (cdr (car rest))) ;bug#= 34757 (eq (car (nth 1 rest)) 'byte-discard) (progn (setq rest (cdr rest)) t)))) - (setq maycall nil) ; Only allow one real function call. + (setq maycall nil) ;; Only allow one real function call. (setq body (nreverse body)) (setq body (list (if (and (eq tmp 'funcall) @@ -3284,127 +3163,115 @@ byte-compile-out-toplevel byte-compile-vector byte-compile-maxdepth))) ;; it's a trivial function ((cdr body) (cons 'progn (nreverse body))) - ((car body))))) - -;; Given BODY, compile it and return a new body. -(defun byte-compile-top-level-body (body &optional for-effect) - (setq body - (byte-compile-top-level (cons 'progn body) for-effect t)) - (cond ((eq (car-safe body) 'progn) - (cdr body)) - (body - (list body)))) - -;; Special macro-expander used during byte-compilation. + (t (car body))))) + (defun byte-compile-macroexpand-declare-function (fn file &rest args) + "Special macro-expander used during byte-compilation." (declare (advertised-calling-convention (fn file &optional arglist fileonly) nil)) (let ((gotargs (and (consp args) (listp (car args)))) (unresolved (assq fn byte-compile-unresolved-functions))) - (when unresolved ; function was called before declaration + (when unresolved + ;; function was called before declaration (if (and gotargs (byte-compile-warning-enabled-p 'callargs)) (byte-compile-arglist-warn fn (car args) nil) (setq byte-compile-unresolved-functions (delq unresolved byte-compile-unresolved-functions)))) (push (cons fn (if gotargs (list 'declared (car args)) - t)) ; Arglist not specified. + t)) byte-compile-function-environment)) ;; We are stating that it _will_ be defined at runtime. (setq byte-compile-noruntime-functions (delq fn byte-compile-noruntime-functions)) ;; Delegate the rest to the normal macro definition. - (let ((print-symbols-bare t)) ; Possibly redundant binding. - (macroexpand `(declare-function ,fn ,file ,@args)))) - - -;; This is the recursive entry point for compiling each subform of an -;; expression. -;; If for-effect is non-nil, byte-compile-form will output a byte-discard -;; before terminating (ie no value will be left on the stack). -;; A byte-compile handler may, when byte-compile--for-effect is non-nil, c= hoose -;; output code which does not leave a value on the stack, and then set -;; byte-compile--for-effect to nil (to prevent byte-compile-form from -;; outputting the byte-discard). -;; If a handler wants to call another handler, it should do so via -;; byte-compile-form, or take extreme care to handle byte-compile--for-eff= ect -;; correctly. (Use byte-compile-form-do-effect to reset the -;; byte-compile--for-effect flag too.) -;; + (macroexpand `(declare-function ,fn ,file ,@args))) + +(defsubst byte-compile--decouple-cell (form func) + (cond ((atom (car form)) (funcall func form)) + (t (byte-compile--decouple form func)))) + +(defun byte-compile--decouple (form func) + (unless (circular-list-p form) + (if (atom (car form)) + (byte-compile--decouple-cell form func) + (cl-loop with tail =3D (unless (cl-tailp nil (last form)) + (last form)) + for element in form + when (or (consp element) (null element)) + collect (byte-compile--decouple-cell element func) into res= ult + finally return (nconc result + (when tail + (byte-compile--decouple-cell tail f= unc))))))) + (defun byte-compile-form (form &optional for-effect) - (let ((byte-compile--for-effect for-effect)) - (push form byte-compile-form-stack) + "Compiles FORM. +FOR-EFFECT means FORM is side-effect-only whose meaningless return +value should be byte-discard." + (let ((byte-compile--for-effect for-effect) + (byte-compile-current-form form)) (cond ((not (consp form)) (cond ((or (not (symbolp form)) (macroexp--const-symbol-p form)) - (byte-compile-constant - (if (symbolp form) (bare-symbol form) form))) + (byte-compile-constant form)) ((and byte-compile--for-effect byte-compile-delete-errors) (setq byte-compile--for-effect nil)) (t - (byte-compile-variable-ref (bare-symbol form))))) + (byte-compile-variable-ref form)))) ((symbolp (car form)) (let* ((fn (car form)) (handler (get fn 'byte-compile)) (interactive-only (or (get fn 'interactive-only) (memq fn byte-compile-interactive-only-functions)))) - (when (memq fn '(set symbol-value run-hooks ;; add-to-list - add-hook remove-hook run-hook-with-args - run-hook-with-args-until-success - run-hook-with-args-until-failure)) + (when (memq fn '(set symbol-value run-hooks + add-hook remove-hook run-hook-with-args + run-hook-with-args-until-success + run-hook-with-args-until-failure)) (pcase (cdr form) (`(',var . ,_) (when (memq var byte-compile-lexical-variables) (byte-compile-report-error (format-message "%s cannot use lexical var `%s'" fn var)))= ))) - ;; Warn about using obsolete hooks. - (if (memq fn '(add-hook remove-hook)) - (let ((hook (car-safe (cdr form)))) - (if (eq (car-safe hook) 'quote) - (byte-compile-check-variable (cadr hook) nil)))) + ;; Warn about obsolete hooks. + (when (memq fn '(add-hook remove-hook)) + (let ((hook (car-safe (cdr form)))) + (when (eq (car-safe hook) 'quote) + (byte-compile-check-variable (cadr hook) nil)))) (when (and (byte-compile-warning-enabled-p 'suspicious) (macroexp--const-symbol-p fn)) - (byte-compile-warn-x fn "`%s' called as a function" fn)) + (byte-compile-warn "`%s' called as a function" fn)) (when (and (byte-compile-warning-enabled-p 'interactive-only fn) interactive-only) - (byte-compile-warn-x fn "`%s' is for interactive use only%s" - fn - (cond ((stringp interactive-only) - (format "; %s" - (substitute-command-keys - interactive-only))) - ((and (symbolp 'interactive-only) - (not (eq interactive-only t))) - (format-message "; use `%s' instead." - interactive-only)) - (t ".")))) - (if (eq (car-safe (symbol-function (car form))) 'macro) - (byte-compile-report-error - (format "`%s' defined after use in %S (missing `require' of a= library file?)" - (car form) form))) - (if (and handler - ;; Make sure that function exists. - (and (functionp handler) - ;; Ignore obsolete byte-compile function used by for= mer - ;; CL code to handle compiler macros (we do it - ;; differently now). - (not (eq handler 'cl-byte-compile-compiler-macro)))) + (byte-compile-warn "`%s' is for interactive use only%s" + fn + (cond ((stringp interactive-only) + (format "; %s" + (substitute-command-keys + interactive-only))) + ((and (symbolp 'interactive-only) + (not (eq interactive-only t))) + (format-message "; use `%s' instead." + interactive-only)) + (t ".")))) + (when (eq (car-safe (symbol-function (car form))) 'macro) + (byte-compile-report-error + (format "macro `%s' defined after use in %S (missing require?)" + (car form) form))) + (if handler (funcall handler form) (byte-compile-normal-call form)))) ((and (byte-code-function-p (car form)) (memq byte-optimize '(t lap))) - (byte-compile-unfold-bcf form)) + (byte-compile-unfold-byte-code-function form)) ((and (eq (car-safe (car form)) 'lambda) - ;; if the form comes out the same way it went in, that's - ;; because it was malformed, and we couldn't unfold it. + ;; FORM must be different after unfold, else malformed (not (eq form (setq form (macroexp--unfold-lambda form))))) (byte-compile-form form byte-compile--for-effect) (setq byte-compile--for-effect nil)) - ((byte-compile-normal-call form))) - (if byte-compile--for-effect - (byte-compile-discard)) - (pop byte-compile-form-stack))) + (t (byte-compile-normal-call form))) + (when byte-compile--for-effect + (byte-compile-discard)))) =20 (defun byte-compile-normal-call (form) (when (and (symbolp (car form)) @@ -3414,15 +3281,14 @@ byte-compile-normal-call custom-declare-face)) (byte-compile-nogroup-warn form)) (byte-compile-callargs-warn form)) - (if byte-compile-generate-call-tree - (byte-compile-annotate-call-tree form)) + (when byte-compile-generate-call-tree + (byte-compile-annotate-call-tree form)) (when (and byte-compile--for-effect (eq (car form) 'mapcar) (byte-compile-warning-enabled-p 'mapcar 'mapcar)) - (byte-compile-warn-x - (car form) + (byte-compile-warn "`mapcar' called for effect; use `mapc' or `dolist' instead")) (byte-compile-push-constant (car form)) - (mapc 'byte-compile-form (cdr form)) ; wasteful, but faster. + (mapc #'byte-compile-form (cdr form)) (byte-compile-out 'byte-call (length (cdr form)))) =20 =20 @@ -3491,26 +3357,21 @@ byte-compile-inline-lapcode (byte-compile-out (car op) (cdr op))))) (byte-compile-out-tag endtag))) =20 -(defun byte-compile-unfold-bcf (form) +(defun byte-compile-unfold-byte-code-function (form) "Inline call to byte-code-functions." (let* ((byte-compile-bound-variables byte-compile-bound-variables) (fun (car form)) (fargs (aref fun 0)) (start-depth byte-compile-depth) - (fmax2 (if (numberp fargs) (ash fargs -7))) ;2*max+rest. - ;; (fmin (if (numberp fargs) (logand fargs 127))) + (fmax2 (when (numberp fargs) (ash fargs -7))) ;; 2*max+rest. (alen (length (cdr form))) - (dynbinds ()) - lap) + dynbinds lap) (fetch-bytecode fun) (setq lap (byte-decompile-bytecode-1 (aref fun 1) (aref fun 2) t)) - ;; optimized switch bytecode makes it impossible to guess the correct - ;; `byte-compile-depth', which can result in incorrect inlined code. - ;; therefore, we do not inline code that uses the `byte-switch' - ;; instruction. (if (assq 'byte-switch lap) + ;; switch occludes `byte-compile-depth' so cannot inline (byte-compile-normal-call form) - (mapc 'byte-compile-form (cdr form)) + (mapc #'byte-compile-form (cdr form)) (unless fmax2 ;; Old-style byte-code. (cl-assert (listp fargs)) @@ -3542,8 +3403,8 @@ byte-compile-unfold-bcf (byte-compile-out 'byte-listN n))))) (mapc #'byte-compile-dynamic-variable-bind dynbinds) (byte-compile-inline-lapcode lap (1+ start-depth)) - ;; Unbind dynamic variables. (when dynbinds + ;; Unbind dynamic variables. (byte-compile-out 'byte-unbind (length dynbinds))) (cl-assert (eq byte-compile-depth (1+ start-depth)) nil "Wrong depth start=3D%s end=3D%s" start-depth byte-co= mpile-depth)))) @@ -3553,13 +3414,11 @@ byte-compile-check-variable (cond ((or (not (symbolp var)) (macroexp--const-symbol-p var)) (when (byte-compile-warning-enabled-p 'constants (and (symbolp var) var)) - (byte-compile-warn-x - var - (if (eq access-type 'let-bind) - "attempt to let-bind %s `%s'" - "variable reference to %s `%s'") - (if (symbolp var) "constant" "nonvariable") - var))) + (byte-compile-warn (if (eq access-type 'let-bind) + "attempt to let-bind %s `%s'" + "variable reference to %s `%s'") + (if (symbolp var) "constant" "nonvariable") + (prin1-to-string var)))) ((let ((od (get var 'byte-obsolete-variable))) (and od (not (memq var byte-compile-not-obsolete-vars)) @@ -3572,7 +3431,6 @@ byte-compile-check-variable (byte-compile-warn-obsolete var)))) =20 (defsubst byte-compile-dynamic-variable-op (base-op var) - (if (symbolp var) (setq var (bare-symbol var))) (let ((tmp (assq var byte-compile-variables))) (unless tmp (setq tmp (list var)) @@ -3585,24 +3443,23 @@ byte-compile-dynamic-variable-bind (push var byte-compile-bound-variables) (byte-compile-dynamic-variable-op 'byte-varbind var)) =20 -(defun byte-compile-free-vars-warn (arg var &optional assignment) +(defun byte-compile-free-vars-warn (var &optional assignment) "Warn if symbol VAR refers to a free variable. VAR must not be lexically bound. -ARG is a position argument, used by byte-compile-warn-x. -If optional argument ASSIGNMENT is non-nil, this is treated as an -assignment (i.e. `setq')." - (unless (or (not (byte-compile-warning-enabled-p 'free-vars var)) - (boundp var) - (memq var byte-compile-bound-variables) - (memq var (if assignment - byte-compile-free-assignments - byte-compile-free-references))) +The free record for assignment special forms, i.e., setq, is +kept separately and referenced for non-nil ASSIGNMENT." + (when (and (byte-compile-warning-enabled-p 'free-vars var) + (not (boundp var)) + (not (memq var byte-compile-bound-variables)) + (not (memq var (if assignment + byte-compile-free-assignments + byte-compile-free-references)))) (let* ((varname (prin1-to-string var)) (desc (if assignment "assignment" "reference")) (suggestions (help-uni-confusable-suggestions varname))) - (byte-compile-warn-x arg "%s to free variable `%s'%s" - desc var - (if suggestions (concat "\n " suggestions) "")= )) + (byte-compile-warn "%s to free variable `%s'%s" + desc varname + (if suggestions (concat "\n " suggestions) ""))) (push var (if assignment byte-compile-free-assignments byte-compile-free-references)))) @@ -3612,10 +3469,8 @@ byte-compile-variable-ref (byte-compile-check-variable var 'reference) (let ((lex-binding (assq var byte-compile--lexical-environment))) (if lex-binding - ;; VAR is lexically bound (byte-compile-stack-ref (cdr lex-binding)) - ;; VAR is dynamically bound - (byte-compile-free-vars-warn var var) + (byte-compile-free-vars-warn var) (byte-compile-dynamic-variable-op 'byte-varref var)))) =20 (defun byte-compile-variable-set (var) @@ -3623,10 +3478,8 @@ byte-compile-variable-set (byte-compile-check-variable var 'assign) (let ((lex-binding (assq var byte-compile--lexical-environment))) (if lex-binding - ;; VAR is lexically bound. (byte-compile-stack-set (cdr lex-binding)) - ;; VAR is dynamically bound. - (byte-compile-free-vars-warn var var t) + (byte-compile-free-vars-warn var t) (byte-compile-dynamic-variable-op 'byte-varset var)))) =20 (defmacro byte-compile-get-constant (const) @@ -3646,30 +3499,25 @@ byte-compile-get-constant (defun byte-compile-constant (const) (if byte-compile--for-effect (setq byte-compile--for-effect nil) - (inline (byte-compile-push-constant - (if (symbolp const) (bare-symbol const) const))))) + (byte-compile-push-constant const))) =20 ;; Use this for a constant that is not the value of its containing form. ;; This ignores byte-compile--for-effect. (defun byte-compile-push-constant (const) - (when (symbolp const) - (setq const (bare-symbol const))) - (byte-compile-out - 'byte-constant - (byte-compile-get-constant const))) - -;; Compile those primitive ordinary functions -;; which have special byte codes just for speed. + "Use this for a constant that is not the value of its containing form. +This ignores byte-compile--for-effect." + (byte-compile-out 'byte-constant (byte-compile-get-constant const))) =20 (defmacro byte-defop-compiler (function &optional compile-handler) - "Add a compiler-form for FUNCTION. -If function is a symbol, then the variable \"byte-SYMBOL\" must name -the opcode to be used. If function is a list, the first element -is the function and the second element is the bytecode-symbol. -The second element may be nil, meaning there is no opcode. -COMPILE-HANDLER is the function to use to compile this byte-op, or -may be the abbreviations 0, 1, 2, 2-and, 3, 0-1, 1-2, 1-3, or 2-3. -If it is nil, then the handler is \"byte-compile-SYMBOL.\"" + "Construct a lisp form compiling FUNCTION. + +If FUNCTION is a symbol, the opcode used is byte-FUNCTION. +FUNCTION may also be a list (FUNCTION OPCODE), where OPCODE may +be nil signifying no opcode. + +COMPILE-HANDLER is a function to compile OPCODE, or the +abbreviations 0, 1, 2, 2-and, 3, 0-1, 1-2, 1-3, or 2-3. It +defaults to byte-compile-FUNCTION." (let (opcode) (if (symbolp function) (setq opcode (intern (concat "byte-" (symbol-name function)))) @@ -3687,8 +3535,7 @@ byte-defop-compiler (0-1 . byte-compile-zero-or-one-arg) (1-2 . byte-compile-one-or-two-args) (2-3 . byte-compile-two-or-three-args) - (1-3 . byte-compile-one-to-three-args) - ))) + (1-3 . byte-compile-one-to-three-args)))) compile-handler (intern (concat "byte-compile-" (symbol-name function)))))))) @@ -3703,7 +3550,6 @@ byte-defop-compiler (defmacro byte-defop-compiler-1 (function &optional compile-handler) (list 'byte-defop-compiler (list function nil) compile-handler)) =20 - (put 'byte-call 'byte-opcode-invert 'funcall) (put 'byte-list1 'byte-opcode-invert 'list) (put 'byte-list2 'byte-opcode-invert 'list) @@ -3717,7 +3563,6 @@ byte-defop-compiler-1 (put 'byte-insertN 'byte-opcode-invert 'insert) =20 (byte-defop-compiler point 0) -;;(byte-defop-compiler mark 0) ;; obsolete (byte-defop-compiler point-max 0) (byte-defop-compiler point-min 0) (byte-defop-compiler following-char 0) @@ -3728,8 +3573,6 @@ eobp (byte-defop-compiler bolp 0) (byte-defop-compiler bobp 0) (byte-defop-compiler current-buffer 0) -;;(byte-defop-compiler read-char 0) ;; obsolete -;; (byte-defop-compiler interactive-p 0) ;; Obsolete. (byte-defop-compiler widen 0) (byte-defop-compiler end-of-line 0-1) (byte-defop-compiler forward-char 0-1) @@ -3750,7 +3593,6 @@ symbol-function (byte-defop-compiler goto-char 1) (byte-defop-compiler char-after 0-1) (byte-defop-compiler set-buffer 1) -;;(byte-defop-compiler set-mark 1) ;; obsolete (byte-defop-compiler forward-word 0-1) (byte-defop-compiler char-syntax 1) (byte-defop-compiler nreverse 1) @@ -3806,12 +3648,10 @@ min ;;####(byte-defop-compiler move-to-column 1) (byte-defop-compiler-1 interactive byte-compile-noop) =20 - (defun byte-compile-subr-wrong-args (form n) - (byte-compile-warn-x (car form) - "`%s' called with %d arg%s, but requires %s" - (car form) (length (cdr form)) - (if (=3D 1 (length (cdr form))) "" "s") n) + (byte-compile-warn "`%s' called with %d arg%s, but requires %s" + (car form) (length (cdr form)) + (if (=3D 1 (length (cdr form))) "" "s") n) ;; Get run-time wrong-number-of-args error. (byte-compile-normal-call form)) =20 @@ -3840,8 +3680,7 @@ byte-compile-and-folded (cond ((< l 3) (byte-compile-form `(progn ,(nth 1 form) t))) ((=3D l 3) (byte-compile-two-args form)) - ;; Don't use `cl-every' here (see comment where we require cl-lib). - ((not (memq nil (mapcar #'macroexp-copyable-p (nthcdr 2 form)))) + ((cl-every #'identity (mapcar #'macroexp-copyable-p (nthcdr 2 form))) (byte-compile-form `(and (,(car form) ,(nth 1 form) ,(nth 2 form)) (,(car form) ,@(nthcdr 2 form))))) (t (byte-compile-normal-call form))))) @@ -3888,12 +3727,9 @@ byte-compile-discard If PRESERVE-TOS is non-nil, preserve the top-of-stack value, as if it were popped before discarding the num values, and then pushed back again after discarding." - (if (and (null num) (not preserve-tos)) - ;; common case + (if (and (not num) (not preserve-tos)) (byte-compile-out 'byte-discard) - ;; general case - (unless num - (setq num 1)) + (setq num (or num 1)) (when (and preserve-tos (> num 0)) ;; Preserve the top-of-stack value by writing it directly to the sta= ck ;; location which will be at the top-of-stack after popping. @@ -3922,14 +3758,14 @@ internal-make-closure (byte-defop-compiler-1 internal-get-closed-var byte-compile-get-closed-var) =20 (defun byte-compile-make-closure (form) - "Byte-compile the special `internal-make-closure' form." - (if byte-compile--for-effect (setq byte-compile--for-effect nil) + "Special internal-make-closure form." + (if byte-compile--for-effect + (setq byte-compile--for-effect nil) (let* ((vars (nth 1 form)) (env (nth 2 form)) (docstring-exp (nth 3 form)) (body (nthcdr 4 form)) - (fun - (byte-compile-lambda `(lambda ,vars . ,body) nil (length env))= )) + (fun (byte-compile-lambda `(lambda ,vars . ,body) nil (length e= nv)))) (cl-assert (or (> (length env) 0) docstring-exp)) ;Otherwise, we don't need a closure. (cl-assert (byte-code-function-p fun)) @@ -3967,8 +3803,9 @@ byte-compile-make-closure )))) =20 (defun byte-compile-get-closed-var (form) - "Byte-compile the special `internal-get-closed-var' form." - (if byte-compile--for-effect (setq byte-compile--for-effect nil) + "Special internal-get-closed-var form." + (if byte-compile--for-effect + (setq byte-compile--for-effect nil) (byte-compile-out 'byte-constant (nth 1 form)))) =20 ;; Compile a pure function that accepts zero or more numeric arguments @@ -4002,9 +3839,6 @@ byte-compile-min-max ;; No args: warn and emit code that raises an error when executed. (byte-compile-normal-call form))) =20 - -;; more complicated compiler macros - (byte-defop-compiler char-before) (byte-defop-compiler backward-char) (byte-defop-compiler backward-word) @@ -4019,8 +3853,8 @@ function (byte-defop-compiler (/ byte-quo) byte-compile-quo) (byte-defop-compiler nconc) =20 -;; Is this worth it? Both -before and -after are written in C. (defun byte-compile-char-before (form) + "Is this worth it? Both -before and -after are written in C." (cond ((or (=3D 1 (length form)) (and (=3D 2 (length form)) (not (nth 1 form)))) (byte-compile-form '(char-after (1- (point))))) @@ -4031,9 +3865,9 @@ byte-compile-char-before (point))))))) (t (byte-compile-subr-wrong-args form "0-1")))) =20 -;; backward-... =3D=3D> forward-... with negated argument. -;; Is this worth it? Both -backward and -forward are written in C. (defun byte-compile-backward-char (form) + "backward-... =3D=3D> forward-... with negated argument. +Is this worth it? Both -backward and -forward are written in C." (cond ((or (=3D 1 (length form)) (and (=3D 2 (length form)) (not (nth 1 form)))) (byte-compile-form '(forward-char -1))) @@ -4058,18 +3892,18 @@ byte-compile-list (cond ((=3D count 0) (byte-compile-constant nil)) ((< count 5) - (mapc 'byte-compile-form (cdr form)) - (byte-compile-out - (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- count)) 0)) + (mapc #'byte-compile-form (cdr form)) + (byte-compile-out + (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- count)= ) 0)) ((< count 256) - (mapc 'byte-compile-form (cdr form)) + (mapc #'byte-compile-form (cdr form)) (byte-compile-out 'byte-listN count)) (t (byte-compile-normal-call form))))) =20 (defun byte-compile-concat (form) (let ((count (length (cdr form)))) (cond ((and (< 1 count) (< count 5)) - (mapc 'byte-compile-form (cdr form)) + (mapc #'byte-compile-form (cdr form)) (byte-compile-out (aref [byte-concat2 byte-concat3 byte-concat4] (- count 2)) 0)) @@ -4077,7 +3911,7 @@ byte-compile-concat ((=3D count 0) (byte-compile-form "")) ((< count 256) - (mapc 'byte-compile-form (cdr form)) + (mapc #'byte-compile-form (cdr form)) (byte-compile-out 'byte-concatN count)) ((byte-compile-normal-call form))))) =20 @@ -4108,35 +3942,34 @@ byte-compile-nconc (byte-compile-out 'byte-nconc 0)))))) =20 (defun byte-compile-fset (form) - ;; warn about forms like (fset 'foo '(lambda () ...)) - ;; (where the lambda expression is non-trivial...) + "Warn about forms like (fset 'foo '(lambda () ...)) + (where the lambda expression is non-trivial...)" (let ((fn (nth 2 form)) body) (if (and (eq (car-safe fn) 'quote) (eq (car-safe (setq fn (nth 1 fn))) 'lambda)) (progn (setq body (cdr (cdr fn))) - (if (stringp (car body)) (setq body (cdr body))) - (if (eq 'interactive (car-safe (car body))) (setq body (cdr body))) - (if (and (consp (car body)) - (not (eq 'byte-code (car (car body))))) - (byte-compile-warn-x - (nth 2 form) - "A quoted lambda form is the second argument of `fset'. This is pro= bably + (when (stringp (car body)) + (setq body (cdr body))) + (when (eq 'interactive (car-safe (car body))) + (setq body (cdr body))) + (when (and (consp (car body)) + (not (eq 'byte-code (car (car body))))) + (byte-compile-warn + "A quoted lambda form is the second argument of `fset'. This = is probably not what you want, as that lambda cannot be compiled. Consider using the syntax #'(lambda (...) ...) instead."))))) (byte-compile-two-args form)) =20 -;; (function foo) must compile like 'foo, not like (symbol-function 'foo). -;; Otherwise it will be incompatible with the interpreter, -;; and (funcall (function foo)) will lose with autoloads. - (defun byte-compile-function-form (form) + "(function foo) must compile like 'foo, not like (symbol-function 'foo). +Otherwise it will be incompatible with the interpreter, +and (funcall (function foo)) will lose with autoloads." (let ((f (nth 1 form))) (when (and (symbolp f) (byte-compile-warning-enabled-p 'callargs f)) (byte-compile-function-warn f t (byte-compile-fdefinition f nil))) - (byte-compile-constant (if (eq 'lambda (car-safe f)) (byte-compile-lambda f) f)))) @@ -4156,21 +3989,20 @@ byte-compile-insert (cond ((null (cdr form)) (byte-compile-constant nil)) ((<=3D (length form) 256) - (mapc 'byte-compile-form (cdr form)) + (mapc #'byte-compile-form (cdr form)) (if (cdr (cdr form)) (byte-compile-out 'byte-insertN (length (cdr form))) (byte-compile-out 'byte-insert 0))) ((memq t (mapcar 'consp (cdr (cdr form)))) (byte-compile-normal-call form)) - ;; We can split it; there is no function call after inserting 1st arg. (t + ;; We can split it; there is no function call after inserting 1st arg. (while (setq form (cdr form)) (byte-compile-form (car form)) (byte-compile-out 'byte-insert 0) - (if (cdr form) - (byte-compile-discard)))))) + (when (cdr form) + (byte-compile-discard)))))) =20 - (byte-defop-compiler-1 setq) (byte-defop-compiler-1 quote) =20 @@ -4206,17 +4038,14 @@ byte-compile-set-default (macroexp--const-symbol-p var t)) (byte-compile-warning-enabled-p 'constants (and (symbolp var) var)) - (byte-compile-warn-x - var + (byte-compile-warn "variable assignment to %s `%s'" (if (symbolp var) "constant" "nonvariable") - var)))) + (prin1-to-string var))))) (byte-compile-normal-call form))) =20 (defun byte-compile-quote (form) (byte-compile-constant (car (cdr form)))) - -;;; control structures =20 (defun byte-compile-body (body &optional for-effect) (while (cdr body) @@ -4264,11 +4093,11 @@ byte-compile-ignore (byte-compile-form arg t)) (byte-compile-form nil)) =20 -;; Return the list of items in CONDITION-PARAM that match PRED-LIST. -;; Only return items that are not in ONLY-IF-NOT-PRESENT. (defun byte-compile-find-bound-condition (condition-param pred-list &optional only-if-not-present) + "Return the list of items in CONDITION-PARAM that match PRED-LIST. +Only return items that are not in ONLY-IF-NOT-PRESENT." (let ((result nil) (nth-one nil) (cond-list @@ -4604,16 +4433,13 @@ byte-compile-while (defun byte-compile-funcall (form) (if (cdr form) (progn - (mapc 'byte-compile-form (cdr form)) + (mapc #'byte-compile-form (cdr form)) (byte-compile-out 'byte-call (length (cdr (cdr form))))) (byte-compile-report-error (format-message "`funcall' called with no arguments")) (byte-compile-form '(signal 'wrong-number-of-arguments '(funcall 0)) byte-compile--for-effect))) =20 - -;; let binding - (defun byte-compile-push-binding-init (clause) "Emit byte-codes to push the initialization value for CLAUSE on the stac= k. Return the offset in the form (VAR . OFFSET)." @@ -4727,7 +4553,7 @@ byte-compile-let (byte-compile-unbind clauses init-lexenv (> byte-compile-depth init-stack-depth)))))) =20 - + =20 (byte-defop-compiler-1 /=3D byte-compile-negated) (byte-defop-compiler-1 atom byte-compile-negated) @@ -4749,8 +4575,6 @@ byte-compile-negation-optimizer "Compiler error: `%s' has no `byte-compile-negated-op' property" (car form))) (cdr form)))) - -;;; other tricky macro-like special-forms =20 (byte-defop-compiler-1 catch) (byte-defop-compiler-1 unwind-protect) @@ -4758,8 +4582,6 @@ condition-case (byte-defop-compiler-1 save-excursion) (byte-defop-compiler-1 save-current-buffer) (byte-defop-compiler-1 save-restriction) -;; (byte-defop-compiler-1 save-window-excursion) ;Obsolete: now a mac= ro. -;; (byte-defop-compiler-1 with-output-to-temp-buffer) ;Obsolete: now a mac= ro. =20 (defun byte-compile-catch (form) (byte-compile-form (car (cdr form))) @@ -4793,16 +4615,15 @@ byte-compile-condition-case failure-handlers)) (endtag (byte-compile-make-tag))) (unless (symbolp var) - (byte-compile-warn-x - var "`%s' is not a variable-name or nil (in condition-case)" var)) + (byte-compile-warn "`%s' is not a variable-name or nil (in condition= -case)" + var)) =20 (dolist (clause (reverse clauses)) (let ((condition (nth 1 clause))) (unless (consp condition) (setq condition (list condition))) (dolist (c condition) (unless (and c (symbolp c)) - (byte-compile-warn-x - c "`%S' is not a condition name (in condition-case)" c)) + (byte-compile-warn "`%S' is not a condition name (in condition= -case)" c)) ;; In reality, the `error-conditions' property is only required ;; for the argument to `signal', not to `condition-case'. ;;(unless (consp (get c 'error-conditions)) @@ -4853,8 +4674,7 @@ byte-compile-condition-case (defun byte-compile-save-excursion (form) (if (and (eq 'set-buffer (car-safe (car-safe (cdr form)))) (byte-compile-warning-enabled-p 'suspicious 'set-buffer)) - (byte-compile-warn-x - form + (byte-compile-warn "Use `with-current-buffer' rather than save-excursion+set-buffer")) (byte-compile-out 'byte-save-excursion 0) (byte-compile-body-do-effect (cdr form)) @@ -4869,7 +4689,7 @@ byte-compile-save-current-buffer (byte-compile-out 'byte-save-current-buffer 0) (byte-compile-body-do-effect (cdr form)) (byte-compile-out 'byte-unbind 1)) - + ;;; top-level forms elsewhere =20 (byte-defop-compiler-1 defvar) @@ -4895,10 +4715,8 @@ byte-compile-defvar (when (and (symbolp (nth 1 form)) (not (string-match "[-*/:$]" (symbol-name (nth 1 form)))) (byte-compile-warning-enabled-p 'lexical (nth 1 form))) - (byte-compile-warn-x - (nth 1 form) - "global/dynamic var `%s' lacks a prefix" - (nth 1 form))) + (byte-compile-warn "global/dynamic var `%s' lacks a prefix" + (nth 1 form))) (byte-compile-docstring-length-warn form) (let ((fun (nth 0 form)) (var (nth 1 form)) @@ -4907,21 +4725,17 @@ byte-compile-defvar (when (or (> (length form) 4) (and (eq fun 'defconst) (null (cddr form)))) (let ((ncall (length (cdr form)))) - (byte-compile-warn-x - fun - "`%s' called with %d argument%s, but %s %s" - fun ncall - (if (=3D 1 ncall) "" "s") - (if (< ncall 2) "requires" "accepts only") - "2-3"))) + (byte-compile-warn "`%s' called with %d argument%s, but %s %s" + fun ncall + (if (=3D 1 ncall) "" "s") + (if (< ncall 2) "requires" "accepts only") + "2-3"))) (push var byte-compile-bound-variables) - (if (eq fun 'defconst) - (push var byte-compile-const-variables)) + (when (eq fun 'defconst) + (push var byte-compile-const-variables)) (when (and string (not (stringp string))) - (byte-compile-warn-x - string - "third arg to `%s %s' is not a string: %s" - fun var string)) + (byte-compile-warn "third arg to `%s %s' is not a string: %s" + fun var string)) (byte-compile-form-do-effect (if (cddr form) ; `value' provided ;; Quote with `quote' to prevent byte-compiling the body, @@ -4940,33 +4754,23 @@ byte-compile-autoload (macroexp-const-p (nth 5 form)) (memq (eval (nth 5 form)) '(t macro)) ; macro-p (not (fboundp (eval (nth 1 form)))) - (byte-compile-warn-x - form + (byte-compile-warn "The compiler ignores `autoload' except at top level. You should probably put the autoload of the macro `%s' at top-level." (eval (nth 1 form)))) (byte-compile-normal-call form)) =20 -;; Lambdas in valid places are handled as special cases by various code. -;; The ones that remain are errors. (defun byte-compile-lambda-form (_form) + "Any lambdas heretofore unhandled are errors." (error "`lambda' used as function name is invalid")) =20 -;; Compile normally, but deal with warnings for the function being defined. (put 'defalias 'byte-hunk-handler 'byte-compile-file-form-defalias) -;; Used for eieio--defalias as well. (defun byte-compile-file-form-defalias (form) - ;; For the compilation itself, we could largely get rid of this hunk-han= dler, - ;; if it weren't for the fact that we need to figure out when a defalias - ;; defines a macro, so as to add it to byte-compile-macro-environment. - ;; - ;; FIXME: we also use this hunk-handler to implement the function's - ;; dynamic docstring feature (via byte-compile-file-form-defmumble). - ;; We should actually implement it (more elegantly) in - ;; byte-compile-lambda so it applies to all lambdas. We did it here - ;; so the resulting .elc format was recognizable by make-docfile, - ;; but since then we stopped using DOC for the docstrings of - ;; preloaded elc files so that obstacle is gone. + "When a defalias defines a macro, add it to byte-compile-macro-environme= nt. + +This should be subsumed in byte-compile-lambda now that +make-docfile is obsolete (and consequently, the elc docstrings no +longer need to hew to its rules)." (let ((byte-compile-free-references nil) (byte-compile-free-assignments nil)) (pcase form @@ -4993,22 +4797,9 @@ byte-compile-file-form-defalias (and `(internal-make-closure ,arglist . ,_) (let body t)) (and (let arglist t) (let body t))) lam)) - (unless (byte-compile-file-form-defmumble - name macro arglist body rest) - (when macro - (if (null fun) - (message "Macro %s unrecognized, won't work in file" name) - (message "Macro %s partly recognized, trying our luck" name) - (push (cons name (eval fun)) - byte-compile-macro-environment))) + (unless (byte-compile-file-form-defalias* name macro arglist + body rest) (byte-compile-keep-pending form)))) - - ;; We used to just do: (byte-compile-normal-call form) - ;; But it turns out that this fails to optimize the code. - ;; So instead we now do the same as what other byte-hunk-handlers do, - ;; which is to call back byte-compile-file-form and then return nil. - ;; Except that we can't just call byte-compile-file-form since it wo= uld - ;; call us right back. (_ (byte-compile-keep-pending form))))) =20 (byte-defop-compiler-1 with-no-warnings byte-compile-no-warnings) @@ -5027,11 +4818,10 @@ byte-compile-suppressed-warnings (byte-defop-compiler-1 make-variable-buffer-local byte-compile-make-variable-buffer-local) (defun byte-compile-make-variable-buffer-local (form) - (if (and (eq (car-safe (car-safe (cdr-safe form))) 'quote) - (byte-compile-warning-enabled-p 'make-local)) - (byte-compile-warn-x - form - "`make-variable-buffer-local' not called at toplevel")) + (when (and (eq (car-safe (car-safe (cdr-safe form))) 'quote) + (byte-compile-warning-enabled-p 'make-local)) + (byte-compile-warn + "`make-variable-buffer-local' not called at toplevel")) (byte-compile-normal-call form)) (put 'make-variable-buffer-local 'byte-hunk-handler 'byte-compile-form-make-variable-buffer-local) @@ -5070,13 +4860,10 @@ byte-compile-define-symbol-prop . (,prop ,val ,@(alist-get fun overriding-plist-environment= ))) overriding-plist-environment) (byte-compile-push-constant val) - (byte-compile-out 'byte-call 3) - nil)) - + (byte-compile-out 'byte-call 3))) (_ (byte-compile-keep-pending form)))) =20 =20 - ;;; tags =20 ;; Note: Most operations will strip off the 'TAG, but it speeds up @@ -5122,37 +4909,29 @@ byte-compile-stack-adjustment (defun byte-compile-out (op &optional operand) (push (cons op operand) byte-compile-output) (if (eq op 'byte-return) - ;; This is actually an unnecessary case, because there should be no - ;; more ops behind byte-return. + ;; Consider abort since byte-return no longer produces ops (setq byte-compile-depth nil) (setq byte-compile-depth (+ byte-compile-depth (byte-compile-stack-adjustment op operand))) - (setq byte-compile-maxdepth (max byte-compile-depth byte-compile-maxde= pth)) - ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow= ")) - )) - -;;; call tree stuff + (setq byte-compile-maxdepth (max byte-compile-depth byte-compile-maxde= pth)))) =20 (defun byte-compile-annotate-call-tree (form) - (let ((current-form (byte-run-strip-symbol-positions - byte-compile-current-form)) - (bare-car-form (byte-run-strip-symbol-positions (car form))) - entry) + (let (entry) ;; annotate the current call - (if (setq entry (assq bare-car-form byte-compile-call-tree)) - (or (memq current-form (nth 1 entry)) ;callers + (if (setq entry (assq (car form) byte-compile-call-tree)) + (or (memq byte-compile-current-func (nth 1 entry)) ;callers (setcar (cdr entry) - (cons current-form (nth 1 entry)))) + (cons byte-compile-current-func (nth 1 entry)))) (setq byte-compile-call-tree - (cons (list bare-car-form (list current-form) nil) + (cons (list (car form) (list byte-compile-current-func) nil) byte-compile-call-tree))) ;; annotate the current function - (if (setq entry (assq current-form byte-compile-call-tree)) - (or (memq bare-car-form (nth 2 entry)) ;called + (if (setq entry (assq byte-compile-current-func byte-compile-call-tree= )) + (or (memq (car form) (nth 2 entry)) ;called (setcar (cdr (cdr entry)) - (cons bare-car-form (nth 2 entry)))) + (cons (car form) (nth 2 entry)))) (setq byte-compile-call-tree - (cons (list current-form nil (list bare-car-form)) + (cons (list byte-compile-current-func nil (list (car form))) byte-compile-call-tree))))) =20 ;; Renamed from byte-compile-report-call-tree @@ -5178,15 +4957,14 @@ display-call-tree (set-buffer "*Call-Tree*") (erase-buffer) (message "Generating call tree... (sorting on %s)" - (remove-pos-from-symbol byte-compile-call-tree-sort)) + byte-compile-call-tree-sort) (insert "Call tree for " (cond ((null byte-compile-current-file) (or filename "???")) ((stringp byte-compile-current-file) byte-compile-current-file) (t (buffer-name byte-compile-current-file))) " sorted on " - (prin1-to-string (remove-pos-from-symbol - byte-compile-call-tree-sort)) + (prin1-to-string byte-compile-call-tree-sort) ":\n\n") (if byte-compile-call-tree-sort (setq byte-compile-call-tree @@ -5206,8 +4984,7 @@ display-call-tree ('name (lambda (x y) (string< (car x) (car y)))) (_ (error "`byte-compile-call-tree-sort': `%s' - unk= nown sort mode" - (remove-pos-from-symbol - byte-compile-call-tree-sort))))))) + byte-compile-call-tree-sort)))))) (message "Generating call tree...") (let ((rest byte-compile-call-tree) (b (current-buffer)) @@ -5296,7 +5073,7 @@ display-call-tree (fill-region-as-paragraph p (point)))))) (message "Generating call tree...done."))) =20 - + ;;;###autoload (defun batch-byte-compile-if-not-done () "Like `byte-compile-file' but doesn't recompile if already up to date. @@ -5449,7 +5226,7 @@ batch-byte-recompile-directory (provide 'byte-compile) (provide 'bytecomp) =20 - + ;;; report metering (see the hacks in bytecode.c) =20 (defvar byte-code-meter) @@ -5479,30 +5256,28 @@ byte-compile-report-ops (indent-to 40) (insert (int-to-string n) "\n"))) (setq i (1+ i)))))) - -;; To avoid "lisp nesting exceeds max-lisp-eval-depth" when bytecomp compi= les -;; itself, compile some of its most used recursive functions (at load time= ). -;; + +;; Compile at load-time most frequently used recursive methods to +;; avoid "lisp nesting exceeds max-lisp-eval-depth" errors. (eval-when-compile - (or (byte-code-function-p (symbol-function 'byte-compile-form)) - (subr-native-elisp-p (symbol-function 'byte-compile-form)) - (assq 'byte-code (symbol-function 'byte-compile-form)) - (let ((byte-optimize nil) ; do it fast - (byte-compile-warnings nil)) - (mapc (lambda (x) - (unless (subr-native-elisp-p x) - (or noninteractive (message "compiling %s..." x)) - (byte-compile x) - (or noninteractive (message "compiling %s...done" x)))) - '(byte-compile-normal-call - byte-compile-form - byte-compile-body - ;; Inserted some more than necessary, to speed it up. - byte-compile-top-level - byte-compile-out-toplevel - byte-compile-constant - byte-compile-variable-ref)))) - nil) + (prog1 nil + (or (byte-code-function-p (symbol-function 'byte-compile-form)) + (subr-native-elisp-p (symbol-function 'byte-compile-form)) + (assq 'byte-code (symbol-function 'byte-compile-form)) + (let ((byte-optimize nil) ; do it fast + (byte-compile-warnings nil)) + (mapc (lambda (x) + (unless (subr-native-elisp-p x) + (or noninteractive (message "compiling %s..." x)) + (byte-compile x) + (or noninteractive (message "compiling %s...done" x)))) + '(byte-compile-normal-call + byte-compile-form + byte-compile-body + byte-compile-top-level + byte-compile-out-top-level + byte-compile-constant + byte-compile-variable-ref)))))) =20 (make-obsolete-variable 'bytecomp-load-hook "use `with-eval-after-load' instead." "28.1") diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index c16619bc45d..70bc9de0941 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -262,7 +262,7 @@ cconv--warn-unused-msg (eq var 'ignored)) (let ((suggestions (help-uni-confusable-suggestions (symbol-name va= r)))) (format "Unused lexical %s `%S'%s" - varkind (bare-symbol var) + varkind var (if suggestions (concat "\n " suggestions) ""))))) =20 (define-inline cconv--var-classification (binder form) @@ -286,7 +286,7 @@ cconv--convert-funcbody (let (and (pred stringp) msg) (cconv--warn-unused-msg arg "argument"))) (if (assq arg env) (push `(,arg . nil) env)) ;FIXME: Is it needed? - (push (lambda (body) (macroexp--warn-wrap arg msg body 'lexical))= wrappers)) + (push (lambda (body) (macroexp--warn-wrap msg body 'lexical)) wra= ppers)) (_ (if (assq arg env) (push `(,arg . nil) env))))) (setq funcbody (mapcar (lambda (form) @@ -367,8 +367,7 @@ cconv-convert (var (if (not (consp binder)) (prog1 binder (setq binder (list binder))) (when (cddr binder) - (byte-compile-warn-x - binder + (byte-compile-warn "Malformed `%S' binding: %S" letsym binder)) (setq value (cadr binder)) @@ -376,9 +375,9 @@ cconv-convert (cond ;; Ignore bindings without a valid name. ((not (symbolp var)) - (byte-compile-warn-x var "attempt to let-bind nonvariable `%S= '" var)) + (byte-compile-warn "attempt to let-bind nonvariable `%S'" var= )) ((or (booleanp var) (keywordp var)) - (byte-compile-warn-x var "attempt to let-bind constant `%S'" = var)) + (byte-compile-warn "attempt to let-bind constant `%S'" var)) (t (let ((new-val (pcase (cconv--var-classification binder form) @@ -428,14 +427,11 @@ cconv-convert ;; Declared variable is unused. (if (assq var new-env) (push `(,var) new-env)) ;FIXME:Needed? - (let* ((Ignore (if (symbol-with-pos-p var) - (position-symbol 'ignore var) - 'ignore)) - (newval `(,Ignore - ,(cconv-convert value env extend))) - (msg (cconv--warn-unused-msg var "variable")= )) + (let ((newval + `(ignore ,(cconv-convert value env extend))) + (msg (cconv--warn-unused-msg var "variable"))) (if (null msg) newval - (macroexp--warn-wrap var msg newval 'lexical)))) + (macroexp--warn-wrap msg newval 'lexical)))) =20 ;; Normal default case. (_ @@ -534,7 +530,7 @@ cconv-convert (newprotform (cconv-convert protected-form env extend))) `(condition-case ,var ,(if msg - (macroexp--warn-wrap var msg newprotform 'lexical) + (macroexp--warn-wrap msg newprotform 'lexical) newprotform) ,@(mapcar (lambda (handler) @@ -628,8 +624,7 @@ cconv--analyze-use ;; FIXME: Convert this warning to use `macroexp--warn-wrap' ;; so as to give better position information. (when (byte-compile-warning-enabled-p 'not-unused var) - (byte-compile-warn-x - var "%s `%S' not left unused" varkind var))) + (byte-compile-warn "%s `%S' not left unused" varkind var))) ((and (let (or 'let* 'let) (car form)) `((,var) ;; (or `(,var nil) : Too many false positives: bug#47080 t nil ,_ ,_)) @@ -637,7 +632,7 @@ cconv--analyze-use ;; so as to give better position information and obey ;; `byte-compile-warnings'. (unless (not (intern-soft var)) - (byte-compile-warn-x var "Variable `%S' left uninitialized" var)))) + (byte-compile-warn "Variable `%S' left uninitialized" var)))) (pcase vardata (`(,binder nil ,_ ,_ nil) (push (cons (cons binder form) :unused) cconv-var-classification)) @@ -666,8 +661,7 @@ cconv--analyze-function (dolist (arg args) (cond ((byte-compile-not-lexical-var-p arg) - (byte-compile-warn-x - arg + (byte-compile-warn "Lexical argument shadows the dynamic variable %S" arg)) ((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, = ... @@ -750,8 +744,7 @@ cconv-analyze-form (setq forms (cddr forms)))) =20 (`((lambda . ,_) . ,_) ; First element is lambda expressio= n. - (byte-compile-warn-x - (nth 1 (car form)) + (byte-compile-warn "Use of deprecated ((lambda %s ...) ...) form" (nth 1 (car form))) (dolist (exp `((function ,(car form)) . ,(cdr form))) (cconv-analyze-form exp env))) @@ -770,8 +763,8 @@ cconv-analyze-form (`(condition-case ,var ,protected-form . ,handlers) (cconv-analyze-form protected-form env) (when (and var (symbolp var) (byte-compile-not-lexical-var-p var)) - (byte-compile-warn-x - var "Lexical variable shadows the dynamic variable %S" var)) + (byte-compile-warn + "Lexical variable shadows the dynamic variable %S" var)) (let* ((varstruct (list var nil nil nil nil))) (if var (push varstruct env)) (dolist (handler handlers) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 5e0e0834fff..a7d25d070f0 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -498,8 +498,7 @@ cl-defmethod cl--generic-edebug-make-name nil] lambda-doc ; documentation string def-body))) ; part to be debugged - (let ((qualifiers nil) - (org-name name)) + (let ((qualifiers nil)) (while (cl-generic--method-qualifier-p args) (push args qualifiers) (setq args (pop body))) @@ -512,9 +511,8 @@ cl-defmethod ,(and (get name 'byte-obsolete-info) (or (not (fboundp 'byte-compile-warning-enabled-p)) (byte-compile-warning-enabled-p 'obsolete name)) - (let* ((obsolete (get name 'byte-obsolete-info))) + (let ((obsolete (get name 'byte-obsolete-info))) (macroexp-warn-and-return - org-name (macroexp--obsolete-warning name obsolete "generic funct= ion") nil))) ;; You could argue that `defmethod' modifies rather than defines = the diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 470168177ca..6fcf3ccfb5d 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -748,7 +748,7 @@ cl-load-time-value (if (macroexp-compiling-p) (let* ((temp (cl-gentemp "--cl-load-time--")) (set `(setq ,temp ,form))) - (if (and (fboundp 'byte-compile-file-form-defmumble) + (if (and (fboundp 'byte-compile-file-form-defalias*) (boundp 'this-kind) (boundp 'that-one)) ;; Else, we can't output right away, so we have to delay it to= the ;; next time we're at the top-level. @@ -2429,12 +2429,10 @@ cl-symbol-macrolet (append bindings venv)) macroexpand-all-environment)))) (if malformed-bindings - (let ((rev-malformed-bindings (nreverse malformed-bindings= ))) - (macroexp-warn-and-return - rev-malformed-bindings - (format-message "Malformed `cl-symbol-macrolet' binding= (s): %S" - rev-malformed-bindings) - expansion)) + (macroexp-warn-and-return + (format-message "Malformed `cl-symbol-macrolet' binding(s= ): %S" + (nreverse malformed-bindings)) + expansion) expansion))) (unless advised (advice-remove 'macroexpand #'cl--sm-macroexpand))))) @@ -3118,7 +3116,6 @@ cl-defstruct (when (cl-oddp (length desc)) (push (macroexp-warn-and-return - (car (last desc)) (format "Missing value for option `%S' of slot `%s' in s= truct %s!" (car (last desc)) slot name) 'nil) @@ -3128,7 +3125,6 @@ cl-defstruct (let ((kw (car defaults))) (push (macroexp-warn-and-return - kw (format " I'll take `%s' to be an option rather tha= n a default value." kw) 'nil) diff --git a/lisp/emacs-lisp/cldefs.el.in b/lisp/emacs-lisp/cldefs.el.in new file mode 100644 index 00000000000..a88633d2864 --- /dev/null +++ b/lisp/emacs-lisp/cldefs.el.in @@ -0,0 +1,17 @@ +(require 'gv) + +(defconst cldefs--cl-lib-functions + (let (load-history) + (require 'cl-lib) + (require 'cl-macs) + (require 'cl-seq) + (mapcan + (lambda (defines) + (delq nil (mapcar + (lambda (define) + (when (memq (car-safe define) '(defun t)) + (cdr define))) + defines))) + (mapcar #'cdr load-history))) + "Since cl-lib has yet to join loadup.el, we must flag user code which +does not first require it before using its functions. (Bug#30635)") diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 122638077ce..ad00b2ef4ab 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3570,7 +3570,7 @@ comp-finalize-relocs ;; Symbols imported by C inlined functions. We do this here because ;; is better to add all objs to the relocation containers before we ;; compacting them. - (mapc #'comp-add-const-to-relocs '(nil t consp listp symbol-with-pos-p)) + (mapc #'comp-add-const-to-relocs '(nil t consp listp)) =20 (let* ((d-default (comp-ctxt-d-default comp-ctxt)) (d-default-idx (comp-data-container-idx d-default)) @@ -4006,12 +4006,9 @@ comp--native-compile (signal 'native-compiler-error (list "Not a function symbol or file" function-or-file))) (catch 'no-native-compile - (let* ((print-symbols-bare t) - (max-specpdl-size (max max-specpdl-size 5000)) - (data function-or-file) + (let* ((data function-or-file) (comp-native-compiling t) (byte-native-qualities nil) - (symbols-with-pos-enabled t) ;; Have byte compiler signal an error when compilation fails. (byte-compile-debug t) (comp-ctxt (make-comp-ctxt :output output @@ -4055,10 +4052,10 @@ comp--native-compile (signal (car err) (if (consp err-val) (cons function-or-file err-val) (list function-or-file err-val))))))) - (if (stringp function-or-file) - data - ;; So we return the compiled function. - (native-elisp-load data))))) + (if (stringp function-or-file) + data + ;; So we return the compiled function. + (native-elisp-load data))))) =20 (defun native-compile-async-skip-p (file load selector) "Return non-nil if FILE's compilation should be skipped. diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 7bcb2f2936d..688c76e0c54 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -230,7 +230,6 @@ define-minor-mode (warnwrap (if (or (null body) (keywordp (car body))) #'identity (lambda (exp) (macroexp-warn-and-return - exp "Use keywords rather than deprecated positional ar= guments to `define-minor-mode'" exp)))) keyw keymap-sym tmp) diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 45ded158990..95b755bf762 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -748,7 +748,6 @@ eieio-oref ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-slot-names)))) (macroexp-warn-and-return - name (format-message "Unknown slot `%S'" name) exp nil 'compile-only)) (_ exp)))) @@ -785,13 +784,11 @@ eieio-oref-default ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-slot-names)))) (macroexp-warn-and-return - name (format-message "Unknown slot `%S'" name) exp nil 'compile-only)) ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-class-slot-names= )))) (macroexp-warn-and-return - name (format-message "Slot `%S' is not class-allocated" name) exp nil 'compile-only)) (_ exp))))) @@ -849,13 +846,11 @@ eieio-oset-default ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-slot-names)))) (macroexp-warn-and-return - name (format-message "Unknown slot `%S'" name) exp nil 'compile-only)) ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-class-slot-names= )))) (macroexp-warn-and-return - name (format-message "Slot `%S' is not class-allocated" name) exp nil 'compile-only)) (_ exp))))) diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 6f97c25ca96..5198e344697 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -245,8 +245,7 @@ defclass =20 `(progn ,@(mapcar (lambda (w) - (macroexp-warn-and-return - (car w) (cdr w) `(progn ',(cdr w)) nil 'compile-only)) + (macroexp-warn-and-return w `(progn ',w) nil 'compile-o= nly)) warnings) ;; This test must be created right away so we can have self- ;; referencing classes. ei, a class whose slot can contain only @@ -296,7 +295,6 @@ defclass (if (not (stringp (car slots))) whole (macroexp-warn-and-return - (car slots) (format "Obsolete name arg %S to constructor %= S" (car slots) (car whole)) ;; Keep the name arg, for backward compatibili= ty, diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index 91538d1f06e..1e9793261f9 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -581,9 +581,7 @@ gv-ref Note: this only works reliably with lexical binding mode, except for very simple PLACEs such as (symbol-function \\=3D'foo) which will also work in = dynamic binding mode." - (let ((org-place place) ; It's too difficult to determine by inspection = whether - ; the functions modify place. - (code + (let ((code (gv-letplace (getter setter) place `(cons (lambda () ,getter) (lambda (gv--val) ,(funcall setter 'gv--val)))))) @@ -595,7 +593,6 @@ gv-ref (eq (car-safe code) 'cons)) code (macroexp-warn-and-return - org-place "Use of gv-ref probably requires lexical-binding" code)))) =20 diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 256092599b2..6e0027092d9 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -28,17 +28,6 @@ =20 ;;; Code: =20 -(defvar byte-compile-form-stack nil - "Dynamic list of successive enclosing forms. -This is used by the warning message routines to determine a -source code position. The most accessible element is the current -most deeply nested form. - -Normally a form is manually pushed onto the list at the beginning -of `byte-compile-form', etc., and manually popped off at its end. -This is to preserve the data in it in the event of a -condition-case handling a signaled error.") - ;; Bound by the top-level `macroexpand-all', and modified to include any ;; macros defined by `defmacro'. (defvar macroexpand-all-environment nil) @@ -107,10 +96,9 @@ macroexp--all-clauses =20 (defun macroexp--compiler-macro (handler form) (condition-case-unless-debug err - (let ((symbols-with-pos-enabled t)) - (apply handler form (cdr form))) + (apply handler form (cdr form)) (error - (message "Compiler-macro error for %S: Handler: %S\n%S" (car form) ha= ndler err) + (message "Compiler-macro error for %S: %S" (car form) err) form))) =20 (defun macroexp--funcall-if-compiled (_form) @@ -147,23 +135,21 @@ macroexp-file-name =20 (defvar macroexp--warned (make-hash-table :test #'equal :weakness 'key)) =20 -(defun macroexp--warn-wrap (arg msg form category) +(defun macroexp--warn-wrap (msg form category) (let ((when-compiled (lambda () (when (if (consp category) (apply #'byte-compile-warning-enabled-p category) (byte-compile-warning-enabled-p category)) - (byte-compile-warn-x arg "%s" msg))))) + (byte-compile-warn "%s" msg))))) `(progn (macroexp--funcall-if-compiled ',when-compiled) ,form))) =20 (define-obsolete-function-alias 'macroexp--warn-and-return #'macroexp-warn-and-return "28.1") -(defun macroexp-warn-and-return (arg msg form &optional category compile-o= nly) +(defun macroexp-warn-and-return (msg form &optional category compile-only) "Return code equivalent to FORM labeled with warning MSG. -ARG is a symbol (or a form) giving the source code position of FORM -for the message. It should normally be a symbol with position. CATEGORY is the category of the warning, like the categories that can appear in `byte-compile-warnings'. COMPILE-ONLY non-nil means no warning should be emitted if the code @@ -177,7 +163,7 @@ macroexp-warn-and-return ;; macroexpand-all gets right back to macroexpanding `form'. form (puthash form form macroexp--warned) - (macroexp--warn-wrap arg msg form category))) + (macroexp--warn-wrap msg form category))) (t (unless compile-only (message "%sWarning: %s" @@ -233,7 +219,6 @@ macroexp-macroexpand (let* ((fun (car form)) (obsolete (get fun 'byte-obsolete-info))) (macroexp-warn-and-return - fun (macroexp--obsolete-warning fun obsolete (if (symbolp (symbol-function fun)) @@ -289,7 +274,6 @@ macroexp--unfold-lambda (setq arglist (cdr arglist))) (if values (macroexp-warn-and-return - arglist (format (if (eq values 'too-few) "attempt to open-code `%s' with too few arguments" "attempt to open-code `%s' with too many arguments") @@ -319,124 +303,119 @@ macroexp--expand-all "Expand all macros in FORM. This is an internal version of `macroexpand-all'. Assumes the caller has bound `macroexpand-all-environment'." - (push form byte-compile-form-stack) - (prog1 - (if (eq (car-safe form) 'backquote-list*) - ;; Special-case `backquote-list*', as it is normally a macro that - ;; generates exceedingly deep expansions from relatively shallow= input - ;; forms. We just process it `in reverse' -- first we expand al= l the - ;; arguments, _then_ we expand the top-level definition. - (macroexpand (macroexp--all-forms form 1) - macroexpand-all-environment) - ;; Normal form; get its expansion, and then expand arguments. - (setq form (macroexp-macroexpand form macroexpand-all-environment)) - ;; FIXME: It'd be nice to use `byte-optimize--pcase' here, but when - ;; I tried it, it broke the bootstrap :-( - (pcase form - (`(cond . ,clauses) - (macroexp--cons 'cond (macroexp--all-clauses clauses) form)) - (`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontca= re)) - (macroexp--cons - 'condition-case - (macroexp--cons err - (macroexp--cons (macroexp--expand-all body) - (macroexp--all-clauses handler= s 1) - (cddr form)) - (cdr form)) - form)) - (`(,(or 'defvar 'defconst) ,(and name (pred symbolp)) . ,_) - (push name macroexp--dynvars) - (macroexp--all-forms form 2)) - (`(function ,(and f `(lambda . ,_))) - (let ((macroexp--dynvars macroexp--dynvars)) - (macroexp--cons 'function - (macroexp--cons (macroexp--all-forms f 2) - nil - (cdr form)) - form))) - (`(,(or 'function 'quote) . ,_) form) - (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) - pcase--dontcare)) - (let ((macroexp--dynvars macroexp--dynvars)) - (macroexp--cons - fun - (macroexp--cons - (macroexp--all-clauses bindings 1) - (if (null body) - (macroexp-unprogn - (macroexp-warn-and-return - fun - (format "Empty %s body" fun) - nil nil 'compile-only)) - (macroexp--all-forms body)) - (cdr form)) - form))) - (`(,(and fun `(lambda . ,_)) . ,args) - ;; Embedded lambda in function position. - ;; If the byte-optimizer is loaded, try to unfold this, - ;; i.e. rewrite it to (let () ). We'd do it in the= optimizer - ;; anyway, but doing it here (i.e. earlier) can sometimes avoid= the - ;; creation of a closure, thus resulting in much better code. - (let ((newform (macroexp--unfold-lambda form))) - (if (eq newform form) - ;; Unfolding failed for some reason, avoid infinite recursion. - (macroexp--cons (macroexp--all-forms fun 2) - (macroexp--all-forms args) - form) - (macroexp--expand-all newform)))) - (`(funcall ,exp . ,args) - (let ((eexp (macroexp--expand-all exp)) - (eargs (macroexp--all-forms args))) - ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo' - ;; has a compiler-macro, or to unfold it. - (pcase eexp - ((and `#',f - (guard (not (or (special-form-p f) (macrop f))))) ;; = bug#46636 - (macroexp--expand-all `(,f . ,eargs))) - (_ `(funcall ,eexp . ,eargs))))) - (`(funcall . ,_) form) ;bug#53227 - (`(,func . ,_) - (let ((handler (function-get func 'compiler-macro)) - (funargs (function-get func 'funarg-positions))) - ;; Check functions quoted with ' rather than with #' - (dolist (funarg funargs) - (let ((arg (nth funarg form))) - (when (and (eq 'quote (car-safe arg)) - (eq 'lambda (car-safe (cadr arg)))) - (setcar (nthcdr funarg form) - (macroexp-warn-and-return - (cadr arg) - (format "%S quoted with ' rather than with #'" - (let ((f (cadr arg))) - (if (symbolp f) f `(lambda ,(nth 1 f= ) ...)))) - arg))))) - ;; Macro expand compiler macros. This cannot be delayed to - ;; byte-optimize-form because the output of the compiler-macr= o can - ;; use macros. - (if (null handler) - ;; No compiler macro. We just expand each argument (for - ;; setq/setq-default this works alright because the varia= ble names - ;; are symbols). - (macroexp--all-forms form 1) - ;; If the handler is not loaded yet, try (auto)loading the - ;; function itself, which may in turn load the handler. - (unless (functionp handler) - (with-demoted-errors "macroexp--expand-all: %S" - (autoload-do-load (indirect-function func) func))) - (let ((newform (macroexp--compiler-macro handler form))) - (if (eq form newform) - ;; The compiler macro did not find anything to do. - (if (equal form (setq newform (macroexp--all-forms fo= rm 1))) - form - ;; Maybe after processing the args, some new opport= unities - ;; appeared, so let's try the compiler macro again. - (setq form (macroexp--compiler-macro handler newfor= m)) - (if (eq newform form) - newform - (macroexp--expand-all newform))) - (macroexp--expand-all newform)))))) - (_ form))) - (pop byte-compile-form-stack))) + (if (eq (car-safe form) 'backquote-list*) + ;; Special-case `backquote-list*', as it is normally a macro that + ;; generates exceedingly deep expansions from relatively shallow inp= ut + ;; forms. We just process it `in reverse' -- first we expand all the + ;; arguments, _then_ we expand the top-level definition. + (macroexpand (macroexp--all-forms form 1) + macroexpand-all-environment) + ;; Normal form; get its expansion, and then expand arguments. + (setq form (macroexp-macroexpand form macroexpand-all-environment)) + ;; FIXME: It'd be nice to use `byte-optimize--pcase' here, but when + ;; I tried it, it broke the bootstrap :-( + (pcase form + (`(cond . ,clauses) + (macroexp--cons 'cond (macroexp--all-clauses clauses) form)) + (`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare)) + (macroexp--cons + 'condition-case + (macroexp--cons err + (macroexp--cons (macroexp--expand-all body) + (macroexp--all-clauses handlers 1) + (cddr form)) + (cdr form)) + form)) + (`(,(or 'defvar 'defconst) ,(and name (pred symbolp)) . ,_) + (push name macroexp--dynvars) + (macroexp--all-forms form 2)) + (`(function ,(and f `(lambda . ,_))) + (let ((macroexp--dynvars macroexp--dynvars)) + (macroexp--cons 'function + (macroexp--cons (macroexp--all-forms f 2) + nil + (cdr form)) + form))) + (`(,(or 'function 'quote) . ,_) form) + (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) + pcase--dontcare)) + (let ((macroexp--dynvars macroexp--dynvars)) + (macroexp--cons + fun + (macroexp--cons + (macroexp--all-clauses bindings 1) + (if (null body) + (macroexp-unprogn + (macroexp-warn-and-return + (format "Empty %s body" fun) + nil nil 'compile-only)) + (macroexp--all-forms body)) + (cdr form)) + form))) + (`(,(and fun `(lambda . ,_)) . ,args) + ;; Embedded lambda in function position. + ;; If the byte-optimizer is loaded, try to unfold this, + ;; i.e. rewrite it to (let () ). We'd do it in the opt= imizer + ;; anyway, but doing it here (i.e. earlier) can sometimes avoid the + ;; creation of a closure, thus resulting in much better code. + (let ((newform (macroexp--unfold-lambda form))) + (if (eq newform form) + ;; Unfolding failed for some reason, avoid infinite recursion. + (macroexp--cons (macroexp--all-forms fun 2) + (macroexp--all-forms args) + form) + (macroexp--expand-all newform)))) + (`(funcall ,exp . ,args) + (let ((eexp (macroexp--expand-all exp)) + (eargs (macroexp--all-forms args))) + ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo' + ;; has a compiler-macro, or to unfold it. + (pcase eexp + ((and `#',f + (guard (not (or (special-form-p f) (macrop f))))) ;; bug#= 46636 + (macroexp--expand-all `(,f . ,eargs))) + (_ `(funcall ,eexp . ,eargs))))) + (`(funcall . ,_) form) ;bug#53227 + (`(,func . ,_) + (let ((handler (function-get func 'compiler-macro)) + (funargs (function-get func 'funarg-positions))) + ;; Check functions quoted with ' rather than with #' + (dolist (funarg funargs) + (let ((arg (nth funarg form))) + (when (and (eq 'quote (car-safe arg)) + (eq 'lambda (car-safe (cadr arg)))) + (setcar (nthcdr funarg form) + (macroexp-warn-and-return + (format "%S quoted with ' rather than with #'" + (let ((f (cadr arg))) + (if (symbolp f) f `(lambda ,(nth 1 f) ..= .)))) + arg))))) + ;; Macro expand compiler macros. This cannot be delayed to + ;; byte-optimize-form because the output of the compiler-macro can + ;; use macros. + (if (null handler) + ;; No compiler macro. We just expand each argument (for + ;; setq/setq-default this works alright because the variable = names + ;; are symbols). + (macroexp--all-forms form 1) + ;; If the handler is not loaded yet, try (auto)loading the + ;; function itself, which may in turn load the handler. + (unless (functionp handler) + (with-demoted-errors "macroexp--expand-all: %S" + (autoload-do-load (indirect-function func) func))) + (let ((newform (macroexp--compiler-macro handler form))) + (if (eq form newform) + ;; The compiler macro did not find anything to do. + (if (equal form (setq newform (macroexp--all-forms form 1= ))) + form + ;; Maybe after processing the args, some new opportunit= ies + ;; appeared, so let's try the compiler macro again. + (setq form (macroexp--compiler-macro handler newform)) + (if (eq newform form) + newform + (macroexp--expand-all newform))) + (macroexp--expand-all newform)))))) + (_ form)))) =20 ;; Record which arguments expect functions, so we can warn when those ;; are accidentally quoted with ' rather than with #' @@ -464,7 +443,7 @@ macroexpand-all ;; This function is like `macroexpand-all' but for use with top-level ;; forms. It does not dynbind `macroexp--dynvars' because we want ;; top-level `defvar' declarations to be recorded in that variable. -(defun macroexpand--all-toplevel (form &optional environment) +(defun macroexpand--all-top-level (form &optional environment) (let ((macroexpand-all-environment environment)) (macroexp--expand-all form))) =20 @@ -726,40 +705,38 @@ macroexp--debug-eager =20 (defun internal-macroexpand-for-load (form full-p) ;; Called from the eager-macroexpansion in readevalloop. - (let ((symbols-with-pos-enabled t) - (print-symbols-bare t)) - (cond - ;; Don't repeat the same warning for every top-level element. - ((eq 'skip (car macroexp--pending-eager-loads)) form) - ;; If we detect a cycle, skip macro-expansion for now, and output a w= arning - ;; with a trimmed backtrace. - ((and load-file-name (member load-file-name macroexp--pending-eager-l= oads)) - (let* ((bt (delq nil - (mapcar #'macroexp--trim-backtrace-frame - (macroexp--backtrace)))) - (elem `(load ,(file-name-nondirectory load-file-name))) - (tail (member elem (cdr (member elem bt))))) - (if tail (setcdr tail (list '=E2=80=A6))) - (if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt))) - (if macroexp--debug-eager - (debug 'eager-macroexp-cycle) - (message "Warning: Eager macro-expansion skipped due to cycle:\n= %s" - (mapconcat #'prin1-to-string (nreverse bt) " =3D> "))) - (push 'skip macroexp--pending-eager-loads) - form)) - (t - (condition-case err - (let ((macroexp--pending-eager-loads - (cons load-file-name macroexp--pending-eager-loads))) - (if full-p - (macroexpand--all-toplevel form) - (macroexpand form))) - (error - ;; Hopefully this shouldn't happen thanks to the cycle detection, - ;; but in case it does happen, let's catch the error and give the - ;; code a chance to macro-expand later. - (message "Eager macro-expansion failure: %S" err) - form)))))) + (cond + ;; Don't repeat the same warning for every top-level element. + ((eq 'skip (car macroexp--pending-eager-loads)) form) + ;; If we detect a cycle, skip macro-expansion for now, and output a war= ning + ;; with a trimmed backtrace. + ((and load-file-name (member load-file-name macroexp--pending-eager-loa= ds)) + (let* ((bt (delq nil + (mapcar #'macroexp--trim-backtrace-frame + (macroexp--backtrace)))) + (elem `(load ,(file-name-nondirectory load-file-name))) + (tail (member elem (cdr (member elem bt))))) + (if tail (setcdr tail (list '=E2=80=A6))) + (if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt))) + (if macroexp--debug-eager + (debug 'eager-macroexp-cycle) + (message "Warning: Eager macro-expansion skipped due to cycle:\n = %s" + (mapconcat #'prin1-to-string (nreverse bt) " =3D> "))) + (push 'skip macroexp--pending-eager-loads) + form)) + (t + (condition-case err + (let ((macroexp--pending-eager-loads + (cons load-file-name macroexp--pending-eager-loads))) + (if full-p + (macroexpand--all-top-level form) + (macroexpand form))) + (error + ;; Hopefully this shouldn't happen thanks to the cycle detection, + ;; but in case it does happen, let's catch the error and give the + ;; code a chance to macro-expand later. + (message "Eager macro-expansion failure: %S" err) + form))))) =20 ;; =C2=A1=C2=A1=C2=A1 Big Ugly Hack !!! ;; src/bootstrap-emacs is mostly used to compile .el files, so it needs diff --git a/lisp/emacs-lisp/multisession.el b/lisp/emacs-lisp/multisession= .el index d6f1ab98faa..a132f9eee4a 100644 --- a/lisp/emacs-lisp/multisession.el +++ b/lisp/emacs-lisp/multisession.el @@ -2,7 +2,7 @@ =20 ;; Copyright (C) 2021-2022 Free Software Foundation, Inc. =20 -;; This file is part of GNU Emacs. +;; This file is NOT part of GNU Emacs. =20 ;; 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 diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index c3dbfe29473..7a82b416e55 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -433,7 +433,6 @@ pcase-compile-patterns (memq (car case) pcase--dontwarn-upats)) (setq main (macroexp-warn-and-return - (car case) (format "pcase pattern %S shadowed by previous pcase patt= ern" (car case)) main)))) @@ -941,7 +940,6 @@ pcase--u1 (let ((code (pcase--u1 matches code vars rest))) (if (eq upat '_) code (macroexp-warn-and-return - upat "Pattern t is deprecated. Use `_' instead" code)))) ((eq upat 'pcase--dontcare) :pcase--dontcare) diff --git a/lisp/help.el b/lisp/help.el index 975be497e77..b13438c163f 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -2083,7 +2083,7 @@ help--make-usage ((symbolp arg) (let ((name (symbol-name arg))) (cond - ((string-match "\\`&" name) (bare-symbol arg)) + ((string-match "\\`&" name) arg) ((string-match "\\`_." name) (intern (upcase (substring name 1)))) (t (intern (upcase name)))))) diff --git a/lisp/keymap.el b/lisp/keymap.el index c0fdf8721b2..4dbf9cf72ff 100644 --- a/lisp/keymap.el +++ b/lisp/keymap.el @@ -462,19 +462,18 @@ define-keymap--compile (keywordp (car args)) (not (eq (car args) :menu))) (unless (memq (car args) '(:full :keymap :parent :suppress :name :pref= ix)) - (byte-compile-warn-x (car args) "Invalid keyword: %s" (car args))) + (byte-compile-warn "Invalid keyword: %s" (car args))) (setq args (cdr args)) (when (null args) - (byte-compile-warn-x form "Uneven number of keywords in %S" form)) + (byte-compile-warn "Uneven number of keywords in %S" form)) (setq args (cdr args))) ;; Bindings. (while args - (let* ((wargs args) - (key (pop args))) + (let ((key (pop args))) (when (and (stringp key) (not (key-valid-p key))) - (byte-compile-warn-x wargs "Invalid `kbd' syntax: %S" key))) + (byte-compile-warn "Invalid `kbd' syntax: %S" key))) (when (null args) - (byte-compile-warn-x form "Uneven number of key bindings in %S" form= )) + (byte-compile-warn "Uneven number of key bindings in %S" form)) (setq args (cdr args))) form) =20 diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 36b8d808417..291c6c439de 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -2442,8 +2442,8 @@ completion-in-region (funcall completion-in-region-function start end collection predicate)) =20 (defcustom read-file-name-completion-ignore-case - (if (memq system-type '(ms-dos windows-nt darwin cygwin)) - t nil) + (when (memq system-type '(ms-dos windows-nt darwin cygwin)) + t) "Non-nil means when reading a file name completion ignores case." :type 'boolean :version "22.1") diff --git a/lisp/sqlite-mode.el b/lisp/sqlite-mode.el index ba1b81ef7e2..b23b5774e39 100644 --- a/lisp/sqlite-mode.el +++ b/lisp/sqlite-mode.el @@ -2,7 +2,7 @@ =20 ;; Copyright (C) 2021-2022 Free Software Foundation, Inc. =20 -;; This file is part of GNU Emacs. +;; This file is NOT part of GNU Emacs. =20 ;; 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 diff --git a/src/Makefile.in b/src/Makefile.in index 186e06735cc..adaec52c7f8 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -482,9 +482,9 @@ ALLOBJS =3D =20 # Must be first, before dep inclusion! ifneq ($(HAVE_BE_APP),yes) -all: emacs$(EXEEXT) $(pdmp) $(OTHER_FILES) +all: emacs$(EXEEXT) $(pdmp) $(lispsource)/emacs-lisp/cldefs.el $(OTHER_FIL= ES) else -all: Emacs Emacs.pdmp $(OTHER_FILES) +all: Emacs Emacs.pdmp $(lispsource)/emacs-lisp/cldefs.el $(OTHER_FILES) endif ifeq ($(HAVE_NATIVE_COMP):$(NATIVE_DISABLED),yes:) all: ../native-lisp @@ -868,7 +868,7 @@ elnlisp :=3D $(addprefix ${lispsource}/,${elnlisp}) $(l= isp: ## native-lisp where the *.eln files will be produced, and the exact ## names of those *.eln files, cannot be known in advance; we must ask ## Emacs to produce them. -../native-lisp: | $(pdmp) +../native-lisp: $(lispsource)/emacs-lisp/cldefs.el | $(pdmp) @if test ! -d $@; then \ mkdir $@ && $(MAKE) $(AM_V_NO_PD) $(elnlisp); \ if test $(SYSTEM_TYPE) =3D cygwin; then \ @@ -890,6 +890,9 @@ $(lispsource)/loaddefs.el: bootstrap-emacs$(EXEEXT) $(bootstrap_pdmp) $(MAKE) -C ../lisp autoloads EMACS=3D"$(bootstrap_exe)" =20 +$(lispsource)/emacs-lisp/cldefs.el: $(pdmp) + $(MAKE) -C ../lisp cldefs EMACS=3D"$(bootstrap_exe)" + ## Dump an Emacs executable named bootstrap-emacs containing the ## files from loadup.el in source form. =20 diff --git a/src/alloc.c b/src/alloc.c index 5d7b484f6ea..12020cdcb2f 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -592,7 +592,7 @@ pointer_align (void *ptr, int alignment) static ATTRIBUTE_NO_SANITIZE_UNDEFINED void * XPNTR (Lisp_Object a) { - return (BARE_SYMBOL_P (a) + return (SYMBOLP (a) ? (char *) lispsym + (XLI (a) - LISP_WORD_TAG (Lisp_Symbol)) : (char *) XLP (a) - (XLI (a) & ~VALMASK)); } @@ -3625,13 +3625,13 @@ #define SYMBOL_BLOCK_SIZE \ static void set_symbol_name (Lisp_Object sym, Lisp_Object name) { - XBARE_SYMBOL (sym)->u.s.name =3D name; + XSYMBOL (sym)->u.s.name =3D name; } =20 void init_symbol (Lisp_Object val, Lisp_Object name) { - struct Lisp_Symbol *p =3D XBARE_SYMBOL (val); + struct Lisp_Symbol *p =3D XSYMBOL (val); set_symbol_name (val, name); set_symbol_plist (val, Qnil); p->u.s.redirect =3D SYMBOL_PLAINVAL; @@ -3694,21 +3694,6 @@ make_misc_ptr (void *a) return make_lisp_ptr (p, Lisp_Vectorlike); } =20 -/* Return a new symbol with position with the specified SYMBOL and POSITIO= N. */ -Lisp_Object -build_symbol_with_pos (Lisp_Object symbol, Lisp_Object position) -{ - Lisp_Object val; - struct Lisp_Symbol_With_Pos *p - =3D (struct Lisp_Symbol_With_Pos *) allocate_vector (2); - XSETVECTOR (val, p); - XSETPVECTYPESIZE (XVECTOR (val), PVEC_SYMBOL_WITH_POS, 2, 0); - p->sym =3D symbol; - p->pos =3D position; - - return val; -} - /* Return a new overlay with specified START, END and PLIST. */ =20 Lisp_Object @@ -5253,7 +5238,7 @@ valid_lisp_object_p (Lisp_Object obj) if (PURE_P (p)) return 1; =20 - if (BARE_SYMBOL_P (obj) && c_symbol_p (p)) + if (SYMBOLP (obj) && c_symbol_p (p)) return ((char *) p - (char *) lispsym) % sizeof lispsym[0] =3D=3D 0; =20 if (p =3D=3D &buffer_defaults || p =3D=3D &buffer_local_symbols) @@ -5685,12 +5670,12 @@ purecopy (Lisp_Object obj) pin_string (vec->contents[1]); XSETVECTOR (obj, vec); } - else if (BARE_SYMBOL_P (obj)) + else if (SYMBOLP (obj)) { - if (!XBARE_SYMBOL (obj)->u.s.pinned && !c_symbol_p (XBARE_SYMBOL (ob= j))) + if (!XSYMBOL (obj)->u.s.pinned && !c_symbol_p (XSYMBOL (obj))) { /* We can't purify them, but they appear in many pure objects. Mark them as `pinned' so we know to mark them at every GC cycle. */ - XBARE_SYMBOL (obj)->u.s.pinned =3D true; + XSYMBOL (obj)->u.s.pinned =3D true; symbol_block_pinned =3D symbol_block; } /* Don't hash-cons it. */ @@ -6318,10 +6303,7 @@ DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage= _collect, 0, 0, "", if (garbage_collection_inhibited) return Qnil; =20 - ptrdiff_t count =3D SPECPDL_INDEX (); - specbind (Qsymbols_with_pos_enabled, Qnil); garbage_collect (); - unbind_to (count, Qnil); struct gcstat gcst =3D gcstat; =20 Lisp_Object total[] =3D { @@ -6460,7 +6442,7 @@ mark_char_table (struct Lisp_Vector *ptr, enum pvec_t= ype pvectype) Lisp_Object val =3D ptr->contents[i]; =20 if (FIXNUMP (val) || - (BARE_SYMBOL_P (val) && symbol_marked_p (XBARE_SYMBOL (val)))) + (SYMBOLP (val) && symbol_marked_p (XSYMBOL (val)))) continue; if (SUB_CHAR_TABLE_P (val)) { @@ -6864,7 +6846,7 @@ #define CHECK_ALLOCATED_AND_LIVE_SYMBOL() ((void) 0) =20 case Lisp_Symbol: { - struct Lisp_Symbol *ptr =3D XBARE_SYMBOL (obj); + struct Lisp_Symbol *ptr =3D XSYMBOL (obj); nextsym: if (symbol_marked_p (ptr)) break; @@ -6985,7 +6967,7 @@ survives_gc_p (Lisp_Object obj) break; =20 case Lisp_Symbol: - survives_p =3D symbol_marked_p (XBARE_SYMBOL (obj)); + survives_p =3D symbol_marked_p (XSYMBOL (obj)); break; =20 case Lisp_String: @@ -7402,7 +7384,7 @@ DEFUN ("malloc-info", Fmalloc_info, Smalloc_info, 0, = 0, "", static bool symbol_uses_obj (Lisp_Object symbol, Lisp_Object obj) { - struct Lisp_Symbol *sym =3D XBARE_SYMBOL (symbol); + struct Lisp_Symbol *sym =3D XSYMBOL (symbol); Lisp_Object val =3D find_symbol_value (symbol); return (EQ (val, obj) || EQ (sym->u.s.function, obj) diff --git a/src/comp.c b/src/comp.c index 251613dc3d4..40cb0c1c23d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -454,7 +454,6 @@ #define HASH_LENGTH 8 =20 /* C symbols emitted for the load relocation mechanism. */ #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" -#define F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM "f_symbols_with_pos_enabled_r= eloc" #define PURE_RELOC_SYM "pure_reloc" #define DATA_RELOC_SYM "d_reloc" #define DATA_RELOC_IMPURE_SYM "d_reloc_imp" @@ -547,7 +546,6 @@ #define NUM_CAST_TYPES 15 gcc_jit_type *emacs_int_type; gcc_jit_type *emacs_uint_type; gcc_jit_type *void_ptr_type; - gcc_jit_type *bool_ptr_type; gcc_jit_type *char_ptr_type; gcc_jit_type *ptrdiff_type; gcc_jit_type *uintptr_type; @@ -569,16 +567,6 @@ #define NUM_CAST_TYPES 15 gcc_jit_field *lisp_cons_u_s_u_cdr; gcc_jit_type *lisp_cons_type; gcc_jit_type *lisp_cons_ptr_type; - /* struct Lisp_Symbol_With_Position */ - gcc_jit_rvalue *f_symbols_with_pos_enabled_ref; - gcc_jit_struct *lisp_symbol_with_position; - gcc_jit_field *lisp_symbol_with_position_header; - gcc_jit_field *lisp_symbol_with_position_sym; - gcc_jit_field *lisp_symbol_with_position_pos; - gcc_jit_type *lisp_symbol_with_position_type; - gcc_jit_type *lisp_symbol_with_position_ptr_type; - gcc_jit_function *get_symbol_with_position; - gcc_jit_function *symbol_with_pos_sym; /* struct jmp_buf. */ gcc_jit_struct *jmp_buf_s; /* struct handler. */ @@ -671,7 +659,6 @@ #define NUM_CAST_TYPES 15 Lisp_Object helper_unbind_n (Lisp_Object n); void helper_save_restriction (void); bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code); -struct Lisp_Symbol_With_Pos *helper_GET_SYMBOL_WITH_POSITION (Lisp_Object = a); =20 /* Note: helper_link_table must match the list created by `declare_runtime_imported_funcs'. */ @@ -683,7 +670,6 @@ #define NUM_CAST_TYPES 15 record_unwind_protect_excursion, helper_unbind_n, helper_save_restriction, - helper_GET_SYMBOL_WITH_POSITION, record_unwind_current_buffer, set_internal, helper_unwind_protect, @@ -1348,9 +1334,9 @@ emit_XCONS (gcc_jit_rvalue *a) } =20 static gcc_jit_rvalue * -emit_BASE_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y) +emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y) { - emit_comment ("BASE_EQ"); + emit_comment ("EQ"); =20 return gcc_jit_context_new_comparison ( comp.ctxt, @@ -1360,30 +1346,6 @@ emit_BASE_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y) emit_XLI (y)); } =20 -static gcc_jit_rvalue * -emit_AND (gcc_jit_rvalue *x, gcc_jit_rvalue *y) -{ - return gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LOGICAL_AND, - comp.bool_type, - x, - y); -} - -static gcc_jit_rvalue * -emit_OR (gcc_jit_rvalue *x, gcc_jit_rvalue *y) -{ - return gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LOGICAL_OR, - comp.bool_type, - x, - y); -} - static gcc_jit_rvalue * emit_TAGGEDP (gcc_jit_rvalue *obj, Lisp_Word_tag tag) { @@ -1445,85 +1407,6 @@ emit_CONSP (gcc_jit_rvalue *obj) return emit_TAGGEDP (obj, Lisp_Cons); } =20 -static gcc_jit_rvalue * -emit_BARE_SYMBOL_P (gcc_jit_rvalue *obj) -{ - emit_comment ("BARE_SYMBOL_P"); - - return gcc_jit_context_new_cast (comp.ctxt, - NULL, - emit_TAGGEDP (obj, Lisp_Symbol), - comp.bool_type); -} - -static gcc_jit_rvalue * -emit_SYMBOL_WITH_POS_P (gcc_jit_rvalue *obj) -{ - emit_comment ("SYMBOL_WITH_POS_P"); - - gcc_jit_rvalue *args[] =3D - { obj, - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, - PVEC_SYMBOL_WITH_POS) - }; - - return gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.pseudovectorp, - 2, - args); -} - -static gcc_jit_rvalue * -emit_SYMBOL_WITH_POS_SYM (gcc_jit_rvalue *obj) -{ - emit_comment ("SYMBOL_WITH_POS_SYM"); - - gcc_jit_rvalue *arg [] =3D { obj }; - return gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.symbol_with_pos_sym, - 1, - arg); -} - -static gcc_jit_rvalue * -emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y) -{ - return - emit_OR ( - gcc_jit_context_new_comparison ( - comp.ctxt, NULL, - GCC_JIT_COMPARISON_EQ, - emit_XLI (x), emit_XLI (y)), - emit_AND ( - gcc_jit_lvalue_as_rvalue ( - gcc_jit_rvalue_dereference (comp.f_symbols_with_pos_enabled_ref, - NULL)), - emit_OR ( - emit_AND ( - emit_SYMBOL_WITH_POS_P (x), - emit_OR ( - emit_AND ( - emit_SYMBOL_WITH_POS_P (y), - emit_BASE_EQ ( - emit_XLI (emit_SYMBOL_WITH_POS_SYM (x)), - emit_XLI (emit_SYMBOL_WITH_POS_SYM (y)))), - emit_AND ( - emit_BARE_SYMBOL_P (y), - emit_BASE_EQ ( - emit_XLI (emit_SYMBOL_WITH_POS_SYM (x)), - emit_XLI (y))))), - emit_AND ( - emit_BARE_SYMBOL_P (x), - emit_AND ( - emit_SYMBOL_WITH_POS_P (y), - emit_BASE_EQ ( - emit_XLI (x), - emit_XLI (emit_SYMBOL_WITH_POS_SYM (y)))))))); -} - static gcc_jit_rvalue * emit_FLOATP (gcc_jit_rvalue *obj) { @@ -1738,7 +1621,7 @@ emit_lisp_obj_rval (Lisp_Object obj) emit_NILP (gcc_jit_rvalue *x) { emit_comment ("NILP"); - return emit_BASE_EQ (x, emit_lisp_obj_rval (Qnil)); + return emit_EQ (x, emit_lisp_obj_rval (Qnil)); } =20 static gcc_jit_rvalue * @@ -1854,29 +1737,6 @@ emit_CHECK_CONS (gcc_jit_rvalue *x) args)); } =20 -static void -emit_CHECK_SYMBOL_WITH_POS (gcc_jit_rvalue *x) -{ - emit_comment ("CHECK_SYMBOL_WITH_POS"); - - gcc_jit_rvalue *args[] =3D - { gcc_jit_context_new_cast (comp.ctxt, - NULL, - emit_SYMBOL_WITH_POS_P (x), - comp.int_type), - emit_lisp_obj_rval (Qsymbol_with_pos_p), - x }; - - gcc_jit_block_add_eval ( - comp.block, - NULL, - gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.check_type, - 3, - args)); -} - static gcc_jit_rvalue * emit_car_addr (gcc_jit_rvalue *c) { @@ -2241,13 +2101,7 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_block *target1 =3D retrive_block (arg[2]); gcc_jit_block *target2 =3D retrive_block (arg[3]); =20 - if ((!NILP (CALL1I (comp-cstr-imm-vld-p, arg[0])) - && NILP (CALL1I (comp-cstr-imm, arg[0]))) - || (!NILP (CALL1I (comp-cstr-imm-vld-p, arg[1])) - && NILP (CALL1I (comp-cstr-imm, arg[1])))) - emit_cond_jump (emit_BASE_EQ (a, b), target1, target2); - else - emit_cond_jump (emit_EQ (a, b), target1, target2); + emit_cond_jump (emit_EQ (a, b), target1, target2); } else if (EQ (op, Qcond_jump_narg_leq)) { @@ -2904,10 +2758,6 @@ #define ADD_IMPORTED(f_name, ret_type, nargs, args) = \ =20 ADD_IMPORTED (helper_save_restriction, comp.void_type, 0, NULL); =20 - args[0] =3D comp.lisp_obj_type; - ADD_IMPORTED (helper_GET_SYMBOL_WITH_POSITION, comp.lisp_symbol_with_pos= ition_ptr_type, - 1, args); - ADD_IMPORTED (record_unwind_current_buffer, comp.void_type, 0, NULL); =20 args[0] =3D args[1] =3D args[2] =3D comp.lisp_obj_type; @@ -2955,15 +2805,6 @@ emit_ctxt_code (void) gcc_jit_type_get_pointer (comp.thread_state_ptr_type), CURRENT_THREAD_RELOC_SYM)); =20 - comp.f_symbols_with_pos_enabled_ref =3D - gcc_jit_lvalue_as_rvalue ( - gcc_jit_context_new_global ( - comp.ctxt, - NULL, - GCC_JIT_GLOBAL_EXPORTED, - comp.bool_ptr_type, - F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM)); - comp.pure_ptr =3D gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_global ( @@ -3143,39 +2984,6 @@ define_lisp_cons (void) =20 } =20 -static void -define_lisp_symbol_with_position (void) -{ - comp.lisp_symbol_with_position_header =3D - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.ptrdiff_type, - "header"); - comp.lisp_symbol_with_position_sym =3D - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.lisp_obj_type, - "sym"); - comp.lisp_symbol_with_position_pos =3D - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.lisp_obj_type, - "pos"); - gcc_jit_field *fields [3] =3D {comp.lisp_symbol_with_position_header, - comp.lisp_symbol_with_position_sym, - comp.lisp_symbol_with_position_pos}; - comp.lisp_symbol_with_position =3D - gcc_jit_context_new_struct_type (comp.ctxt, - NULL, - "comp_lisp_symbol_with_position", - 3, - fields); - comp.lisp_symbol_with_position_type =3D - gcc_jit_struct_as_type (comp.lisp_symbol_with_position); - comp.lisp_symbol_with_position_ptr_type =3D - gcc_jit_type_get_pointer (comp.lisp_symbol_with_position_type); -} - /* Opaque jmp_buf definition. */ =20 static void @@ -3871,82 +3679,6 @@ define_PSEUDOVECTORP (void) comp.bool_type, 2, args, false)); } =20 -static void -define_GET_SYMBOL_WITH_POSITION (void) -{ - gcc_jit_param *param[] =3D - { gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.lisp_obj_type, - "a") }; - - comp.get_symbol_with_position =3D - gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_INTERNAL, - comp.lisp_symbol_with_position_ptr_type, - "GET_SYMBOL_WITH_POSITION", - 1, - param, - 0); - - DECL_BLOCK (entry_block, comp.get_symbol_with_position); - - comp.block =3D entry_block; - comp.func =3D comp.get_symbol_with_position; - - gcc_jit_rvalue *args[] =3D - { gcc_jit_param_as_rvalue (param[0]) }; - /* FIXME use XUNTAG now that's available. */ - gcc_jit_block_end_with_return ( - entry_block, - NULL, - emit_call (intern_c_string ("helper_GET_SYMBOL_WITH_POSITION"), - comp.lisp_symbol_with_position_ptr_type, - 1, args, false)); -} - -static void define_SYMBOL_WITH_POS_SYM (void) -{ - gcc_jit_rvalue *tmpr, *swp; - gcc_jit_lvalue *tmpl; - - gcc_jit_param *param [] =3D - { gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.lisp_obj_type, - "a") }; - comp.symbol_with_pos_sym =3D - gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_INTERNAL, - comp.lisp_obj_type, - "SYMBOL_WITH_POS_SYM", - 1, - param, - 0); - - DECL_BLOCK (entry_block, comp.symbol_with_pos_sym); - comp.func =3D comp.symbol_with_pos_sym; - comp.block =3D entry_block; - - emit_CHECK_SYMBOL_WITH_POS (gcc_jit_param_as_rvalue (param [0])); - - gcc_jit_rvalue *args[] =3D { gcc_jit_param_as_rvalue (param [0]) }; - - swp =3D gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.get_symbol_with_position, - 1, - args); - tmpl =3D gcc_jit_rvalue_dereference (swp, NULL); - tmpr =3D gcc_jit_lvalue_as_rvalue (tmpl); - gcc_jit_block_end_with_return (entry_block, - NULL, - gcc_jit_rvalue_access_field ( - tmpr, - NULL, - comp.lisp_symbol_with_position_sym)); -} - static void define_CHECK_IMPURE (void) { @@ -4584,7 +4316,6 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__in= it_ctxt, gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG_LONG); comp.unsigned_long_long_type =3D gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_UNSIGNED_LONG_LONG); - comp.bool_ptr_type =3D gcc_jit_type_get_pointer (comp.bool_type); comp.char_ptr_type =3D gcc_jit_type_get_pointer (comp.char_type); comp.emacs_int_type =3D gcc_jit_context_get_int_type (comp.ctxt, sizeof (EMACS_INT), @@ -4657,7 +4388,6 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__in= it_ctxt, /* Define data structures. */ =20 define_lisp_cons (); - define_lisp_symbol_with_position (); define_jmp_buf (); define_handler_struct (); define_thread_state_struct (); @@ -4879,9 +4609,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_c= txt_to_file, /* Define inline functions. */ define_CAR_CDR (); define_PSEUDOVECTORP (); - define_GET_SYMBOL_WITH_POSITION (); define_CHECK_TYPE (); - define_SYMBOL_WITH_POS_SYM (); define_CHECK_IMPURE (); define_bool_to_lisp_obj (); define_setcar_setcdr (); @@ -5013,14 +4741,6 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enu= m pvec_type code) code); } =20 -struct Lisp_Symbol_With_Pos * -helper_GET_SYMBOL_WITH_POSITION (Lisp_Object a) -{ - if (!SYMBOL_WITH_POS_P (a)) - wrong_type_argument (Qwrong_type_argument, a); - return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Symbol_With_Pos); -} - /* `native-comp-eln-load-path' clean-up support code. */ =20 @@ -5288,15 +5008,12 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_= u, bool loading_dump, { struct thread_state ***current_thread_reloc =3D dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); - bool **f_symbols_with_pos_enabled_reloc =3D - dynlib_sym (handle, F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM); void **pure_reloc =3D dynlib_sym (handle, PURE_RELOC_SYM); Lisp_Object *data_relocs =3D dynlib_sym (handle, DATA_RELOC_SYM); Lisp_Object *data_imp_relocs =3D comp_u->data_imp_relocs; void **freloc_link_table =3D dynlib_sym (handle, FUNC_LINK_TABLE_SYM= ); =20 if (!(current_thread_reloc - && f_symbols_with_pos_enabled_reloc && pure_reloc && data_relocs && data_imp_relocs @@ -5308,7 +5025,6 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u,= bool loading_dump, xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); =20 *current_thread_reloc =3D ¤t_thread; - *f_symbols_with_pos_enabled_reloc =3D &symbols_with_pos_enabled; *pure_reloc =3D pure; =20 /* Imported functions. */ @@ -5666,7 +5382,6 @@ syms_of_comp (void) DEFSYM (Qnumberp, "numberp"); DEFSYM (Qintegerp, "integerp"); DEFSYM (Qcomp_maybe_gc_or_quit, "comp-maybe-gc-or-quit"); - DEFSYM (Qsymbol_with_pos_p, "symbol-with-pos-p"); =20 /* Allocation classes. */ DEFSYM (Qd_default, "d-default"); diff --git a/src/data.c b/src/data.c index 95d29ac9e98..b637efa6bde 100644 --- a/src/data.c +++ b/src/data.c @@ -216,7 +216,6 @@ DEFUN ("type-of", Ftype_of, Stype_of, 1, 1, 0, case PVEC_NORMAL_VECTOR: return Qvector; case PVEC_BIGNUM: return Qinteger; case PVEC_MARKER: return Qmarker; - case PVEC_SYMBOL_WITH_POS: return Qsymbol_with_pos; case PVEC_OVERLAY: return Qoverlay; case PVEC_FINALIZER: return Qfinalizer; case PVEC_USER_PTR: return Quser_ptr; @@ -319,26 +318,6 @@ DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0, return Qt; } -DEFUN ("bare-symbol-p", Fbare_symbol_p, Sbare_symbol_p, 1, 1, 0, - doc: /* Return t if OBJECT is a symbol, but not a symbol together w= ith position. */ - attributes: const) - (Lisp_Object object) -{ - if (BARE_SYMBOL_P (object)) - return Qt; - return Qnil; -} - -DEFUN ("symbol-with-pos-p", Fsymbol_with_pos_p, Ssymbol_with_pos_p, 1, 1, = 0, - doc: /* Return t if OBJECT is a symbol together with position. */ - attributes: const) - (Lisp_Object object) -{ - if (SYMBOL_WITH_POS_P (object)) - return Qt; - return Qnil; -} - DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0, doc: /* Return t if OBJECT is a symbol. */ attributes: const) @@ -776,62 +755,6 @@ DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1= , 0, return name; } =20 -DEFUN ("bare-symbol", Fbare_symbol, Sbare_symbol, 1, 1, 0, - doc: /* Extract, if need be, the bare symbol from SYM, a symbol. *= /) - (register Lisp_Object sym) -{ - if (BARE_SYMBOL_P (sym)) - return sym; - /* Type checking is done in the following macro. */ - return SYMBOL_WITH_POS_SYM (sym); -} - -DEFUN ("symbol-with-pos-pos", Fsymbol_with_pos_pos, Ssymbol_with_pos_pos, = 1, 1, 0, - doc: /* Extract the position from a symbol with position. */) - (register Lisp_Object ls) -{ - /* Type checking is done in the following macro. */ - return SYMBOL_WITH_POS_POS (ls); -} - -DEFUN ("remove-pos-from-symbol", Fremove_pos_from_symbol, - Sremove_pos_from_symbol, 1, 1, 0, - doc: /* If ARG is a symbol with position, return it without the pos= ition. -Otherwise, return ARG unchanged. Compare with `bare-symbol'. */) - (register Lisp_Object arg) -{ - if (SYMBOL_WITH_POS_P (arg)) - return (SYMBOL_WITH_POS_SYM (arg)); - return arg; -} - -DEFUN ("position-symbol", Fposition_symbol, Sposition_symbol, 2, 2, 0, - doc: /* Create a new symbol with position. -SYM is a symbol, with or without position, the symbol to position. -POS, the position, is either a fixnum or a symbol with position from which -the position will be taken. */) - (register Lisp_Object sym, register Lisp_Object pos) -{ - Lisp_Object bare; - Lisp_Object position; - - if (BARE_SYMBOL_P (sym)) - bare =3D sym; - else if (SYMBOL_WITH_POS_P (sym)) - bare =3D XSYMBOL_WITH_POS (sym)->sym; - else - wrong_type_argument (Qsymbolp, sym); - - if (FIXNUMP (pos)) - position =3D pos; - else if (SYMBOL_WITH_POS_P (pos)) - position =3D XSYMBOL_WITH_POS (pos)->pos; - else - wrong_type_argument (Qfixnum_or_symbol_with_pos_p, pos); - - return build_symbol_with_pos (bare, position); -} - DEFUN ("fset", Ffset, Sfset, 2, 2, 0, doc: /* Set SYMBOL's function definition to DEFINITION, and return = DEFINITION. */) (register Lisp_Object symbol, Lisp_Object definition) @@ -4046,6 +3969,9 @@ syms_of_data (void) DEFSYM (Qtext_read_only, "text-read-only"); DEFSYM (Qmark_inactive, "mark-inactive"); DEFSYM (Qinhibited_interaction, "inhibited-interaction"); + DEFSYM (Qrecursion_error, "recursion-error"); + DEFSYM (Qexcessive_variable_binding, "excessive-variable-binding"); + DEFSYM (Qexcessive_lisp_nesting, "excessive-lisp-nesting"); =20 DEFSYM (Qrecursion_error, "recursion-error"); DEFSYM (Qexcessive_variable_binding, "excessive-variable-binding"); @@ -4053,8 +3979,6 @@ syms_of_data (void) =20 DEFSYM (Qlistp, "listp"); DEFSYM (Qconsp, "consp"); - DEFSYM (Qbare_symbol_p, "bare-symbol-p"); - DEFSYM (Qsymbol_with_pos_p, "symbol-with-pos-p"); DEFSYM (Qsymbolp, "symbolp"); DEFSYM (Qfixnump, "fixnump"); DEFSYM (Qintegerp, "integerp"); @@ -4080,7 +4004,6 @@ syms_of_data (void) =20 DEFSYM (Qchar_table_p, "char-table-p"); DEFSYM (Qvector_or_char_table_p, "vector-or-char-table-p"); - DEFSYM (Qfixnum_or_symbol_with_pos_p, "fixnum-or-symbol-with-pos-p"); =20 DEFSYM (Qsubrp, "subrp"); DEFSYM (Qunevalled, "unevalled"); @@ -4158,6 +4081,15 @@ #define PUT_ERROR(sym, tail, msg) \ "Arithmetic overflow error"); PUT_ERROR (Qunderflow_error, Fcons (Qrange_error, arith_tail), "Arithmetic underflow error"); + recursion_tail =3D pure_cons (Qrecursion_error, error_tail); + Fput (Qrecursion_error, Qerror_conditions, recursion_tail); + Fput (Qrecursion_error, Qerror_message, build_pure_c_string + ("Excessive recursive calling error")); + + PUT_ERROR (Qexcessive_variable_binding, recursion_tail, + "Variable binding depth exceeds max-specpdl-size"); + PUT_ERROR (Qexcessive_lisp_nesting, recursion_tail, + "Lisp nesting exceeds `max-lisp-eval-depth'"); =20 recursion_tail =3D pure_cons (Qrecursion_error, error_tail); Fput (Qrecursion_error, Qerror_conditions, recursion_tail); @@ -4175,7 +4107,6 @@ #define PUT_ERROR(sym, tail, msg) \ DEFSYM (Qstring, "string"); DEFSYM (Qcons, "cons"); DEFSYM (Qmarker, "marker"); - DEFSYM (Qsymbol_with_pos, "symbol-with-pos"); DEFSYM (Qoverlay, "overlay"); DEFSYM (Qfinalizer, "finalizer"); DEFSYM (Qmodule_function, "module-function"); @@ -4228,8 +4159,6 @@ #define PUT_ERROR(sym, tail, msg) \ defsubr (&Snumber_or_marker_p); defsubr (&Sfloatp); defsubr (&Snatnump); - defsubr (&Sbare_symbol_p); - defsubr (&Ssymbol_with_pos_p); defsubr (&Ssymbolp); defsubr (&Skeywordp); defsubr (&Sstringp); @@ -4260,10 +4189,6 @@ #define PUT_ERROR(sym, tail, msg) \ defsubr (&Sindirect_function); defsubr (&Ssymbol_plist); defsubr (&Ssymbol_name); - defsubr (&Sbare_symbol); - defsubr (&Ssymbol_with_pos_pos); - defsubr (&Sremove_pos_from_symbol); - defsubr (&Sposition_symbol); defsubr (&Smakunbound); defsubr (&Sfmakunbound); defsubr (&Sboundp); @@ -4346,12 +4271,6 @@ #define PUT_ERROR(sym, tail, msg) \ Vmost_negative_fixnum =3D make_fixnum (MOST_NEGATIVE_FIXNUM); make_symbol_constant (intern_c_string ("most-negative-fixnum")); =20 - DEFSYM (Qsymbols_with_pos_enabled, "symbols-with-pos-enabled"); - DEFVAR_BOOL ("symbols-with-pos-enabled", symbols_with_pos_enabled, - doc: /* Non-nil when "symbols with position" can be used as= symbols. -Bind this to non-nil in applications such as the byte compiler. */); - symbols_with_pos_enabled =3D false; - DEFSYM (Qwatchers, "watchers"); DEFSYM (Qmakunbound, "makunbound"); DEFSYM (Qunlet, "unlet"); diff --git a/src/fns.c b/src/fns.c index c67871da744..fb05bdc5be3 100644 --- a/src/fns.c +++ b/src/fns.c @@ -291,6 +291,21 @@ DEFUN ("proper-list-p", Fproper_list_p, Sproper_list_p= , 1, 1, 0, return make_fixnum (len); } =20 +DEFUN ("circular-list-p", Fcircular_list_p, Scircular_list_p, 1, 1, 0, + doc: /* Return t if OBJECT is a circular list, nil otherwise. +The expression (not (proper-list-p OBJECT)) also returns t if OBJECT +is circular, but undesirably returns t if OBJECT is a dotted list. */ + attributes: const) + (Lisp_Object object) +{ + Lisp_Object tail =3D object, circular_p =3D Qnil; + FOR_EACH_TAIL_INTERNAL (tail, (void) ((circular_p) =3D Qt), false) + { + (void) 0; + } + return circular_p; +} + DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0, doc: /* Return the number of bytes in STRING. If STRING is multibyte, this may be greater than the length of STRING. */) @@ -2631,13 +2646,6 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum= equal_kind equal_kind, } } =20 - /* A symbol with position compares the contained symbol, and is - `equal' to the corresponding ordinary symbol. */ - if (SYMBOL_WITH_POS_P (o1)) - o1 =3D SYMBOL_WITH_POS_SYM (o1); - if (SYMBOL_WITH_POS_P (o2)) - o2 =3D SYMBOL_WITH_POS_SYM (o2); - if (EQ (o1, o2)) return true; if (XTYPE (o1) !=3D XTYPE (o2)) @@ -4542,10 +4550,7 @@ hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object = key, Lisp_Object *hash) { ptrdiff_t start_of_bucket, i; =20 - Lisp_Object hash_code; - if (SYMBOL_WITH_POS_P (key)) - key =3D SYMBOL_WITH_POS_SYM (key); - hash_code =3D h->test.hashfn (key, h); + Lisp_Object hash_code =3D h->test.hashfn (key, h); if (hash) *hash =3D hash_code; =20 @@ -6122,6 +6127,7 @@ syms_of_fns (void) defsubr (&Slength_greater); defsubr (&Slength_equal); defsubr (&Sproper_list_p); + defsubr (&Scircular_list_p); defsubr (&Sstring_bytes); defsubr (&Sstring_distance); defsubr (&Sstring_equal); diff --git a/src/keyboard.c b/src/keyboard.c index 441c23e10c7..70e055a9df9 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -689,8 +689,6 @@ recursive_edit_1 (void) { specbind (Qstandard_output, Qt); specbind (Qstandard_input, Qt); - specbind (Qsymbols_with_pos_enabled, Qnil); - specbind (Qprint_symbols_bare, Qnil); } =20 #ifdef HAVE_WINDOW_SYSTEM diff --git a/src/lisp.h b/src/lisp.h index 10f45057d50..ec615aa8d1e 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -353,41 +353,18 @@ #define LISP_WORDS_ARE_POINTERS (EMACS_INT_MAX =3D=3D= INTPTR_MAX) # endif #endif =20 -#define lisp_h_PSEUDOVECTORP(a,code) \ - (lisp_h_VECTORLIKEP((a)) && \ - ((XUNTAG ((a), Lisp_Vectorlike, union vectorlike_header)->size \ - & (PSEUDOVECTOR_FLAG | PVEC_TYPE_MASK)) \ - =3D=3D (PSEUDOVECTOR_FLAG | ((code) << PSEUDOVECTOR_AREA_BITS)))) - #define lisp_h_CHECK_FIXNUM(x) CHECK_TYPE (FIXNUMP (x), Qfixnump, x) #define lisp_h_CHECK_SYMBOL(x) CHECK_TYPE (SYMBOLP (x), Qsymbolp, x) #define lisp_h_CHECK_TYPE(ok, predicate, x) \ ((ok) ? (void) 0 : wrong_type_argument (predicate, x)) #define lisp_h_CONSP(x) TAGGEDP (x, Lisp_Cons) -#define lisp_h_BASE_EQ(x, y) (XLI (x) =3D=3D XLI (y)) - -/* FIXME: Do we really need to inline the whole thing? - * What about keeping the part after `symbols_with_pos_enabled` in - * a separate function? */ -#define lisp_h_EQ(x, y) \ - ((XLI ((x)) =3D=3D XLI ((y))) \ - || (symbols_with_pos_enabled \ - && (SYMBOL_WITH_POS_P ((x)) \ - ? (BARE_SYMBOL_P ((y)) \ - ? XLI (XSYMBOL_WITH_POS((x))->sym) =3D=3D XLI (y) \ - : SYMBOL_WITH_POS_P((y)) \ - && (XLI (XSYMBOL_WITH_POS((x))->sym) \ - =3D=3D XLI (XSYMBOL_WITH_POS((y))->sym))) \ - : (SYMBOL_WITH_POS_P ((y)) \ - && BARE_SYMBOL_P ((x)) \ - && (XLI (x) =3D=3D XLI ((XSYMBOL_WITH_POS ((y)))->sym)))))) - +#define lisp_h_EQ(x, y) (XLI (x) =3D=3D XLI (y)) #define lisp_h_FIXNUMP(x) \ (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) \ - (unsigned) (Lisp_Int0 >> !USE_LSB_TAG)) \ & ((1 << INTTYPEBITS) - 1))) #define lisp_h_FLOATP(x) TAGGEDP (x, Lisp_Float) -#define lisp_h_NILP(x) BASE_EQ (x, Qnil) +#define lisp_h_NILP(x) EQ (x, Qnil) #define lisp_h_SET_SYMBOL_VAL(sym, v) \ (eassert ((sym)->u.s.redirect =3D=3D SYMBOL_PLAINVAL), \ (sym)->u.s.val.value =3D (v)) @@ -396,10 +373,7 @@ #define lisp_h_SYMBOL_CONSTANT_P(sym) \ #define lisp_h_SYMBOL_TRAPPED_WRITE_P(sym) (XSYMBOL (sym)->u.s.trapped_wri= te) #define lisp_h_SYMBOL_VAL(sym) \ (eassert ((sym)->u.s.redirect =3D=3D SYMBOL_PLAINVAL), (sym)->u.s.val.v= alue) -#define lisp_h_SYMBOL_WITH_POS_P(x) PSEUDOVECTORP ((x), PVEC_SYMBOL_WITH_P= OS) -#define lisp_h_BARE_SYMBOL_P(x) TAGGEDP ((x), Lisp_Symbol) -#define lisp_h_SYMBOLP(x) ((BARE_SYMBOL_P ((x)) || \ - (symbols_with_pos_enabled && (SYMBOL_WITH_POS_= P ((x)))))) +#define lisp_h_SYMBOLP(x) TAGGEDP (x, Lisp_Symbol) #define lisp_h_TAGGEDP(a, tag) \ (! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \ - (unsigned) (tag)) \ @@ -444,12 +418,11 @@ #define lisp_h_XHASH(a) XUFIXNUM_RAW (a) # define XLI(o) lisp_h_XLI (o) # define XIL(i) lisp_h_XIL (i) # define XLP(o) lisp_h_XLP (o) -# define BARE_SYMBOL_P(x) lisp_h_BARE_SYMBOL_P (x) # define CHECK_FIXNUM(x) lisp_h_CHECK_FIXNUM (x) # define CHECK_SYMBOL(x) lisp_h_CHECK_SYMBOL (x) # define CHECK_TYPE(ok, predicate, x) lisp_h_CHECK_TYPE (ok, predicate, x) # define CONSP(x) lisp_h_CONSP (x) -# define BASE_EQ(x, y) lisp_h_BASE_EQ (x, y) +# define EQ(x, y) lisp_h_EQ (x, y) # define FLOATP(x) lisp_h_FLOATP (x) # define FIXNUMP(x) lisp_h_FIXNUMP (x) # define NILP(x) lisp_h_NILP (x) @@ -457,7 +430,7 @@ #define lisp_h_XHASH(a) XUFIXNUM_RAW (a) # define SYMBOL_CONSTANT_P(sym) lisp_h_SYMBOL_CONSTANT_P (sym) # define SYMBOL_TRAPPED_WRITE_P(sym) lisp_h_SYMBOL_TRAPPED_WRITE_P (sym) # define SYMBOL_VAL(sym) lisp_h_SYMBOL_VAL (sym) -/* # define SYMBOLP(x) lisp_h_SYMBOLP (x) */ /* X is accessed more than on= ce. */ +# define SYMBOLP(x) lisp_h_SYMBOLP (x) # define TAGGEDP(a, tag) lisp_h_TAGGEDP (a, tag) # define VECTORLIKEP(x) lisp_h_VECTORLIKEP (x) # define XCAR(c) lisp_h_XCAR (c) @@ -616,7 +589,6 @@ #define ENUM_BF(TYPE) enum TYPE extern void char_table_set (Lisp_Object, int, Lisp_Object); =20 /* Defined in data.c. */ -extern bool symbols_with_pos_enabled; extern AVOID args_out_of_range_3 (Lisp_Object, Lisp_Object, Lisp_Object); extern AVOID wrong_type_argument (Lisp_Object, Lisp_Object); extern Lisp_Object default_value (Lisp_Object symbol); @@ -1002,12 +974,57 @@ #define ROUNDUP(x, y) (POWER_OF_2 (y) \ ptrdiff_t size; }; =20 -struct Lisp_Symbol_With_Pos +INLINE bool +(SYMBOLP) (Lisp_Object x) { - union vectorlike_header header; - Lisp_Object sym; /* A symbol */ - Lisp_Object pos; /* A fixnum */ -} GCALIGNED_STRUCT; + return lisp_h_SYMBOLP (x); +} + +INLINE struct Lisp_Symbol * ATTRIBUTE_NO_SANITIZE_UNDEFINED +XSYMBOL (Lisp_Object a) +{ + eassert (SYMBOLP (a)); + intptr_t i =3D (intptr_t) XUNTAG (a, Lisp_Symbol, struct Lisp_Symbol); + void *p =3D (char *) lispsym + i; + return p; +} + +INLINE Lisp_Object +make_lisp_symbol (struct Lisp_Symbol *sym) +{ + /* GCC 7 x86-64 generates faster code if lispsym is + cast to char * rather than to intptr_t. */ + char *symoffset =3D (char *) ((char *) sym - (char *) lispsym); + Lisp_Object a =3D TAG_PTR (Lisp_Symbol, symoffset); + eassert (XSYMBOL (a) =3D=3D sym); + return a; +} + +INLINE Lisp_Object +builtin_lisp_symbol (int index) +{ + return make_lisp_symbol (&lispsym[index]); +} + +INLINE bool +c_symbol_p (struct Lisp_Symbol *sym) +{ + char *bp =3D (char *) lispsym; + char *sp =3D (char *) sym; + if (PTRDIFF_MAX < INTPTR_MAX) + return bp <=3D sp && sp < bp + sizeof lispsym; + else + { + ptrdiff_t offset =3D sp - bp; + return 0 <=3D offset && offset < sizeof lispsym; + } +} + +INLINE void +(CHECK_SYMBOL) (Lisp_Object x) +{ + lisp_h_CHECK_SYMBOL (x); +} =20 /* In the size word of a vector, this bit means the vector has been marked= . */ =20 @@ -1032,7 +1049,6 @@ DEFINE_GDB_SYMBOL_END (PSEUDOVECTOR_FLAG) PVEC_MARKER, PVEC_OVERLAY, PVEC_FINALIZER, - PVEC_SYMBOL_WITH_POS, PVEC_MISC_PTR, PVEC_USER_PTR, PVEC_PROCESS, @@ -1092,92 +1108,6 @@ DEFINE_GDB_SYMBOL_END (PSEUDOVECTOR_FLAG) values. They are macros for use in #if and static initializers. */ #define MOST_POSITIVE_FIXNUM (EMACS_INT_MAX >> INTTYPEBITS) #define MOST_NEGATIVE_FIXNUM (-1 - MOST_POSITIVE_FIXNUM) - -INLINE bool -PSEUDOVECTORP (Lisp_Object a, int code) -{ - return lisp_h_PSEUDOVECTORP (a, code); -} - -INLINE bool -(BARE_SYMBOL_P) (Lisp_Object x) -{ - return lisp_h_BARE_SYMBOL_P (x); -} - -INLINE bool -(SYMBOL_WITH_POS_P) (Lisp_Object x) -{ - return lisp_h_SYMBOL_WITH_POS_P (x); -} - -INLINE bool -(SYMBOLP) (Lisp_Object x) -{ - return lisp_h_SYMBOLP (x); -} - -INLINE struct Lisp_Symbol_With_Pos * -XSYMBOL_WITH_POS (Lisp_Object a) -{ - eassert (SYMBOL_WITH_POS_P (a)); - return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Symbol_With_Pos); -} - -INLINE struct Lisp_Symbol * ATTRIBUTE_NO_SANITIZE_UNDEFINED -(XBARE_SYMBOL) (Lisp_Object a) -{ - eassert (BARE_SYMBOL_P (a)); - intptr_t i =3D (intptr_t) XUNTAG (a, Lisp_Symbol, struct Lisp_Symbol); - void *p =3D (char *) lispsym + i; - return p; -} - -INLINE struct Lisp_Symbol * ATTRIBUTE_NO_SANITIZE_UNDEFINED -(XSYMBOL) (Lisp_Object a) -{ - eassert (SYMBOLP ((a))); - if (!symbols_with_pos_enabled || BARE_SYMBOL_P (a)) - return XBARE_SYMBOL (a); - return XBARE_SYMBOL (XSYMBOL_WITH_POS (a)->sym); -} - -INLINE Lisp_Object -make_lisp_symbol (struct Lisp_Symbol *sym) -{ - /* GCC 7 x86-64 generates faster code if lispsym is - cast to char * rather than to intptr_t. */ - char *symoffset =3D (char *) ((char *) sym - (char *) lispsym); - Lisp_Object a =3D TAG_PTR (Lisp_Symbol, symoffset); - eassert (XSYMBOL (a) =3D=3D sym); - return a; -} - -INLINE Lisp_Object -builtin_lisp_symbol (int index) -{ - return make_lisp_symbol (&lispsym[index]); -} - -INLINE bool -c_symbol_p (struct Lisp_Symbol *sym) -{ - char *bp =3D (char *) lispsym; - char *sp =3D (char *) sym; - if (PTRDIFF_MAX < INTPTR_MAX) - return bp <=3D sp && sp < bp + sizeof lispsym; - else - { - ptrdiff_t offset =3D sp - bp; - return 0 <=3D offset && offset < sizeof lispsym; - } -} - -INLINE void -(CHECK_SYMBOL) (Lisp_Object x) -{ - lisp_h_CHECK_SYMBOL (x); -} =20 /* True if the possibly-unsigned integer I doesn't fit in a fixnum. */ =20 @@ -1309,14 +1239,7 @@ make_fixed_natnum (EMACS_INT n) } =20 /* Return true if X and Y are the same object. */ -INLINE bool -(BASE_EQ) (Lisp_Object x, Lisp_Object y) -{ - return lisp_h_BASE_EQ (x, y); -} =20 -/* Return true if X and Y are the same object, reckoning a symbol with - position as being the same as the bare symbol. */ INLINE bool (EQ) (Lisp_Object x, Lisp_Object y) { @@ -1791,6 +1714,20 @@ PSEUDOVECTOR_TYPEP (const union vectorlike_header *a= , enum pvec_type code) =3D=3D (PSEUDOVECTOR_FLAG | (code << PSEUDOVECTOR_AREA_BITS))); } =20 +INLINE bool +PSEUDOVECTORP (Lisp_Object a, int code) +{ + if (! VECTORLIKEP (a)) + return false; + else + { + /* Converting to union vectorlike_header * avoids aliasing issues. = */ + return PSEUDOVECTOR_TYPEP (XUNTAG (a, Lisp_Vectorlike, + union vectorlike_header), + code); + } +} + /* A boolvector is a kind of vectorlike, with contents like a string. */ =20 struct Lisp_Bool_Vector @@ -2702,22 +2639,6 @@ XOVERLAY (Lisp_Object a) return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Overlay); } =20 -INLINE Lisp_Object -SYMBOL_WITH_POS_SYM (Lisp_Object a) -{ - if (!SYMBOL_WITH_POS_P (a)) - wrong_type_argument (Qsymbol_with_pos_p, a); - return XSYMBOL_WITH_POS (a)->sym; -} - -INLINE Lisp_Object -SYMBOL_WITH_POS_POS (Lisp_Object a) -{ - if (!SYMBOL_WITH_POS_P (a)) - wrong_type_argument (Qsymbol_with_pos_p, a); - return XSYMBOL_WITH_POS (a)->pos; -} - INLINE bool USER_PTRP (Lisp_Object x) { @@ -4179,7 +4100,6 @@ #define ALLOCATE_ZEROED_PSEUDOVECTOR(type, field, tag= ) \ extern Lisp_Object make_float (double); extern void display_malloc_warning (void); extern ptrdiff_t inhibit_garbage_collection (void); -extern Lisp_Object build_symbol_with_pos (Lisp_Object, Lisp_Object); extern Lisp_Object build_overlay (Lisp_Object, Lisp_Object, Lisp_Object); extern void free_cons (struct Lisp_Cons *); extern void init_alloc_once (void); diff --git a/src/lread.c b/src/lread.c index 713c03243cb..4d7560f80c1 100644 --- a/src/lread.c +++ b/src/lread.c @@ -128,8 +128,7 @@ #define file_tell ftell static ptrdiff_t read_from_string_index_byte; static ptrdiff_t read_from_string_limit; =20 -/* Position in object from which characters are being read by `readchar'. = */ -static EMACS_INT readchar_offset; +static EMACS_INT readchar_charpos; /* one-indexed */ =20 /* This contains the last string skipped with #@. */ static char *saved_doc_string; @@ -170,7 +169,7 @@ #define file_tell ftell char **, ptrdiff_t *, ptrdiff_t *); =20 - + /* Functions that read one byte from the current source READCHARFUN or unreads one byte. If the integer argument C is -1, it returns one read byte, or -1 when there's no more byte in the source. If C @@ -192,6 +191,8 @@ #define UNREAD(c) unreadchar (readcharfun, c) =20 /* Same as READCHAR but set *MULTIBYTE to the multibyteness of the source.= */ #define READCHAR_REPORT_MULTIBYTE(multibyte) readchar (readcharfun, multib= yte) +#define ANNOTATE(atom) \ + (annotated ? Fcons (make_fixnum (initial_charpos), atom) : atom) =20 /* When READCHARFUN is Qget_file_char, Qget_emacs_mule_file_char, Qlambda, or a cons, we use this to keep an unread character because @@ -212,7 +213,7 @@ readchar (Lisp_Object readcharfun, bool *multibyte) if (multibyte) *multibyte =3D 0; =20 - readchar_offset++; + readchar_charpos++; =20 if (BUFFERP (readcharfun)) { @@ -423,7 +424,7 @@ skip_dyn_eof (Lisp_Object readcharfun) static void unreadchar (Lisp_Object readcharfun, int c) { - readchar_offset--; + readchar_charpos--; if (c =3D=3D -1) /* Don't back up the pointer if we're unreading the end-of-input mark, since readchar didn't advance it when we read it. */ @@ -482,7 +483,6 @@ readbyte_for_lambda (int c, Lisp_Object readcharfun) return read_bytecode_char (c >=3D 0); } =20 - static int readbyte_from_stdio (void) { @@ -648,15 +648,15 @@ read_emacs_mule_char (int c, int (*readbyte) (int, Li= sp_Object), Lisp_Object rea static Lisp_Object read_internal_start (Lisp_Object, Lisp_Object, Lisp_Object, bool); static Lisp_Object read0 (Lisp_Object, bool); -static Lisp_Object read1 (Lisp_Object, int *, bool, bool); +static Lisp_Object read1 (Lisp_Object, int *, bool); =20 static Lisp_Object read_list (bool, Lisp_Object, bool); -static Lisp_Object read_vector (Lisp_Object, bool, bool); +static Lisp_Object read_vector (Lisp_Object, bool); =20 static Lisp_Object substitute_object_recurse (struct subst *, Lisp_Object); static void substitute_in_interval (INTERVAL, void *); =20 - + /* Get a character from the tty. */ =20 /* Read input events until we get one that's acceptable for our purposes. @@ -705,8 +705,10 @@ read_filtered_event (bool no_switch_frame, bool ascii_= required, /* Read until we get an acceptable event. */ retry: do - val =3D read_char (0, Qnil, (input_method ? Qnil : Qt), 0, - NUMBERP (seconds) ? &end_time : NULL); + { + val =3D read_char (0, Qnil, (input_method ? Qnil : Qt), 0, + NUMBERP (seconds) ? &end_time : NULL); + } while (FIXNUMP (val) && XFIXNUM (val) =3D=3D -2); /* wrong_kboard_jmpbuf= */ =20 if (BUFFERP (val)) @@ -732,12 +734,12 @@ read_filtered_event (bool no_switch_frame, bool ascii= _required, { Lisp_Object tem, tem1; tem =3D Fget (val, Qevent_symbol_element_mask); - if (!NILP (tem)) + if (! NILP (tem)) { tem1 =3D Fget (Fcar (tem), Qascii_character); /* Merge this symbol's modifier bits with the ASCII equivalent of its basic code. */ - if (!NILP (tem1)) + if (! NILP (tem1)) XSETFASTINT (val, XFIXNUM (tem1) | XFIXNUM (Fcar (Fcdr (tem)))); } } @@ -907,7 +909,7 @@ DEFUN ("get-file-char", Fget_file_char, Sget_file_char,= 0, 0, 0, } =20 =20 - + =20 /* Return true if the lisp code read using READCHARFUN defines a non-nil `lexical-binding' file variable. After returning, the stream is @@ -1038,7 +1040,7 @@ #define UPDATE_BEG_END_STATE(ch) \ return rv; } } - + /* Value is a version number of byte compiled code if the file associated with file descriptor FD is a compiled Lisp file that's safe to load. Only files compiled with Emacs can be loaded. */ @@ -1100,14 +1102,9 @@ load_error_handler (Lisp_Object data) static void load_warn_unescaped_character_literals (Lisp_Object file) { - Lisp_Object function - =3D Fsymbol_function (Qbyte_run_unescaped_character_literals_warning); - /* If byte-run.el is being loaded, - `byte-run--unescaped-character-literals-warning' isn't yet - defined. Since it'll be byte-compiled later, ignore potential - unescaped character literals. */ - Lisp_Object warning =3D NILP (function) ? Qnil : call0 (function); - if (!NILP (warning)) + Lisp_Object warning =3D + safe_call (1, intern ("byte-run--unescaped-character-literals-warning"= )); + if (! NILP (warning)) { AUTO_STRING (format, "Loading `%s': %s"); CALLN (Fmessage, format, file, warning); @@ -1235,7 +1232,7 @@ DEFUN ("load", Fload, Sload, 1, 5, 0, /* If file name is magic, call the handler. */ /* This shouldn't be necessary any more now that `openp' handles it righ= t. handler =3D Ffind_file_name_handler (file, Qload); - if (!NILP (handler)) + if (! NILP (handler)) return call5 (handler, Qload, file, noerror, nomessage, nosuffix); */ =20 /* The presence of this call is the result of a historical accident: @@ -1289,7 +1286,7 @@ DEFUN ("load", Fload, Sload, 1, 5, 0, must_suffix =3D Qnil; } =20 - if (!NILP (nosuffix)) + if (! NILP (nosuffix)) suffixes =3D Qnil; else { @@ -1381,7 +1378,7 @@ DEFUN ("load", Fload, Sload, 1, 5, 0, int load_count =3D 0; Lisp_Object tem =3D Vloads_in_progress; FOR_EACH_TAIL_SAFE (tem) - if (!NILP (Fequal (found, XCAR (tem))) && (++load_count > 3)) + if (! NILP (Fequal (found, XCAR (tem))) && (++load_count > 3)) signal_error ("Recursive load", Fcons (found, Vloads_in_progress)); record_unwind_protect (record_load_unwind, Vloads_in_progress); Vloads_in_progress =3D Fcons (found, Vloads_in_progress); @@ -1451,7 +1448,7 @@ DEFUN ("load", Fload, Sload, 1, 5, 0, newer =3D 1; =20 /* If we won't print another message, mention this anywa= y. */ - if (!NILP (nomessage) && !force_load_messages) + if (! NILP (nomessage) && !force_load_messages) { Lisp_Object msg_file; msg_file =3D Fsubstring (found, make_fixnum (0), mak= e_fixnum (-1)); @@ -1465,7 +1462,7 @@ DEFUN ("load", Fload, Sload, 1, 5, 0, else if (!is_module && !is_native_elisp) { /* We are loading a source file (*.el). */ - if (!NILP (Vload_source_file_function)) + if (! NILP (Vload_source_file_function)) { Lisp_Object val; =20 @@ -1594,7 +1591,7 @@ DEFUN ("load", Fload, Sload, 1, 5, 0, unbind_to (count, Qnil); =20 /* Run any eval-after-load forms for this file. */ - if (!NILP (Ffboundp (Qdo_after_load_evaluation))) + if (! NILP (Ffboundp (Qdo_after_load_evaluation))) call1 (Qdo_after_load_evaluation, hist_file_name) ; =20 xfree (saved_doc_string); @@ -1633,7 +1630,7 @@ save_match_data_load (Lisp_Object file, Lisp_Object n= oerror, Lisp_Object result =3D Fload (file, noerror, nomessage, nosuffix, must_s= uffix); return unbind_to (count, result); } - + static bool complete_filename_p (Lisp_Object pathname) { @@ -1725,7 +1722,7 @@ maybe_swap_for_eln (bool no_native, Lisp_Object *file= name, int *fd, src_name =3D concat2 (src_name, build_string (".gz")); if (NILP (Ffile_exists_p (src_name))) { - if (!NILP (find_symbol_value ( + if (! NILP (find_symbol_value ( Qnative_comp_warning_on_missing_source))) call2 (intern_c_string ("display-warning"), Qcomp, @@ -1901,12 +1898,12 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Obje= ct suffixes, else string =3D make_string (fn, fnlen); handler =3D Ffind_file_name_handler (string, Qfile_exists_p); - if ((!NILP (handler) || (!NILP (predicate) && !EQ (predicate, Qt))) + if ((! NILP (handler) || (! NILP (predicate) && !EQ (predicate, Qt))) && !FIXNATP (predicate)) { bool exists; if (NILP (predicate) || EQ (predicate, Qt)) - exists =3D !NILP (Ffile_readable_p (string)); + exists =3D ! NILP (Ffile_readable_p (string)); else { Lisp_Object tmp =3D call1 (predicate, string); @@ -2041,7 +2038,7 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object= suffixes, return -1; } =20 - + /* Merge the list we've accumulated of globals from the current input sour= ce into the load_history variable. The details depend on whether the source has an associated file name or not. @@ -2066,7 +2063,7 @@ build_load_history (Lisp_Object filename, bool entire) tem =3D XCAR (tail); =20 /* Find the feature's previous assoc list... */ - if (!NILP (Fequal (filename, Fcar (tem)))) + if (! NILP (Fequal (filename, Fcar (tem)))) { foundit =3D 1; =20 @@ -2199,7 +2196,7 @@ readevalloop (Lisp_Object readcharfun, specbind (Qstandard_input, readcharfun); specbind (Qcurrent_load_list, Qnil); record_unwind_protect_int (readevalloop_1, load_convert_to_unibyte); - load_convert_to_unibyte =3D !NILP (unibyte); + load_convert_to_unibyte =3D ! NILP (unibyte); =20 /* If lexical binding is active (either because it was specified in the file's header, or via a buffer-local variable), create an empty @@ -2212,7 +2209,7 @@ readevalloop (Lisp_Object readcharfun, =20 /* Ensure sourcename is absolute, except whilst preloading. */ if (!will_dump_p () - && !NILP (sourcename) && !NILP (Ffile_name_absolute_p (sourcename))) + && ! NILP (sourcename) && ! NILP (Ffile_name_absolute_p (sourcename)= )) sourcename =3D Fexpand_file_name (sourcename, Qnil); =20 LOADHIST_ATTACH (sourcename); @@ -2225,7 +2222,7 @@ readevalloop (Lisp_Object readcharfun, if (b !=3D 0 && !BUFFER_LIVE_P (b)) error ("Reading from killed buffer"); =20 - if (!NILP (start)) + if (! NILP (start)) { /* Switch to the buffer we are reading from. */ record_unwind_protect_excursion (); @@ -2239,7 +2236,7 @@ readevalloop (Lisp_Object readcharfun, =20 /* Set point and ZV around stuff to be read. */ Fgoto_char (start); - if (!NILP (end)) + if (! NILP (end)) Fnarrow_to_region (make_fixnum (BEGV), end); =20 /* Just for cleanliness, convert END to a marker @@ -2284,14 +2281,14 @@ readevalloop (Lisp_Object readcharfun, =3D make_hash_table (hashtest_eq, DEFAULT_HASH_SIZE, DEFAULT_REHASH_SIZE, DEFAULT_REHASH_THRESHOLD, Qnil, false); - if (!NILP (Vpurify_flag) && c =3D=3D '(') + if (! NILP (Vpurify_flag) && c =3D=3D '(') { val =3D read_list (0, readcharfun, false); } else { UNREAD (c); - if (!NILP (readfun)) + if (! NILP (readfun)) { val =3D call1 (readfun, readcharfun); =20 @@ -2318,14 +2315,14 @@ readevalloop (Lisp_Object readcharfun, && XHASH_TABLE (read_objects_completed)->count > 0) read_objects_completed =3D Qnil; =20 - if (!NILP (start) && continue_reading_p) + if (! NILP (start) && continue_reading_p) start =3D Fpoint_marker (); =20 /* Restore saved point and BEGV. */ unbind_to (count1, Qnil); =20 /* Now eval what we just read. */ - if (!NILP (macroexpand)) + if (! NILP (macroexpand)) val =3D readevalloop_eager_expand_eval (val, macroexpand); else val =3D eval_sub (val); @@ -2400,7 +2397,7 @@ DEFUN ("eval-buffer", Feval_buffer, Seval_buffer, 0, = 5, "", specbind (Qlexical_binding, lisp_file_lexically_bound_p (buf) ? Qt : Qni= l); BUF_TEMP_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf))); readevalloop (buf, 0, filename, - !NILP (printflag), unibyte, Qnil, Qnil, Qnil); + ! NILP (printflag), unibyte, Qnil, Qnil, Qnil); return unbind_to (count, Qnil); } =20 @@ -2434,13 +2431,32 @@ DEFUN ("eval-region", Feval_region, Seval_region, 2= , 4, "r", =20 /* `readevalloop' calls functions which check the type of start and end.= */ readevalloop (cbuf, 0, BVAR (XBUFFER (cbuf), filename), - !NILP (printflag), Qnil, read_function, + ! NILP (printflag), Qnil, read_function, start, end); =20 return unbind_to (count, Qnil); } =20 - +DEFUN ("read-annotated", Fread_annotated, Sread_annotated, 1, 1, 0, + doc: /* Return parsed s-expr as `read' with each atom bundled +with its charpos as (CHARPOS . ATOM). */) + (Lisp_Object buffer) +{ + Lisp_Object retval, warning; + ptrdiff_t count =3D SPECPDL_INDEX (); + + CHECK_BUFFER (buffer); + specbind (Qlread_unescaped_character_literals, Qnil); + retval =3D read_internal_start (buffer, Qnil, Qnil, true); + + warning =3D safe_call (1, intern ("byte-run--unescaped-character-literal= s-warning")); + if (! NILP (warning)) + call2 (intern ("byte-compile-warn"), build_string ("%s"), warning); + + unbind_to (count, Qnil); + return retval; +} + DEFUN ("read", Fread, Sread, 0, 1, 0, doc: /* Read one Lisp expression as text from STREAM, return as Lis= p object. If STREAM is nil, use the value of `standard-input' (which see). @@ -2469,34 +2485,6 @@ DEFUN ("read", Fread, Sread, 0, 1, 0, return read_internal_start (stream, Qnil, Qnil, false); } =20 -DEFUN ("read-positioning-symbols", Fread_positioning_symbols, - Sread_positioning_symbols, 0, 1, 0, - doc: /* Read one Lisp expression as text from STREAM, return as Lis= p object. -Convert each occurrence of a symbol into a "symbol with pos" object. - -If STREAM is nil, use the value of `standard-input' (which see). -STREAM or the value of `standard-input' may be: - a buffer (read from point and advance it) - a marker (read from where it points and advance it) - a function (call it with no arguments for each character, - call it with a char as argument to push a char back) - a string (takes text from string, starting at the beginning) - t (read text line using minibuffer and use it, or read from - standard input in batch mode). */) - (Lisp_Object stream) -{ - if (NILP (stream)) - stream =3D Vstandard_input; - if (EQ (stream, Qt)) - stream =3D Qread_char; - if (EQ (stream, Qread_char)) - /* FIXME: ?! When is this used !? */ - return call1 (intern ("read-minibuffer"), - build_string ("Lisp expression: ")); - - return read_internal_start (stream, Qnil, Qnil, true); -} - DEFUN ("read-from-string", Fread_from_string, Sread_from_string, 1, 3, 0, doc: /* Read one Lisp expression which is represented as text by ST= RING. Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX). @@ -2515,16 +2503,14 @@ DEFUN ("read-from-string", Fread_from_string, Sread= _from_string, 1, 3, 0, } =20 /* Function to set up the global context we need in toplevel read - calls. START and END only used when STREAM is a string. - LOCATE_SYMS true means read symbol occurrences as symbols with - position. */ + calls. START and END only used when STREAM is a string. */ static Lisp_Object -read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object en= d, - bool locate_syms) +read_internal_start (Lisp_Object stream, Lisp_Object start, + Lisp_Object end, bool annotated) { Lisp_Object retval; =20 - readchar_offset =3D BUFFERP (stream) ? XBUFFER (stream)->pt : 0; + readchar_charpos =3D BUFFERP (stream) ? XBUFFER (stream)->pt : 1; /* We can get called from readevalloop which may have set these already. */ if (! HASH_TABLE_P (read_objects_map) @@ -2557,7 +2543,7 @@ read_internal_start (Lisp_Object stream, Lisp_Object = start, Lisp_Object end, read_from_string_limit =3D endval; } =20 - retval =3D read0 (stream, locate_syms); + retval =3D read0 (stream, annotated); if (HASH_TABLE_P (read_objects_map) && XHASH_TABLE (read_objects_map)->count > 0) read_objects_map =3D Qnil; @@ -2566,25 +2552,23 @@ read_internal_start (Lisp_Object stream, Lisp_Objec= t start, Lisp_Object end, read_objects_completed =3D Qnil; return retval; } - =20 -/* Use this for recursive reads, in contexts where internal tokens - are not allowed. */ +/* "read0" is merely an error-checked version of "read1". */ =20 static Lisp_Object -read0 (Lisp_Object readcharfun, bool locate_syms) +read0 (Lisp_Object readcharfun, bool annotated) { register Lisp_Object val; int c; =20 - val =3D read1 (readcharfun, &c, 0, locate_syms); + val =3D read1 (readcharfun, &c, annotated); if (!c) return val; =20 invalid_syntax_lisp (Fmake_string (make_fixnum (1), make_fixnum (c), Qni= l), readcharfun); } - + /* Grow a read buffer BUF that contains OFFSET useful bytes of data, by at least MAX_MULTIBYTE_LENGTH bytes. Update *BUF_ADDR and *BUF_SIZE accordingly; 0 <=3D OFFSET <=3D *BUF_SIZE. If *BUF_ADDR is @@ -3000,16 +2984,14 @@ read_integer (Lisp_Object readcharfun, int radix, /* If the next token is ')' or ']' or '.', we store that character in *PCH and the return value is not interesting. Else, we store zero in *PCH and we read and return one lisp object. - - FIRST_IN_LIST is true if this is the first element of a list. - LOCATE_SYMS true means read symbol occurrences as symbols with - position. */ +*/ =20 static Lisp_Object -read1 (Lisp_Object readcharfun, int *pch, bool first_in_list, bool locate_= syms) +read1 (Lisp_Object readcharfun, int *pch, bool annotated) { int c; - bool uninterned_symbol =3D false; + EMACS_INT initial_charpos =3D readchar_charpos; + bool q_interned =3D true; bool skip_shorthand =3D false; bool multibyte; char stackbuf[stackbufsize]; @@ -3019,6 +3001,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_= in_list, bool locate_syms) =20 retry: =20 + initial_charpos =3D readchar_charpos; c =3D READCHAR_REPORT_MULTIBYTE (&multibyte); if (c < 0) end_of_file_error (); @@ -3026,16 +3009,16 @@ read1 (Lisp_Object readcharfun, int *pch, bool firs= t_in_list, bool locate_syms) switch (c) { case '(': - return read_list (0, readcharfun, locate_syms); + return read_list (0, readcharfun, annotated); =20 case '[': - return read_vector (readcharfun, 0, locate_syms); + return ANNOTATE (read_vector (readcharfun, 0)); =20 case ')': case ']': { *pch =3D c; - return Qnil; + return ANNOTATE (Qnil); } =20 case '#': @@ -3048,6 +3031,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_= in_list, bool locate_syms) /* Accept extended format for hash tables (extensible to other types), e.g. #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */ + Lisp_Object tmp =3D read_list (0, readcharfun, false); Lisp_Object head =3D CAR_SAFE (tmp); Lisp_Object data =3D Qnil; @@ -3070,7 +3054,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_= in_list, bool locate_syms) tmp =3D Fcdr (tmp); ASET (record, i, Fcar (tmp)); } - return record; + return ANNOTATE (record); } =20 tmp =3D CDR_SAFE (tmp); @@ -3078,32 +3062,32 @@ read1 (Lisp_Object readcharfun, int *pch, bool firs= t_in_list, bool locate_syms) /* This is repetitive but fast and simple. */ params[param_count] =3D QCsize; params[param_count + 1] =3D Fplist_get (tmp, Qsize); - if (!NILP (params[param_count + 1])) + if (! NILP (params[param_count + 1])) param_count +=3D 2; =20 params[param_count] =3D QCtest; params[param_count + 1] =3D Fplist_get (tmp, Qtest); - if (!NILP (params[param_count + 1])) + if (! NILP (params[param_count + 1])) param_count +=3D 2; =20 params[param_count] =3D QCweakness; params[param_count + 1] =3D Fplist_get (tmp, Qweakness); - if (!NILP (params[param_count + 1])) + if (! NILP (params[param_count + 1])) param_count +=3D 2; =20 params[param_count] =3D QCrehash_size; params[param_count + 1] =3D Fplist_get (tmp, Qrehash_size); - if (!NILP (params[param_count + 1])) + if (! NILP (params[param_count + 1])) param_count +=3D 2; =20 params[param_count] =3D QCrehash_threshold; params[param_count + 1] =3D Fplist_get (tmp, Qrehash_threshold); - if (!NILP (params[param_count + 1])) + if (! NILP (params[param_count + 1])) param_count +=3D 2; =20 params[param_count] =3D QCpurecopy; params[param_count + 1] =3D Fplist_get (tmp, Qpurecopy); - if (!NILP (params[param_count + 1])) + if (! NILP (params[param_count + 1])) param_count +=3D 2; =20 /* This is the hash table data. */ @@ -3123,10 +3107,10 @@ read1 (Lisp_Object readcharfun, int *pch, bool firs= t_in_list, bool locate_syms) last =3D XCDR (data); Fputhash (key, val, ht); } - if (!NILP (last)) + if (! NILP (last)) error ("Hash table data is not a list of even length"); =20 - return ht; + return ANNOTATE (ht); } UNREAD (c); invalid_syntax ("#", readcharfun); @@ -3137,11 +3121,11 @@ read1 (Lisp_Object readcharfun, int *pch, bool firs= t_in_list, bool locate_syms) if (c =3D=3D '[') { Lisp_Object tmp; - tmp =3D read_vector (readcharfun, 0, false); + tmp =3D read_vector (readcharfun, 0); if (ASIZE (tmp) < CHAR_TABLE_STANDARD_SLOTS) error ("Invalid size char-table"); XSETPVECTYPE (XVECTOR (tmp), PVEC_CHAR_TABLE); - return tmp; + return ANNOTATE (tmp); } else if (c =3D=3D '^') { @@ -3179,7 +3163,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_= in_list, bool locate_syms) cell =3D XCONS (tmp), tmp =3D XCDR (tmp); free_cons (cell); } - return tbl; + return ANNOTATE (tbl); } invalid_syntax ("#^^", readcharfun); } @@ -3188,7 +3172,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_= in_list, bool locate_syms) if (c =3D=3D '&') { Lisp_Object length; - length =3D read1 (readcharfun, pch, first_in_list, false); + length =3D read1 (readcharfun, pch, false); c =3D READCHAR; if (c =3D=3D '"') { @@ -3197,7 +3181,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_= in_list, bool locate_syms) unsigned char *data; =20 UNREAD (c); - tmp =3D read1 (readcharfun, pch, first_in_list, false); + tmp =3D read1 (readcharfun, pch, false); if (STRING_MULTIBYTE (tmp) || (size_in_chars !=3D SCHARS (tmp) /* We used to print 1 char too many @@ -3215,7 +3199,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_= in_list, bool locate_syms) if (XFIXNUM (length) !=3D size_in_chars * BOOL_VECTOR_BITS_PER_CHAR) data[size_in_chars - 1] &=3D (1 << (XFIXNUM (length) % BOOL_VECTOR_BITS_PER_CHAR)) - 1; - return val; + return ANNOTATE (val); } invalid_syntax ("#&...", readcharfun); } @@ -3225,7 +3209,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_= in_list, bool locate_syms) build them using function calls. */ Lisp_Object tmp; struct Lisp_Vector *vec; - tmp =3D read_vector (readcharfun, 1, false); + tmp =3D read_vector (readcharfun, 1); vec =3D XVECTOR (tmp); if (! (COMPILED_STACK_DEPTH < ASIZE (tmp) && (FIXNUMP (AREF (tmp, COMPILED_ARGLIST)) @@ -3254,7 +3238,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_= in_list, bool locate_syms) } =20 XSETPVECTYPE (vec, PVEC_COMPILED); - return tmp; + return ANNOTATE (tmp); } if (c =3D=3D '(') { @@ -3262,7 +3246,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_= in_list, bool locate_syms) int ch; =20 /* Read the string itself. */ - tmp =3D read1 (readcharfun, &ch, 0, false); + tmp =3D read1 (readcharfun, &ch, false); if (ch !=3D 0 || !STRINGP (tmp)) invalid_syntax ("#", readcharfun); /* Read the intervals and their properties. */ @@ -3270,20 +3254,20 @@ read1 (Lisp_Object readcharfun, int *pch, bool firs= t_in_list, bool locate_syms) { Lisp_Object beg, end, plist; =20 - beg =3D read1 (readcharfun, &ch, 0, false); + beg =3D read1 (readcharfun, &ch, false); end =3D plist =3D Qnil; if (ch =3D=3D ')') break; if (ch =3D=3D 0) - end =3D read1 (readcharfun, &ch, 0, false); + end =3D read1 (readcharfun, &ch, false); if (ch =3D=3D 0) - plist =3D read1 (readcharfun, &ch, 0, false); + plist =3D read1 (readcharfun, &ch, false); if (ch) invalid_syntax ("Invalid string property list", readcharfun); Fset_text_properties (beg, end, plist, tmp); } =20 - return tmp; + return ANNOTATE (tmp); } =20 /* #@NUMBER is used to skip NUMBER following bytes. @@ -3306,7 +3290,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_= in_list, bool locate_syms) if (digits =3D=3D 2 && nskip =3D=3D 0) { /* We've just seen #@00, which means "skip to end". */ skip_dyn_eof (readcharfun); - return Qnil; + return ANNOTATE (Qnil); } } if (nskip > 0) @@ -3386,13 +3370,13 @@ read1 (Lisp_Object readcharfun, int *pch, bool firs= t_in_list, bool locate_syms) goto retry; } if (c =3D=3D '$') - return Vload_file_name; + return ANNOTATE (Vload_file_name); if (c =3D=3D '\'') - return list2 (Qfunction, read0 (readcharfun, locate_syms)); + return ANNOTATE (list2 (Qfunction, read0 (readcharfun, false))); /* #:foo is the uninterned symbol named foo. */ if (c =3D=3D ':') { - uninterned_symbol =3D true; + q_interned =3D false; read_hash_prefixed_symbol: c =3D READCHAR; if (!(c > 040 @@ -3403,7 +3387,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_= in_list, bool locate_syms) /* No symbol character follows, this is the empty symbol. */ UNREAD (c); - return Fmake_symbol (empty_unibyte_string); + return ANNOTATE (Fmake_symbol (empty_unibyte_string)); } goto read_symbol; } @@ -3415,7 +3399,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_= in_list, bool locate_syms) } /* ## is the empty symbol. */ if (c =3D=3D '#') - return Fintern (empty_unibyte_string, Qnil); + return ANNOTATE (Fintern (empty_unibyte_string, Qnil)); =20 if (c >=3D '0' && c <=3D '9') { @@ -3435,7 +3419,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_= in_list, bool locate_syms) { if (! (2 <=3D n && n <=3D 36)) invalid_radix_integer (n, stackbuf, readcharfun); - return read_integer (readcharfun, n, stackbuf); + return ANNOTATE (read_integer (readcharfun, n, stackbuf)); } =20 if (n <=3D MOST_POSITIVE_FIXNUM && ! NILP (Vread_circle)) @@ -3471,7 +3455,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_= in_list, bool locate_syms) hash_put (h, number, placeholder, hash); =20 /* Read the object itself. */ - Lisp_Object tem =3D read0 (readcharfun, locate_syms); + Lisp_Object tem =3D read0 (readcharfun, false); =20 /* If it can be recursive, remember it for future substitutions. */ @@ -3491,7 +3475,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_= in_list, bool locate_syms) { Fsetcar (placeholder, XCAR (tem)); Fsetcdr (placeholder, XCDR (tem)); - return placeholder; + return ANNOTATE (placeholder); } else { @@ -3503,7 +3487,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_= in_list, bool locate_syms) eassert (i >=3D 0); set_hash_value_slot (h, i, tem); =20 - return tem; + return ANNOTATE (tem); } } =20 @@ -3514,18 +3498,18 @@ read1 (Lisp_Object readcharfun, int *pch, bool firs= t_in_list, bool locate_syms) =3D XHASH_TABLE (read_objects_map); ptrdiff_t i =3D hash_lookup (h, make_fixnum (n), NULL); if (i >=3D 0) - return HASH_VALUE (h, i); + return ANNOTATE (HASH_VALUE (h, i)); } } } /* Fall through to error message. */ } else if (c =3D=3D 'x' || c =3D=3D 'X') - return read_integer (readcharfun, 16, stackbuf); + return ANNOTATE (read_integer (readcharfun, 16, stackbuf)); else if (c =3D=3D 'o' || c =3D=3D 'O') - return read_integer (readcharfun, 8, stackbuf); + return ANNOTATE (read_integer (readcharfun, 8, stackbuf)); else if (c =3D=3D 'b' || c =3D=3D 'B') - return read_integer (readcharfun, 2, stackbuf); + return ANNOTATE (read_integer (readcharfun, 2, stackbuf)); =20 char acm_buf[15]; /* FIXME!!! 2021-11-27. */ sprintf (acm_buf, "#%c", c); @@ -3538,10 +3522,10 @@ read1 (Lisp_Object readcharfun, int *pch, bool firs= t_in_list, bool locate_syms) goto retry; =20 case '\'': - return list2 (Qquote, read0 (readcharfun, locate_syms)); + return ANNOTATE (list2 (Qquote, read0 (readcharfun, false))); =20 case '`': - return list2 (Qbackquote, read0 (readcharfun, locate_syms)); + return ANNOTATE (list2 (Qbackquote, read0 (readcharfun, false))); =20 case ',': { @@ -3557,8 +3541,8 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_= in_list, bool locate_syms) comma_type =3D Qcomma; } =20 - value =3D read0 (readcharfun, locate_syms); - return list2 (comma_type, value); + value =3D read0 (readcharfun, false); + return ANNOTATE (list2 (comma_type, value)); } case '?': { @@ -3575,7 +3559,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_= in_list, bool locate_syms) Other literal whitespace like NL, CR, and FF are not accepted, as there are well-established escape sequences for these. */ if (c =3D=3D ' ' || c =3D=3D '\t') - return make_fixnum (c); + return ANNOTATE (make_fixnum (c)); =20 if (c =3D=3D '(' || c =3D=3D ')' || c =3D=3D '[' || c =3D=3D ']' || c =3D=3D '"' || c =3D=3D ';') @@ -3601,7 +3585,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_= in_list, bool locate_syms) && strchr ("\"';()[]#?`,.", next_char) !=3D NULL)); UNREAD (next_char); if (ok) - return make_fixnum (c); + return ANNOTATE (make_fixnum (c)); =20 invalid_syntax ("?", readcharfun); } @@ -3709,8 +3693,8 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_= in_list, bool locate_syms) /* If purifying, and string starts with \ newline, return zero instead. This is for doc strings that we are really going to find in etc/DOC.nn.nn. */ - if (!NILP (Vpurify_flag) && NILP (Vdoc_file_name) && cancel) - return unbind_to (count, make_fixnum (0)); + if (! NILP (Vpurify_flag) && NILP (Vdoc_file_name) && cancel) + return ANNOTATE (unbind_to (count, make_fixnum (0))); =20 if (! force_multibyte && force_singlebyte) { @@ -3725,7 +3709,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_= in_list, bool locate_syms) =3D make_specified_string (read_buffer, nchars, p - read_buffer, (force_multibyte || (p - read_buffer !=3D nchars))); - return unbind_to (count, result); + return ANNOTATE (unbind_to (count, result)); } =20 case '.': @@ -3738,7 +3722,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_= in_list, bool locate_syms) && strchr ("\"';([#?`,", next_char) !=3D NULL)) { *pch =3D c; - return Qnil; + return ANNOTATE (Qnil); } } /* The atom-reading loop below will now loop at least once, @@ -3759,7 +3743,8 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_= in_list, bool locate_syms) char *p =3D read_buffer; char *end =3D read_buffer + read_buffer_size; bool quoted =3D false; - EMACS_INT start_position =3D readchar_offset - 1; + ptrdiff_t nchars =3D 0; + Lisp_Object result =3D Qnil; =20 do { @@ -3796,86 +3781,75 @@ read1 (Lisp_Object readcharfun, int *pch, bool firs= t_in_list, bool locate_syms) ptrdiff_t nbytes =3D p - read_buffer; UNREAD (c); =20 - if (!quoted && !uninterned_symbol && !skip_shorthand) + if (! quoted && q_interned && ! skip_shorthand) { - ptrdiff_t len; - Lisp_Object result =3D string_to_number (read_buffer, 10, &len); - if (! NILP (result) && len =3D=3D nbytes) - return unbind_to (count, result); + result =3D string_to_number (read_buffer, 10, &nchars); + if (nchars !=3D nbytes) + result =3D Qnil; } - { - Lisp_Object result; - ptrdiff_t nchars - =3D (multibyte - ? multibyte_chars_in_text ((unsigned char *) read_buffer, - nbytes) - : nbytes); - - if (uninterned_symbol) - { - Lisp_Object name - =3D ((! NILP (Vpurify_flag) - ? make_pure_string : make_specified_string) - (read_buffer, nchars, nbytes, multibyte)); - result =3D Fmake_symbol (name); - } - 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. */ - Lisp_Object obarray =3D check_obarray (Vobarray); - - char* longhand =3D NULL; - ptrdiff_t longhand_chars =3D 0; - ptrdiff_t longhand_bytes =3D 0; - - Lisp_Object tem; - if (skip_shorthand - /* The following ASCII characters are used in the - only "core" Emacs Lisp symbols that are comprised - entirely of characters that have the 'symbol - constituent' syntax. We exempt them from - transforming according to shorthands. */ - || strspn (read_buffer, "^*+-/<=3D>_|") >=3D nbytes) - tem =3D oblookup (obarray, read_buffer, nchars, nbytes); - else - tem =3D oblookup_considering_shorthand (obarray, read_buffer, - nchars, nbytes, &longhand, - &longhand_chars, - &longhand_bytes); - - if (SYMBOLP (tem)) - result =3D tem; - else if (longhand) - { - Lisp_Object name - =3D make_specified_string (longhand, longhand_chars, - longhand_bytes, multibyte); - xfree (longhand); - result =3D intern_driver (name, obarray, tem); - } - else - { - Lisp_Object name - =3D make_specified_string (read_buffer, nchars, nbytes, - multibyte); - result =3D intern_driver (name, obarray, tem); - } - } - if (locate_syms - && !NILP (result) - ) - result =3D build_symbol_with_pos (result, - make_fixnum (start_position)); =20 - return unbind_to (count, result); - } + if (NILP (result)) + { + nchars =3D (multibyte + ? multibyte_chars_in_text ((unsigned char *) read_buffer, + nbytes) + : nbytes); + if (! q_interned) + { + Lisp_Object name + =3D ((! NILP (Vpurify_flag) + ? make_pure_string : make_specified_string) + (read_buffer, nchars, nbytes, multibyte)); + result =3D Fmake_symbol (name); + } + 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. */ + char* longhand =3D NULL; + ptrdiff_t longhand_chars =3D 0, longhand_bytes =3D 0; + + Lisp_Object tem; + if (skip_shorthand + /* The following ASCII characters are used in the + only "core" Emacs Lisp symbols that are comprised + entirely of characters that have the 'symbol + constituent' syntax. We exempt them from + transforming according to shorthands. */ + || strspn (read_buffer, "^*+-/<=3D>_|") >=3D nbytes) + tem =3D oblookup (Vobarray, read_buffer, nchars, nbytes); + else + tem =3D oblookup_considering_shorthand (Vobarray, read_buffer, + nchars, nbytes, &longhand, + &longhand_chars, + &longhand_bytes); + if (SYMBOLP (tem)) + result =3D tem; + else if (longhand) + { + Lisp_Object name + =3D make_specified_string (longhand, longhand_chars, + longhand_bytes, multibyte); + xfree (longhand); + result =3D intern_driver (name, Vobarray, tem); + } + else + { + Lisp_Object name + =3D make_specified_string (read_buffer, nchars, nbytes, + multibyte); + result =3D intern_driver (name, Vobarray, tem); + } + } + } + + return ANNOTATE (unbind_to (count, result)); } } } - + DEFUN ("lread--substitute-object-in-subtree", Flread__substitute_object_in_subtree, Slread__substitute_object_in_subtree, 3, 3, 0, @@ -3909,7 +3883,7 @@ substitute_object_recurse (struct subst *subst, Lisp_= Object subtree) return subtree; =20 /* If we've been to this node before, don't explore it again. */ - if (!NILP (Fmemq (subtree, subst->seen))) + if (! NILP (Fmemq (subtree, subst->seen))) return subtree; =20 /* If this node can be the entry point to a cycle, remember that @@ -3980,7 +3954,7 @@ substitute_in_interval (INTERVAL interval, void *arg) substitute_object_recurse (arg, interval->plist)); } =20 - + /* Convert the initial prefix of STRING to a number, assuming base BASE. If the prefix has floating point syntax and BASE is 10, return a nearest float; otherwise, if the prefix has integer syntax, return @@ -4120,11 +4094,11 @@ string_to_number (char const *string, int base, ptr= diff_t *plen) return result; } =20 - + static Lisp_Object -read_vector (Lisp_Object readcharfun, bool bytecodeflag, bool locate_syms) +read_vector (Lisp_Object readcharfun, bool bytecodeflag) { - Lisp_Object tem =3D read_list (1, readcharfun, locate_syms); + Lisp_Object tem =3D read_list (1, readcharfun, false); ptrdiff_t size =3D list_length (tem); Lisp_Object vector =3D make_nil_vector (size); =20 @@ -4196,40 +4170,30 @@ read_vector (Lisp_Object readcharfun, bool bytecode= flag, bool locate_syms) return vector; } =20 -/* FLAG means check for ']' to terminate rather than ')' and '.'. - LOCATE_SYMS true means read symbol occurrencess as symbols with - position. */ +/* FLAG means check for ']' to terminate rather than ')' and '.'. */ =20 static Lisp_Object -read_list (bool flag, Lisp_Object readcharfun, bool locate_syms) +read_list (bool flag, Lisp_Object readcharfun, bool annotated) { - Lisp_Object val, tail; + Lisp_Object val =3D Qnil, tail =3D Qnil; Lisp_Object elt, tem; /* 0 is the normal case. 1 means this list is a doc reference; replace it with the number 0. 2 means this list is a doc reference; replace it with the doc string.= */ int doc_reference =3D 0; =20 - /* Initialize this to 1 if we are reading a list. */ - bool first_in_list =3D flag <=3D 0; - - val =3D Qnil; - tail =3D Qnil; - while (1) { int ch; - elt =3D read1 (readcharfun, &ch, first_in_list, locate_syms); - - first_in_list =3D 0; + elt =3D read1 (readcharfun, &ch, annotated); =20 /* While building, if the list starts with #$, treat it specially. = */ if (EQ (elt, Vload_file_name) && ! NILP (elt)) { - if (!NILP (Vpurify_flag)) + if (! NILP (Vpurify_flag)) doc_reference =3D 0; - else if (load_force_doc_strings) + else if (load_force_doc_strings && ! annotated) doc_reference =3D 2; } if (ch) @@ -4244,11 +4208,11 @@ read_list (bool flag, Lisp_Object readcharfun, bool= locate_syms) return val; if (ch =3D=3D '.') { - if (!NILP (tail)) - XSETCDR (tail, read0 (readcharfun, locate_syms)); + if (! NILP (tail)) + XSETCDR (tail, read0 (readcharfun, annotated)); else - val =3D read0 (readcharfun, locate_syms); - read1 (readcharfun, &ch, 0, locate_syms); + val =3D read0 (readcharfun, annotated); + read1 (readcharfun, &ch, annotated); =20 if (ch =3D=3D ')') { @@ -4321,14 +4285,15 @@ read_list (bool flag, Lisp_Object readcharfun, bool= locate_syms) invalid_syntax ("] in a list", readcharfun); } tem =3D list1 (elt); - if (!NILP (tail)) + if (! NILP (tail)) XSETCDR (tail, tem); else val =3D tem; tail =3D tem; } } - +#undef ANNOTATE + static Lisp_Object initial_obarray; =20 /* `oblookup' stores the bucket number here, for the sake of Funintern. */ @@ -4442,7 +4407,7 @@ 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. @@ -4519,7 +4484,7 @@ DEFUN ("intern-soft", Fintern_soft, Sintern_soft, 1, = 2, 0, return EQ (name, tem) ? name : Qnil; } } - + 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. @@ -4601,7 +4566,7 @@ DEFUN ("unintern", Funintern, Sunintern, 1, 2, 0, =20 return Qt; } - + /* Return the symbol in OBARRAY whose names matches the string of SIZE characters (SIZE_BYTE bytes) at PTR. If there is no such symbol, return the integer bucket number of @@ -4704,7 +4669,7 @@ oblookup_considering_shorthand (Lisp_Object obarray, = const char *in, return oblookup (obarray, in, size, size_byte); } =20 - + void map_obarray (Lisp_Object obarray, void (*fn) (Lisp_Object, Lisp_Object), L= isp_Object arg) { @@ -4773,7 +4738,7 @@ init_obarray_once (void) DEFSYM (Qvariable_documentation, "variable-documentation"); } =20 - + void defsubr (union Aligned_Lisp_Subr *aname) { @@ -4854,7 +4819,7 @@ defvar_kboard (struct Lisp_Kboard_Objfwd const *ko_fw= d, char const *namestring) XSYMBOL (sym)->u.s.redirect =3D SYMBOL_FORWARDED; SET_SYMBOL_FWD (XSYMBOL (sym), ko_fwd); } - + /* Check that the elements of lpath exist. */ =20 static void @@ -4865,7 +4830,7 @@ load_path_check (Lisp_Object lpath) /* The only elements that might not exist are those from PATH_LOADSEARCH, EMACSLOADPATH. Anything else is only added if it exists. */ - for (path_tail =3D lpath; !NILP (path_tail); path_tail =3D XCDR (path_ta= il)) + for (path_tail =3D lpath; ! NILP (path_tail); path_tail =3D XCDR (path_t= ail)) { Lisp_Object dirfile; dirfile =3D Fcar (path_tail); @@ -4923,7 +4888,7 @@ load_path_default (void) =20 lpath =3D decode_env_path (0, PATH_LOADSEARCH, 0); =20 - if (!NILP (Vinstallation_directory)) + if (! NILP (Vinstallation_directory)) { Lisp_Object tem, tem1; =20 @@ -4933,7 +4898,7 @@ load_path_default (void) tem =3D Fexpand_file_name (build_string ("lisp"), Vinstallation_directory); tem1 =3D Ffile_accessible_directory_p (tem); - if (!NILP (tem1)) + if (! NILP (tem1)) { if (NILP (Fmember (tem, lpath))) { @@ -4959,7 +4924,7 @@ load_path_default (void) tem =3D Fexpand_file_name (build_string ("site-lisp"), Vinstallation_directory); tem1 =3D Ffile_accessible_directory_p (tem); - if (!NILP (tem1)) + if (! NILP (tem1)) { if (NILP (Fmember (tem, lpath))) lpath =3D Fcons (tem, lpath); @@ -4985,7 +4950,7 @@ load_path_default (void) tem =3D Fexpand_file_name (build_string ("src/Makefile.in"), Vinstallation_directory); tem2 =3D Ffile_exists_p (tem); - if (!NILP (tem1) && NILP (tem2)) + if (! NILP (tem1) && NILP (tem2)) { tem =3D Fexpand_file_name (build_string ("lisp"), Vsource_directory); @@ -4998,7 +4963,7 @@ load_path_default (void) tem =3D Fexpand_file_name (build_string ("site-lisp"), Vsource_directory); tem1 =3D Ffile_accessible_directory_p (tem); - if (!NILP (tem1)) + if (! NILP (tem1)) { if (NILP (Fmember (tem, lpath))) lpath =3D Fcons (tem, lpath); @@ -5124,8 +5089,8 @@ dir_warning (char const *use, Lisp_Object dirname) syms_of_lread (void) { defsubr (&Sread); - defsubr (&Sread_positioning_symbols); defsubr (&Sread_from_string); + defsubr (&Sread_annotated); defsubr (&Slread__substitute_object_in_subtree); defsubr (&Sintern); defsubr (&Sintern_soft); @@ -5366,10 +5331,6 @@ syms_of_lread (void) DEFSYM (Qlread_unescaped_character_literals, "lread--unescaped-character-literals"); =20 - /* Defined in lisp/emacs-lisp/byte-run.el. */ - DEFSYM (Qbyte_run_unescaped_character_literals_warning, - "byte-run--unescaped-character-literals-warning"); - DEFVAR_BOOL ("load-prefer-newer", load_prefer_newer, doc: /* Non-nil means `load' prefers the newest version of = a file. This applies when a filename suffix is not explicitly specified and diff --git a/src/pdumper.c b/src/pdumper.c index f4e8e4af28a..60280fcb043 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2948,7 +2948,7 @@ dump_vectorlike (struct dump_context *ctx, Lisp_Object lv, dump_off offset) { -#if CHECK_STRUCTS && !defined HASH_pvec_type_AFF6FED5BD +#if CHECK_STRUCTS && !defined HASH_pvec_type_19F6CF5169 # error "pvec_type changed. See CHECK_STRUCTS comment in config.h." #endif const struct Lisp_Vector *v =3D XVECTOR (lv); @@ -3032,8 +3032,6 @@ dump_vectorlike (struct dump_context *ctx, error_unsupported_dump_object (ctx, lv, "sqlite"); case PVEC_MODULE_FUNCTION: error_unsupported_dump_object (ctx, lv, "module function"); - case PVEC_SYMBOL_WITH_POS: - error_unsupported_dump_object (ctx, lv, "symbol with pos"); default: error_unsupported_dump_object(ctx, lv, "weird pseudovector"); } diff --git a/src/print.c b/src/print.c index 04a271ce456..7440a82f6fd 100644 --- a/src/print.c +++ b/src/print.c @@ -1649,30 +1649,6 @@ print_vectorlike (Lisp_Object obj, Lisp_Object print= charfun, bool escapeflag, printchar ('>', printcharfun); break; =20 - case PVEC_SYMBOL_WITH_POS: - { - struct Lisp_Symbol_With_Pos *sp =3D XSYMBOL_WITH_POS (obj); - if (print_symbols_bare) - print_object (sp->sym, printcharfun, escapeflag); - else - { - print_c_string ("#sym)) - print_object (sp->sym, printcharfun, escapeflag); - else - print_c_string ("NOT A SYMBOL!!", printcharfun); - if (FIXNUMP (sp->pos)) - { - print_c_string (" at ", printcharfun); - print_object (sp->pos, printcharfun, escapeflag); - } - else - print_c_string (" NOT A POSITION!!", printcharfun); - printchar ('>', printcharfun); - } - } - break; - case PVEC_OVERLAY: print_c_string ("#buffer) @@ -1998,7 +1974,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharf= un, bool escapeflag) error ("Apparently circular structure being printed"); =20 for (i =3D 0; i < print_depth; i++) - if (BASE_EQ (obj, being_printed[i])) + if (EQ (obj, being_printed[i])) { int len =3D sprintf (buf, "#%d", i); strout (buf, len, len, printcharfun); @@ -2502,13 +2478,6 @@ syms_of_print (void) `default'. */); Vprint_charset_text_property =3D Qdefault; =20 - DEFVAR_BOOL ("print-symbols-bare", print_symbols_bare, - doc: /* A flag to control printing of symbols with position. -If the value is nil, print these objects complete with position. -Otherwise print just the bare symbol. */); - print_symbols_bare =3D false; - DEFSYM (Qprint_symbols_bare, "print-symbols-bare"); - /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */ staticpro (&Vprin1_to_string_buffer); =20 diff --git a/src/sqlite.c b/src/sqlite.c index 649cb382948..af88187b32c 100644 --- a/src/sqlite.c +++ b/src/sqlite.c @@ -1,7 +1,7 @@ /* Copyright (C) 2021-2022 Free Software Foundation, Inc. =20 -This file is part of GNU Emacs. +This file is NOT part of GNU Emacs. =20 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 diff --git a/test/Makefile.in b/test/Makefile.in index 9ad994e1101..2badb614b18 100644 --- a/test/Makefile.in +++ b/test/Makefile.in @@ -159,8 +159,8 @@ SELECTOR_ACTUAL=3D endif =20 ## Byte-compile all test files to test for errors. -%.elc: %.el - $(AM_V_ELC)$(emacs) --batch -f batch-byte-compile $< +%.elc: %.el $(srcdir)/../lisp/emacs-lisp/bytecomp.el + $(AM_V_ELC) $(emacs) --batch -f batch-byte-compile $< =20 ## Save logs, and show logs for failed tests. WRITE_LOG =3D > $@ 2>&1 || { STAT=3D$$?; cat $@; exit $$STAT; } diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/= bytecomp-tests.el index abd33ab8e5a..8db9210f91d 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -790,11 +790,11 @@ test-byte-comp-macro-expand-lexical-override (defun def () (m)))) (should (equal (funcall 'def) 4))) =20 - + ;;;; Warnings. =20 (ert-deftest bytecomp-tests--warnings () - (with-current-buffer (get-buffer-create "*Compile-Log*") + (with-current-buffer (get-buffer-create byte-compile-log-buffer) (let ((inhibit-read-only t)) (erase-buffer))) (mapc #'fmakunbound '(my-test0 my--test11 my--test12 my--test2)) (test-byte-comp-compile-and-load t @@ -807,7 +807,7 @@ bytecomp-tests--warnings (eval-and-compile (defmacro my--test12 (arg) (+ arg 1)) (defun my--test2 (arg) (+ arg 1))))) - (with-current-buffer (get-buffer-create "*Compile-Log*") + (with-current-buffer (get-buffer-create byte-compile-log-buffer) (goto-char (point-min)) ;; Should warn that mt--test1[12] are first used as functions. ;; The second alternative is for when the file name is so long @@ -822,12 +822,138 @@ bytecomp-tests--warnings =20 (defmacro bytecomp--with-warning-test (re-warning &rest form) (declare (indent 1)) - `(with-current-buffer (get-buffer-create "*Compile-Log*") + `(with-current-buffer (get-buffer-create byte-compile-log-buffer) (let ((inhibit-read-only t)) (erase-buffer)) (byte-compile ,@form) (ert-info ((prin1-to-string (buffer-string)) :prefix "buffer: ") (should (re-search-forward ,(string-replace " " "[ \n]+" re-warning= )))))) =20 +(defmacro bytecomp--buffer-with-warning-test (re-warnings &rest forms) + (declare (indent 1)) + `(with-current-buffer (get-buffer-create byte-compile-log-buffer) + (let ((inhibit-read-only t)) (erase-buffer)) + (save-excursion + (let ((buffer (generate-new-buffer "*bytecomp-tests*"))) + (with-current-buffer buffer + (mapc (lambda (form) + (if (stringp form) + (insert form) + (insert (format "%S\n" form)))) + ',forms)) + (byte-compile-from-buffer buffer) + (let (kill-buffer-query-functions) + (kill-buffer buffer)))) + (ert-info ((prin1-to-string (buffer-string)) :prefix "buffer: ") + (dolist (re-warning (if (atom ,re-warnings) + (list ,re-warnings) + ,re-warnings)) + (should (re-search-forward (string-replace " " "[ \n]+" re-warnin= g))))))) + +(ert-deftest bytecomp-warn-absent-require-cl-lib () + (bytecomp--buffer-with-warning-test + "cl-member-if. might not be defined" + (cl-member-if (function cl-evenp) (list 1 2 3)))) + +(ert-deftest bytecomp-warn-coordinates () + (let ((byte-compile-current-file "his-fooness.el")) + (bytecomp--buffer-with-warning-test + '("his-fooness.el:3:2" + "his-fooness.el:9:6" + "his-fooness.el:16:6" + "his-fooness.el:20:6" + "his-fooness.el:24:11" + "his-fooness.el:24:11" + "his-fooness.el:29:2" ;; let special form kicks back to defun + "his-fooness.el:31:3" + "his-fooness.el:32:2" ;; let special form kicks back to defun + "his-fooness.el:34:10" + "his-fooness.el:32:2" ;; this one too + "his-fooness.el:4:4" ;; cl-lib might not be defined at runtime. + ) + " +(bytecomp-tests-warn-coordinates-basic) +(defsubst bytecomp-tests-warn-coordinates-basic () + (cl-member-if (function cl-evenp) (list 1 2 3))) +(defun bytecomp-tests-warn-coordinates-roland () + (unwind-protect + (let ((foo \"foo\")) + (insert foo)) + (setq foo \"bar\"))) +(defun bytecomp-tests-warn-coordinates-eglen () + \"Fix page breaks in SAS 6 print files.\" + (interactive) + (save-excursion + (goto-char (point-min)) + (if (looking-at \"\f\") (delete-char 1)) + (replace-regexp \"^\\(.+\\)\f\" \"\\1\n\f\n\") + (goto-char (point-min)) + (replace-regexp \"^\f\\(.+\\)\" \"\f\n\\1\") + (goto-char (point-min)))) +(defun bytecomp-tests-warn-coordinates-kenichi (v) + (or (=3D (length v 0)) + (=3D (length v) 1))) +(defun bytecomp-tests-warn-coordinates-ynyaaa (_files) + (and t (string-match 1)) + (and t (string-match 1 2))) +(defun bytecomp-tests-warn-coordinates-clement () + (let ((a))) + a) +(defun bytecomp-tests-warn-coordinates-not-clement () + (let ((a))) + (progn a) + (let ((a))) + a) +"))) + +(ert-deftest bytecomp-warn-present-require-cl-lib () + (should-error + (bytecomp--buffer-with-warning-test + "cl-member-if. might not be defined" + (require 'cl-lib) + (cl-member-if (function cl-evenp) (list 1 2 3))))) + +(ert-deftest bytecomp-read-annotated-equivalence () + (cl-macrolet + ((bytecomp + (file &rest body) + `(with-temp-buffer + (save-excursion (insert-file-contents + (expand-file-name + ,file + (concat (file-name-as-directory + (or (getenv "EMACS_TEST_DIRECTORY") + default-directory)) + "..")))) + ,@body))) + (dolist (file '("lisp/emacs-lisp/cl-generic.el" + "lisp/international/mule-cmds.el" + "test/lisp/emacs-lisp/macroexp-tests.el")) + (let ((annotated-read + (bytecomp + file + (cl-loop while (progn + (while (progn (skip-chars-forward " \t\n\^l") + (=3D (following-char) ?\;)) + (forward-line 1)) + (not (eobp))) + collect (byte-compile--decouple + (read-annotated (current-buffer)) + #'cdr)))) + (just-read + (bytecomp + file + (cl-loop while (progn + (while (progn (skip-chars-forward " \t\n\^l") + (=3D (following-char) ?\;)) + (forward-line 1)) + (not (eobp))) + collect (read (current-buffer)))))) + (should + (condition-case nil + (equal annotated-read just-read) + (circular-list (equal (safe-length annotated-read) + (safe-length just-read))))))))) + (ert-deftest bytecomp-warn-wrong-args () (bytecomp--with-warning-test "remq.*3.*2" '(remq 1 2 3))) @@ -852,7 +978,7 @@ bytecomp-warn-wide-docstring/defvar =20 (defmacro bytecomp--define-warning-file-test (file re-warning &optional re= verse) `(ert-deftest ,(intern (format "bytecomp/%s" file)) () - (with-current-buffer (get-buffer-create "*Compile-Log*") + (with-current-buffer (get-buffer-create byte-compile-log-buffer) (let ((inhibit-read-only t)) (erase-buffer)) (byte-compile-file ,(ert-resource-file file)) (ert-info ((buffer-string) :prefix "buffer: ") @@ -1023,7 +1149,6 @@ "warn-variable-set-nonvariable.el" "nowarn-inline-after-defvar.el" "Lexical argument shadows" 'reverse) =20 - ;;;; Macro expansion. =20 (ert-deftest test-eager-load-macro-expansion () @@ -1113,15 +1238,16 @@ bytecomp-tests--test-no-warnings-with-advice (defun f ()) (define-advice f (:around (oldfun &rest args) test) (apply oldfun args)) - (with-current-buffer (get-buffer-create "*Compile-Log*") + (with-current-buffer (get-buffer-create byte-compile-log-buffer) (let ((inhibit-read-only t)) (erase-buffer))) (test-byte-comp-compile-and-load t '(defun f ())) - (with-current-buffer (get-buffer-create "*Compile-Log*") + (with-current-buffer (get-buffer-create byte-compile-log-buffer) (goto-char (point-min)) (should-not (search-forward "Warning" nil t)))) =20 (ert-deftest bytecomp-test-featurep-warnings () - (let ((byte-compile-log-buffer (generate-new-buffer " *Compile-Log*"))) + (let ((byte-compile-log-buffer + (generate-new-buffer (concat " " byte-compile-log-buffer)))) (unwind-protect (progn (with-temp-buffer @@ -1193,7 +1319,8 @@ bytecomp-test--switch-duplicates =20 (defun test-suppression (form suppress match) (let ((lexical-binding t) - (byte-compile-log-buffer (generate-new-buffer " *Compile-Log*"))) + (byte-compile-log-buffer + (generate-new-buffer (concat " " byte-compile-log-buffer)))) ;; Check that we get a warning without suppression. (with-current-buffer byte-compile-log-buffer (setq-local fill-column 9999) diff --git a/test/lisp/emacs-lisp/gv-tests.el b/test/lisp/emacs-lisp/gv-tes= ts.el index 0757e3c7aa5..f150bd21cfa 100644 --- a/test/lisp/emacs-lisp/gv-tests.el +++ b/test/lisp/emacs-lisp/gv-tests.el @@ -32,7 +32,7 @@ gv-tests--in-temp-dir (let ((,elvar "gv-test-deffoo.el") (,elcvar "gv-test-deffoo.elc")) (with-temp-file ,elvar - (insert ";; -*- lexical-binding: t; -*-\n") + (insert ";; -*- lexical-binding: t; -*-\n(require 'gv)\n") (dolist (form ',filebody) (pp form (current-buffer)))) ,@body))) @@ -117,7 +117,8 @@ gv-define-expander-out-of-file (with-temp-buffer (call-process (concat invocation-directory invocation-name) nil '(t t) nil - "-Q" "-batch" "--eval" (prin1-to-string `(byte-compile= -file ,el)) + "-Q" "-batch" + "--eval" (prin1-to-string `(byte-compile-file ,el)) "-l" elc "--eval" (prin1-to-string '(progn (setf (gv-test-foo gv-test-pa= ir) 99) --=20 2.26.2 --=-=-= Content-Type: text/plain In Commercial Emacs 0.2.1snapshot a8a0cc3 in dev (upstream 29.0.50, x86_64-pc-linux-gnu) built on dick Repository revision: a8a0cc3a11c149851f324a9a9bea0d4c6e0d5def Repository branch: dev Windowing system distributor 'The X.Org Foundation', version 11.0.12013000 System Description: Ubuntu 20.04.3 LTS Configured using: 'configure --prefix=/home/dick/.local --with-tree-sitter --enable-dumping-overwrite 'CFLAGS=-g3 -O2 -I/home/dick/.local/include/' LDFLAGS=-L/home/dick/.local/lib' Configured features: CAIRO DBUS FREETYPE GIF GLIB GMP GNUTLS GSETTINGS HARFBUZZ JPEG JSON TREE_SITTER LCMS2 LIBSELINUX LIBXML2 MODULES NOTIFY INOTIFY PDUMPER PNG RSVG SECCOMP SOUND THREADS TIFF TOOLKIT_SCROLL_BARS WEBP X11 XDBE XIM XPM GTK3 ZLIB Important settings: value of $LANG: en_US.UTF-8 locale-coding-system: utf-8-unix Major mode: Group Minor modes in effect: gnus-topic-mode: t gnus-undo-mode: t projectile-mode: t flx-ido-mode: t override-global-mode: t winner-mode: t tooltip-mode: t show-paren-mode: t mouse-wheel-mode: t file-name-shadow-mode: t global-font-lock-mode: t font-lock-mode: t blink-cursor-mode: t auto-composition-mode: t auto-encryption-mode: t auto-compression-mode: t buffer-read-only: t column-number-mode: t line-number-mode: t transient-mark-mode: t Load-path shadows: /home/dick/gomacro-mode/gomacro-mode hides /home/dick/.emacs.d/elpa/gomacro-mode-20200326.1103/gomacro-mode /home/dick/.emacs.d/elpa/hydra-20170924.2259/lv hides /home/dick/.emacs.d/elpa/lv-20191106.1238/lv /home/dick/.emacs.d/elpa/magit-3.3.0/magit-section-pkg hides /home/dick/.emacs.d/elpa/magit-section-3.3.0/magit-section-pkg /home/dick/org-gcal.el/org-gcal hides /home/dick/.emacs.d/elpa/org-gcal-0.3/org-gcal /home/dick/.emacs.d/lisp/json hides /home/dick/.local/share/emacs/0.2.1/lisp/json /home/dick/.emacs.d/elpa/transient-0.3.6/transient hides /home/dick/.local/share/emacs/0.2.1/lisp/transient /home/dick/.emacs.d/elpa/hierarchy-20171221.1151/hierarchy hides /home/dick/.local/share/emacs/0.2.1/lisp/emacs-lisp/hierarchy Features: (shadow bbdb-message footnote emacsbug sendmail gnus-html url-queue help-fns radix-tree flow-fill gravatar dns gnus-notifications gnus-fun notifications gnus-kill utf-7 qp sort smiley mail-extr textsec uni-scripts idna-mapping ucs-normalize uni-confusable textsec-check gnus-async gnus-ml disp-table nndoc gnus-dup benchmark mm-archive url-cache debbugs-gnu add-log debbugs soap-client rng-xsd rng-dt rng-util xsd-regexp nnrss nnfolder nndiscourse rbenv nnhackernews nntwitter nntwitter-api bbdb-gnus gnus-demon nntp nnmairix nnml nnreddit gnus-topic url-http url-auth url-gw network-stream gnutls nsm request virtualenvwrapper gud s json-rpc python gnus-score score-mode gnus-bcklg gnus-srvr gnus-cite anaphora bbdb-mua bbdb-com bbdb bbdb-site timezone gnus-delay gnus-draft gnus-cache gnus-agent gnus-msg gnus-art mm-uu mml2015 mm-view mml-smime smime dig gnus-sum shr pixel-fill kinsoku svg dom nndraft nnmh gnus-group mm-url gnus-undo use-package use-package-delight use-package-diminish gnus-start gnus-dbus dbus xml gnus-cloud nnimap nnmail mail-source utf7 netrc nnoo parse-time iso8601 gnus-spec gnus-int gnus-range message yank-media rmc puny dired-x dired dired-loaddefs rfc822 mml mml-sec epa epg rfc6068 epg-config mm-decode mm-bodies mm-encode mail-parse rfc2231 rfc2047 rfc2045 ietf-drums mailabbrev gmm-utils mailheader gnus-win smerge-mode diff vc-git vc-dispatcher whitespace diff-mode paredit-ext paredit subed subed-vtt subed-srt subed-common subed-mpv subed-debug subed-config inf-ruby ruby-mode smie company pcase haskell-interactive-mode haskell-presentation-mode haskell-process haskell-session haskell-compile haskell-mode haskell-cabal haskell-utils haskell-font-lock haskell-indentation haskell-string haskell-sort-imports haskell-lexeme haskell-align-imports haskell-complete-module haskell-ghc-support noutline outline flymake-proc flymake warnings etags fileloop generator xref project dabbrev haskell-customize hydra lv use-package-ensure solarized-theme solarized-definitions projectile lisp-mnt ibuf-ext ibuffer ibuffer-loaddefs thingatpt magit-autorevert autorevert filenotify magit-git magit-section magit-utils crm dash rx grep compile comint ansi-color gnus nnheader range mail-utils mm-util mail-prsvr gnus-util text-property-search time-date flx-ido flx google-translate-default-ui google-translate-core-ui facemenu color ido google-translate-core google-translate-tk google-translate-backend use-package-bind-key bind-key auto-complete easy-mmode advice edmacro kmacro popup cus-edit pp cus-load wid-edit emms-player-mplayer emms-player-simple emms emms-compat cl-extra help-mode use-package-core derived winner ring finder-inf json-reformat-autoloads json-snatcher-autoloads sml-mode-autoloads tornado-template-mode-autoloads info package browse-url url url-proxy url-privacy url-expand url-methods url-history url-cookie url-domsuf url-util mailcap url-handlers url-parse auth-source cl-seq eieio eieio-core cl-macs eieio-loaddefs password-cache json map url-vars seq gv subr-x byte-opt bytecomp byte-compile cconv cldefs cl-loaddefs cl-lib iso-transl tooltip eldoc paren electric uniquify ediff-hook vc-hooks lisp-float-type elisp-mode mwheel term/x-win x-win term/common-win x-dnd tool-bar dnd fontset image regexp-opt fringe tree-sitter tabulated-list replace newcomment text-mode lisp-mode prog-mode register page tab-bar menu-bar rfn-eshadow isearch easymenu timer select scroll-bar mouse jit-lock font-lock syntax font-core term/tty-colors frame minibuffer cl-generic cham georgian utf-8-lang misc-lang vietnamese tibetan thai tai-viet lao korean japanese eucjp-ms cp51932 hebrew greek romanian slovak czech european ethiopic indian cyrillic chinese composite emoji-zwj charscript charprop case-table epa-hook jka-cmpr-hook help simple abbrev obarray cl-preloaded nadvice button loaddefs faces cus-face macroexp files window text-properties overlay sha1 md5 base64 format env code-pages mule custom widget keymap hashtable-print-readable backquote threads dbusbind inotify lcms2 dynamic-setting system-font-setting font-render-setting cairo move-toolbar gtk x-toolkit x multi-tty make-network-process emacs) Memory information: ((conses 16 878999 83139) (symbols 48 35304 3) (strings 32 177445 23342) (string-bytes 1 5085348) (vectors 16 75009) (vector-slots 8 1051120 70621) (floats 8 4045 863) (intervals 56 13903 1539) (buffers 992 29)) --=-=-=-- From debbugs-submit-bounces@debbugs.gnu.org Wed Feb 09 21:06:31 2022 Received: (at 53905-done) by debbugs.gnu.org; 10 Feb 2022 02:06:31 +0000 Received: from localhost ([127.0.0.1]:53167 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1nHyqs-0004kA-UP for submit@debbugs.gnu.org; Wed, 09 Feb 2022 21:06:31 -0500 Received: from sonic307-10.consmr.mail.ne1.yahoo.com ([66.163.190.33]:37592) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1nHyqr-0004jw-5Y for 53905-done@debbugs.gnu.org; Wed, 09 Feb 2022 21:06:29 -0500 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=yahoo.com; s=s2048; t=1644458782; bh=cvZUBmYA53kDsZ9AkOonRPcl22tmfnmjW39uz1oU/fk=; h=From:To:Cc:Subject:References:Date:In-Reply-To:From:Subject:Reply-To; b=Cu2yErc6ZPNiOBD5A4tMrgbaTgYNxo21tC8vFy250zds+iVNGDpnfu1VRjGTmbnWugVG41r612GwXraB1tyrRCATH7szESocr/cOV713ZTOS6nj5kBGtMM+xGVvWbrUoTica0S+wZHw6dEcX6RKM4Qxju9NV5WZTZWhk+Mc8QMagLMAixmc9rhS5cBfEdos1yyH0w3eY0aq3xU32o5qA2zGq5zusdutS7wazB9oCx57CDM0eDiRPApeLLRQZ1XZTl3uqotFA6/1i1hV917UPecGDP2cd1EUgewNHe39D+6Aiwn8LC5l3AEN1MfTDX+W0Ad9WEkgmqWJ1eeTgZakEJA== X-SONIC-DKIM-SIGN: v=1; a=rsa-sha256; c=relaxed/relaxed; d=yahoo.com; s=s2048; t=1644458782; bh=ccJo1YNmkkvkkV5ivox8rMtMh979r02bwQGw5GPtXuI=; h=X-Sonic-MF:From:To:Subject:Date:From:Subject; b=sgE+MmLARbKY7bqbiOLKPxe5xcACDVhFq3v9ZnjsjvxCko1Sw0yL5z3Z+lARnwjlF1Ntd8OiQ6m7PBC+flyz1ult7LHUpMvOIMmoFyIU6GS7e5o3Hqta/lzVWZcGAfNwbLXNNC0VVNyYhlSnBXlwH4ZZqf9sSW0DTAMd2yu1aQJBVadlJ0mwAxQMdhJbjg+f1XA8y0wwM+R4aXWTHGQR14ijlqUjRoOejwsXS1v9LebukxJnQPjksCOfEzyVWMGmRvORW5WW5clPJMRdr0tlQh9zGdFkyZn7swpaXVwwogLiTNg0dWUhVZzYX2SBRSXP2biAAUUTU+reU2hy00qGpw== X-YMail-OSG: rCUCiK0VM1m8U08o.KnZrJev6pX9YSY6jb2_FJA5.k1Q7bz_p2LohBa1b_cxgtZ g.Que.gMQOt9aCWjiz5Y8Vj_s17jWUNP8vYjZxXGml1l7mtK8GW_pLBa6f_QXP1miUNflCfVu5Y2 n8705cVbL4KJzFCoq2u9Ata47d0QkOuPcOOlhz9uRqsenE5ZjaDLn3I2pX.aoAw43OgzCAbBKcLn PCNhHHYRctq7Owo5861CkywE3LbBOEx9FHBaAsT.vx.2g6.dxAZMJVHDK2etMzXvZLl.H7MptQ.D .L0q6rJ5IOM.n1HnXTBBnMzYOYpqXQ349srypQ485cCftwijJiYWbyRFB6kGkFzLv0tXUxjppYH4 mYt9yTD2JdCLzOO3tdPcuxGD6suNZj5Yrg5QuAyy5imhxWFHT_1ykjGByu9k3E1mgTLMZXopnhU6 AhrJTKEzEqkZhfzZlRcPsvoy90ZosBvn85cbk0UKDuCDeuH0SyPwsTXOZMrfszuTHU6zW6vWwpxJ G.6M78QO3yNwiHzTW_dqvxN4y3tOwDG1RjgfUursIcMv2BwoK8CP3L9wKoxAvZ0V5BBbo6pmtiCE 7.E0Z1MNdpPBttlH5HFrN9sqiw1mdJt3jS5W8M36Lx.augXuK2XnFZqUMD0mg3FWiZLjEeKXfQsq jUnffC0CPzYXEcCLodCMsBUiL9fOowYtxaRUzhjh5g3caiJYOsXBWpiOpKkflaSUW9fzk1djHu9y 7b7Nj1ujSN2VPCx.EPyOs_eHdcPkrUAE8lAF3abtlSl5Ja9zguzLvy21JZFCWvdG6QDn5n0cpOik IolrokiPkyGckIlzIs9ZsFjgWjSQ8_UdFeoerXPvQmFOav.apD21_USh7oQLPGaTxlkE6IWLwEHS ppBm2iM2BBXQVlnUKoCopdhQXAT65vGRqcZ27ocVB2h7dTKIVFpXg0c0u4bn1CLRSs3WIzFTObPs _O4LKEL.yy0us_PaSbW0f1h34mZZ2UrE2GnkPrTYOAmC98EUEbsViIeJ_Y4bvBmp9axHgYVlJvh0 YS4XC7gAzCgKEZLCfbHJzen33PXbYru9g7GTECAgauE5LkenFXh3M76hGgdFElBzBQLXT8oetBSA WTfPAhEhYKTnZiIW7v4NPqpbDhmJQzSaW8sgBZ12qMneZGPOttJWTmK8PK..92dqmWLn4O5lRQCi ISkAcdIAByzJATl.eyI8lIapuDSoDLwLoOQnP5K5ty6LWjOvtdpxR5Dhc2UMXx2rZS2VIuRqmFtn 3mKeCvnekdjFFfXlYvNTpPN0Zkg4FysJ.Km7Eqc.oqPHAx.0jbXjonHqD9wtNQqNIH1mHnJBt8fO RqniL2Zf_Cqh3PUZtx8u0960WE9g.6eniwMc2DEsH6CC2pNxNALkyNaUqMBsEsM0qYPoZdxUNDUM lfP_st_Z_Gj1PYafKhBOp4h27D0UPK_c3xG0MEbtZ5sdvoHJl4WT.TTsiqRidweblkYH7aPfUBTi 2sojghJO8qaNQDATGQguyc3_zbFi1zAfcYnVAx5hUrfayJUefQUc26vqQ2obMxcpCVzLwuH3Ozdj IOnQiDLqi50C9o4IUK4x3AxEY3ROsprzBTjXlHwNh5_jw6gAlLtmGE6iXKXBcD73VPJopaFd6O0Y daSJdvK9rYTTnBVUw_f_3yzF30JEktVN8MuTEkMJu.MlH6OSBckaAO.uLAfqY1QtVQSdGS1OZYiv nrqmopr_JSux.w.kyin7R9PFqGdzg0My3TuSPqPJQWXUu9Y0NS7LJBZTVPATC9vXMaKVT5JAvde0 sb8TJioz0v6Hm3zEmzW4WqgcR7GiDBoiKl3Qlx.5uxUAuggddtJeXYOQXMw2WIHk9HGya0vnIwbJ DB.HCcZoARahise3V9fPcEPKpNR0qxev7kBAMj.6jQiKrpz.BQPjrScCFNmZyMKSaba8otLjURrD rfZFQ_aQjyhwMn1igc4AfDY1RPavJA4L241FVjV1zJ_p37lds64ScKNrwZ5eSSLEbDwZiZ_KbI7I 7SvCJxF39CabTMmXKUIrceZVrwDtcwN8qU4Lv8JnhYupvEoCDt8E_YjF074njoOnsGAiMFSOr6ZU DvNKSO_Sbtv1_aMf.wgPQiYULaHtmRA7S3Ni_oq6w4g2k4sIRUD.jQQJKb9p45Glnqw3OahyFpwF Ojw49antBapm8jSqlNoIHD67Ui0b5jEBP6afoAjObDdcykpAj8QWsPOG52oU2ejioaBlqhHJlV6Q c0NpvQp_HDkLhiFoCtbRjrNc2emK6pghXFfR2OKvSVZ8Mj.HCpLgzNLhsMVrm X-Sonic-MF: Received: from sonic.gate.mail.ne1.yahoo.com by sonic307.consmr.mail.ne1.yahoo.com with HTTP; Thu, 10 Feb 2022 02:06:22 +0000 Received: by kubenode518.mail-prod1.omega.sg3.yahoo.com (VZM Hermes SMTP Server) with ESMTPA ID 94ae08fc66107dc2fb620266c63bc4a3; Thu, 10 Feb 2022 02:06:20 +0000 (UTC) From: Po Lu To: dick.r.chiang@gmail.com Subject: Re: bug#53905: 29.0.50; [PATCH] Back out scratch/correct-warning-pos References: <87zgmzamcd.fsf@dick> Date: Thu, 10 Feb 2022 10:06:15 +0800 In-Reply-To: <87zgmzamcd.fsf@dick> (dick r. chiang's message of "Wed, 09 Feb 2022 14:09:22 -0500") Message-ID: <87h797zd9k.fsf@yahoo.com> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/28.0.91 (gnu/linux) MIME-Version: 1.0 Content-Type: text/plain X-Mailer: WebService/1.1.19724 mail.backend.jedi.jws.acl:role.jedi.acl.token.atz.jws.hermes.yahoo Content-Length: 246 X-Spam-Score: -0.0 (/) X-Debbugs-Envelope-To: 53905-done Cc: 53905-done@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) dick.r.chiang@gmail.com writes: > Prefer giving up some diagnostic precision to avoid vitiating > the lisp implementation. You didn't say why it was "vitiating", and the decision was already made to install the branch, so I'm closing this bug. From unknown Sun Jun 15 13:00:54 2025 Received: (at fakecontrol) by fakecontrolmessage; To: internal_control@debbugs.gnu.org From: Debbugs Internal Request Subject: Internal Control Message-Id: bug archived. Date: Thu, 10 Mar 2022 12:24:04 +0000 User-Agent: Fakemail v42.6.9 # This is a fake control message. # # The action: # bug archived. thanks # This fakemail brought to you by your local debbugs # administrator