From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: dick.r.chiang@gmail.com Newsgroups: gmane.emacs.bugs Subject: bug#53905: 29.0.50; [PATCH] Back out scratch/correct-warning-pos Date: Wed, 09 Feb 2022 14:09:22 -0500 Message-ID: <87zgmzamcd.fsf@dick> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="20486"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: Gnus/5.14 (Gnus v5.14) Commercial/29.0.50 (gnu/linux) To: 53905@debbugs.gnu.org Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Wed Feb 09 20:47:42 2022 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1nHswH-0004xP-Vj for geb-bug-gnu-emacs@m.gmane-mx.org; Wed, 09 Feb 2022 20:47:42 +0100 Original-Received: from localhost ([::1]:51262 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1nHswG-0001Sc-Bb for geb-bug-gnu-emacs@m.gmane-mx.org; Wed, 09 Feb 2022 14:47:40 -0500 Original-Received: from eggs.gnu.org ([209.51.188.92]:45850) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1nHsaN-00041h-AZ for bug-gnu-emacs@gnu.org; Wed, 09 Feb 2022 14:25:03 -0500 Original-Received: from debbugs.gnu.org ([209.51.188.43]:58812) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1nHsaM-0004Yd-VJ for bug-gnu-emacs@gnu.org; Wed, 09 Feb 2022 14:25:03 -0500 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1nHsaM-0005Og-S1 for bug-gnu-emacs@gnu.org; Wed, 09 Feb 2022 14:25:02 -0500 X-Loop: help-debbugs@gnu.org Resent-From: dick.r.chiang@gmail.com Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Wed, 09 Feb 2022 19:25:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: report 53905 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch X-Debbugs-Original-To: bug-gnu-emacs Original-Received: via spool by submit@debbugs.gnu.org id=B.164443468720705 (code B ref -1); Wed, 09 Feb 2022 19:25:02 +0000 Original-Received: (at submit) by debbugs.gnu.org; 9 Feb 2022 19:24:47 +0000 Original-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 Original-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 Original-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 Original-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 Original-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) Original-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) 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-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 X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Original-Sender: "bug-gnu-emacs" Xref: news.gmane.io gmane.emacs.bugs:226503 Archived-At: --=-=-= 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)) --=-=-=--