commit e670412a3e101e70dc26e021f467faece8cb7f6b (HEAD, refs/remotes/origin/master) Author: Jens Schmidt Date: Mon Nov 20 23:42:01 2023 +0100 Update handling of advices during preload * lisp/emacs-lisp/comp-common.el (native-comp-never-optimize-functions): Remove macroexpand and rename-buffer from default value. * lisp/emacs-lisp/comp.el (comp-call-optim-form-call): Document call optimization for advised primitives. * lisp/emacs-lisp/nadvice.el (advice-add): Remove references to TODOs that were completed already earlier. * lisp/loadup.el: Disallow advices during preload. (Bug#67005) diff --git a/lisp/emacs-lisp/comp-common.el b/lisp/emacs-lisp/comp-common.el index 6d94d1bd82e..b7a685223ed 100644 --- a/lisp/emacs-lisp/comp-common.el +++ b/lisp/emacs-lisp/comp-common.el @@ -49,11 +49,10 @@ native-comp-verbose :version "28.1") (defcustom native-comp-never-optimize-functions - '(eval - ;; The following two are mandatory for Emacs to be working - ;; correctly (see comment in `advice--add-function'). DO NOT - ;; REMOVE. - macroexpand rename-buffer) + ;; We used to list those functions here that were advised during + ;; preload, but we now prefer to disallow preload advices in + ;; loadup.el (bug#67005). + '(eval) "Primitive functions to exclude from trampoline optimization. Primitive functions included in this list will not be called diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 39e32d5142c..3e5ff195764 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2789,6 +2789,14 @@ comp-call-optim-form-call (symbol-function callee) (cl-assert (byte-code-function-p callee)) callee)) + ;; Below call to `subrp' returns nil on an advised + ;; primitive F, so that we do not optimize calls to F + ;; with the funcall trampoline removal below. But if F + ;; is advised while we compile its call, it is very + ;; likely to be advised also when that call is executed. + ;; And in that case an "unoptimized" call to F is + ;; actually cheaper since it avoids the call to the + ;; intermediate native trampoline (bug#67005). (subrp (subrp f)) (comp-func-callee (comp-func-in-unit callee))) (cond diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 42027c01491..9f2b42f5765 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -509,8 +509,6 @@ advice-add <<>>" ;; TODO: ;; - record the advice location, to display in describe-function. - ;; - change all defadvice in lisp/**/*.el. - ;; - obsolete advice.el. (let* ((f (symbol-function symbol)) (nf (advice--normalize symbol f))) (unless (eq f nf) (fset symbol nf)) diff --git a/lisp/loadup.el b/lisp/loadup.el index 07895228d0d..3b58d5fb9b7 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -393,6 +393,15 @@ ;; from the repository. It is generated just after temacs is built. (load "leim/leim-list.el" t) +;; Actively disallow advised functions during preload since: +;; - advices in Emacs's core are generally considered bad style; +;; - `Snarf-documentation' looses docstrings of primitives advised +;; during preload (bug#66032#20). +(mapatoms + (lambda (f) + (and (advice--p (symbol-function f)) + (error "Preload advice on %s" f)))) + ;; If you want additional libraries to be preloaded and their ;; doc strings kept in the DOC file rather than in core, ;; you may load them with a "site-load.el" file. commit f5e45247081ab2489581c650423413a2b6c2caf9 Author: Andrea Corallo Date: Mon Dec 4 19:14:28 2023 +0100 comp: Fix mvar dependency chain (bug#67239) * lisp/emacs-lisp/comp.el (comp-add-cond-cstrs): Emit assume with the original mvar as explicit rhs. (comp-fwprop-insn): Add note. * test/src/comp-tests.el (67239-1): Add new test. * test/src/comp-resources/comp-test-funcs.el (comp-test-time) (comp-test-67239-00-f, comp-test-67239-0-f, comp-test-67239-1-f): Define. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 08d406b7999..39e32d5142c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1967,10 +1967,14 @@ comp-add-cond-cstrs (set ,(and (pred comp-mvar-p) mvar-3) (call memq ,(and (pred comp-mvar-p) mvar-1) ,(and (pred comp-mvar-p) mvar-2))) (cond-jump ,(and (pred comp-mvar-p) mvar-3) ,(pred comp-mvar-p) ,bb1 ,bb2)) - (push `(assume ,mvar-tested ,(make-comp-mvar :type (comp-cstr-cl-tag mvar-tag))) - (comp-block-insns (comp-add-cond-cstrs-target-block b bb2))) - (push `(assume ,mvar-tested ,(make-comp-mvar :type (comp-cstr-cl-tag mvar-tag) :neg t)) - (comp-block-insns (comp-add-cond-cstrs-target-block b bb1)))) + (comp-emit-assume 'and mvar-tested + (make-comp-mvar :type (comp-cstr-cl-tag mvar-tag)) + (comp-add-cond-cstrs-target-block b bb2) + nil) + (comp-emit-assume 'and mvar-tested + (make-comp-mvar :type (comp-cstr-cl-tag mvar-tag)) + (comp-add-cond-cstrs-target-block b bb1) + t)) (`((set ,(and (pred comp-mvar-p) cmp-res) (,(pred comp--call-op-p) ,(and (or (pred comp--equality-fun-p) @@ -2645,6 +2649,8 @@ comp-fwprop-insn (_ (comp-cstr-shallow-copy lval rval)))) (`(assume ,lval ,(and (pred comp-mvar-p) rval)) + ;; NOTE we should probably assert this case in the future when + ;; will be possible. (comp-cstr-shallow-copy lval rval)) (`(assume ,lval (,kind . ,operands)) (cl-case kind diff --git a/test/src/comp-resources/comp-test-funcs.el b/test/src/comp-resources/comp-test-funcs.el index 85282e4dc97..4b5f61d504f 100644 --- a/test/src/comp-resources/comp-test-funcs.el +++ b/test/src/comp-resources/comp-test-funcs.el @@ -543,6 +543,22 @@ comp-test-63674-1-f (if (comp-test-struct-p pkg) x) t)) + +(cl-defstruct comp-test-time + unix) + +(defun comp-test-67239-00-f (a) + (cl-assert (stringp a))) + +(defsubst comp-test-67239-0-f (x _y) + (cl-etypecase x + (comp-test-time (error "foo")) + (string (comp-test-67239-00-f x)))) + +(defun comp-test-67239-1-f () + (let ((time (make-comp-test-time :unix (time-convert (current-time) 'integer)))) + (comp-test-67239-0-f "%F" time))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index c2f0af51570..92b66496c46 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -582,6 +582,10 @@ 61917-1 (advice-remove #'delete-region f) (should (equal comp-test-primitive-redefine-args '(1 2)))))) +(comp-deftest 67239-1 () + "" + (should-not (comp-test-67239-1-f))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; commit 365114d3bda270f35268ab7d5335de3bec0e89ac Author: Andrea Corallo Date: Sat Dec 2 09:53:03 2023 +0100 * lisp/emacs-lisp/comp.el (comp--native-compile): Better log. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index dd08bc93ae4..08d406b7999 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3363,7 +3363,7 @@ comp--native-compile for pass in comp-passes unless (memq pass comp-disabled-passes) do - (comp-log (format "(%s) Running pass %s:\n" + (comp-log (format "\n(%s) Running pass %s:\n" function-or-file pass) 2) (setf data (funcall pass data)) commit c8636b46356f1bfecee89f09e255e3cb93baaed4 Author: Andrea Corallo Date: Mon Nov 27 15:39:24 2023 +0100 comp: Rename some functions * lisp/emacs-lisp/comp.el (comp--known-predicate-p) (comp--pred-to-cstr, comp-edge, comp--edge-make) (comp--block-preds, comp--gen-counter, comp-func) (comp--equality-fun-p, comp--arithm-cmp-fun-p, comp--set-op-p) (comp--assign-op-p, comp--call-op-p, comp--branch-op-p) (comp--limple-insn-call-p, comp--type-hint-p) (comp--func-unique-in-cu-p, comp--symbol-func-to-fun) (comp--function-pure-p, comp--alloc-class-to-container) (comp--add-const-to-relocs, comp--prettyformat-insn) (comp--log-func, comp--log-edges, comp-emit-setimm) (comp-emit-lambda-for-top-level, comp-add-cond-cstrs) (comp-collect-calls, comp-compute-dominator-tree) (comp-function-foldable-p, comp-function-call-maybe-fold) (comp-func-in-unit, comp-call-optim-form-call) (comp-dead-assignments-func, comp-tco) (comp-remove-type-hints-func, comp-remove-type-hints) (comp-compute-function-type, comp-finalize-relocs) (comp-compile-ctxt-to-file): Rename and update. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 73764eb1d79..dd08bc93ae4 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -224,13 +224,13 @@ comp-known-predicates-h finally return h) "Hash table function -> `comp-constraint'.") -(defun comp-known-predicate-p (predicate) +(defun comp--known-predicate-p (predicate) "Return t if PREDICATE is known." (when (or (gethash predicate comp-known-predicates-h) (gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt))) t)) -(defun comp-pred-to-cstr (predicate) +(defun comp--pred-to-cstr (predicate) "Given PREDICATE, return the corresponding constraint." (or (gethash predicate comp-known-predicates-h) (gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt)))) @@ -430,7 +430,7 @@ comp-args-base (:include comp-block)) "A basic block holding only constraints.") -(cl-defstruct (comp-edge (:copier nil) (:constructor make--comp-edge)) +(cl-defstruct (comp-edge (:copier nil) (:constructor comp--edge-make0)) "An edge connecting two basic blocks." (src nil :type (or null comp-block)) (dst nil :type (or null comp-block)) @@ -438,19 +438,19 @@ comp-args-base :documentation "The index number corresponding to this edge in the edge hash.")) -(defun make-comp-edge (&rest args) +(defun comp--edge-make (&rest args) "Create a `comp-edge' with basic blocks SRC and DST." (let ((n (funcall (comp-func-edge-cnt-gen comp-func)))) (puthash n - (apply #'make--comp-edge :number n args) + (apply #'comp--edge-make0 :number n args) (comp-func-edges-h comp-func)))) -(defun comp-block-preds (basic-block) +(defun comp--block-preds (basic-block) "Return the list of predecessors of BASIC-BLOCK." (mapcar #'comp-edge-src (comp-block-in-edges basic-block))) -(defun comp-gen-counter () +(defun comp--gen-counter () "Return a sequential number generator." (let ((n -1)) (lambda () @@ -484,9 +484,9 @@ comp-gen-counter :documentation "LAP label -> LIMPLE basic block name.") (edges-h (make-hash-table) :type hash-table :documentation "Hash edge-num -> edge connecting basic two blocks.") - (block-cnt-gen (funcall #'comp-gen-counter) :type function + (block-cnt-gen (funcall #'comp--gen-counter) :type function :documentation "Generates block numbers.") - (edge-cnt-gen (funcall #'comp-gen-counter) :type function + (edge-cnt-gen (funcall #'comp--gen-counter) :type function :documentation "Generates edges numbers.") (has-non-local nil :type boolean :documentation "t if non local jumps are present.") @@ -525,39 +525,39 @@ comp-mvar-type-hint-match-p -(defun comp-equality-fun-p (function) +(defun comp--equality-fun-p (function) "Equality functions predicate for FUNCTION." (when (memq function '(eq eql equal)) t)) -(defun comp-arithm-cmp-fun-p (function) +(defun comp--arithm-cmp-fun-p (function) "Predicate for arithmetic comparison functions." (when (memq function '(= > < >= <=)) t)) -(defun comp-set-op-p (op) +(defun comp--set-op-p (op) "Assignment predicate for OP." (when (memq op comp-limple-sets) t)) -(defun comp-assign-op-p (op) +(defun comp--assign-op-p (op) "Assignment predicate for OP." (when (memq op comp-limple-assignments) t)) -(defun comp-call-op-p (op) +(defun comp--call-op-p (op) "Call predicate for OP." (when (memq op comp-limple-calls) t)) -(defun comp-branch-op-p (op) +(defun comp--branch-op-p (op) "Branch predicate for OP." (when (memq op comp-limple-branches) t)) -(defsubst comp-limple-insn-call-p (insn) +(defsubst comp--limple-insn-call-p (insn) "Limple INSN call predicate." - (comp-call-op-p (car-safe insn))) + (comp--call-op-p (car-safe insn))) -(defun comp-type-hint-p (func) +(defun comp--type-hint-p (func) "Type-hint predicate for function name FUNC." (when (memq func comp-type-hints) t)) -(defun comp-func-unique-in-cu-p (func) +(defun comp--func-unique-in-cu-p (func) "Return t if FUNC is known to be unique in the current compilation unit." (if (symbolp func) (cl-loop with h = (make-hash-table :test #'eq) @@ -569,46 +569,46 @@ comp-func-unique-in-cu-p finally return t) t)) -(defsubst comp-symbol-func-to-fun (symbol-funcion) +(defsubst comp--symbol-func-to-fun (symbol-funcion) "Given a function called SYMBOL-FUNCION return its `comp-func'." (gethash (gethash symbol-funcion (comp-ctxt-sym-to-c-name-h comp-ctxt)) (comp-ctxt-funcs-h comp-ctxt))) -(defun comp-function-pure-p (f) +(defun comp--function-pure-p (f) "Return t if F is pure." (or (get f 'pure) - (when-let ((func (comp-symbol-func-to-fun f))) + (when-let ((func (comp--symbol-func-to-fun f))) (comp-func-pure func)))) -(defun comp-alloc-class-to-container (alloc-class) +(defun comp--alloc-class-to-container (alloc-class) "Given ALLOC-CLASS, return the data container for the current context. Assume allocation class `d-default' as default." (cl-struct-slot-value 'comp-ctxt (or alloc-class 'd-default) comp-ctxt)) -(defsubst comp-add-const-to-relocs (obj) +(defsubst comp--add-const-to-relocs (obj) "Keep track of OBJ into the ctxt relocations." - (puthash obj t (comp-data-container-idx (comp-alloc-class-to-container + (puthash obj t (comp-data-container-idx (comp--alloc-class-to-container comp-curr-allocation-class)))) ;;; Log routines. -(defun comp-prettyformat-mvar (mvar) +(defun comp--prettyformat-mvar (mvar) (format "#(mvar %s %s %S)" (comp-mvar-id mvar) (comp-mvar-slot mvar) (comp-cstr-to-type-spec mvar))) -(defun comp-prettyformat-insn (insn) +(defun comp--prettyformat-insn (insn) (cond ((comp-mvar-p insn) - (comp-prettyformat-mvar insn)) + (comp--prettyformat-mvar insn)) ((proper-list-p insn) - (concat "(" (mapconcat #'comp-prettyformat-insn insn " ") ")")) + (concat "(" (mapconcat #'comp--prettyformat-insn insn " ") ")")) (t (prin1-to-string insn)))) -(defun comp-log-func (func verbosity) +(defun comp--log-func (func verbosity) "Log function FUNC at VERBOSITY. VERBOSITY is a number between 0 and 3." (when (>= native-comp-verbose verbosity) @@ -619,9 +619,9 @@ comp-log-func do (comp-log (concat "<" (symbol-name block-name) ">") verbosity) (cl-loop for insn in (comp-block-insns bb) - do (comp-log (comp-prettyformat-insn insn) verbosity))))) + do (comp-log (comp--prettyformat-insn insn) verbosity))))) -(defun comp-log-edges (func) +(defun comp--log-edges (func) "Log edges in FUNC." (let ((edges (comp-func-edges-h func))) (comp-log (format "\nEdges in function: %s\n" @@ -963,7 +963,7 @@ make-comp-mvar "`comp-mvar' initializer." (let ((mvar (make--comp-mvar :slot slot))) (when const-vld - (comp-add-const-to-relocs constant) + (comp--add-const-to-relocs constant) (setf (comp-cstr-imm mvar) constant)) (when type (setf (comp-mvar-typeset mvar) (list type))) @@ -1008,7 +1008,7 @@ comp-emit-annotation (defsubst comp-emit-setimm (val) "Set constant VAL to current slot." - (comp-add-const-to-relocs val) + (comp--add-const-to-relocs val) ;; Leave relocation index nil on purpose, will be fixed-up in final ;; by `comp-finalize-relocs'. (comp-emit `(setimm ,(comp-slot) ,val))) @@ -1496,7 +1496,7 @@ comp-limplify-finalize-function (cl-loop for bb being the hash-value in (comp-func-blocks func) do (setf (comp-block-insns bb) (nreverse (comp-block-insns bb)))) - (comp-log-func func 2) + (comp--log-func func 2) func) (cl-defgeneric comp-prepare-args-for-top-level (function) @@ -1570,7 +1570,7 @@ comp-emit-lambda-for-top-level These are stored in the reloc data array." (let ((args (comp-prepare-args-for-top-level func))) (let ((comp-curr-allocation-class 'd-impure)) - (comp-add-const-to-relocs (comp-func-byte-func func))) + (comp--add-const-to-relocs (comp-func-byte-func func))) (comp-emit (comp-call 'comp--register-lambda ;; mvar to be fixed-up when containers are @@ -1773,7 +1773,7 @@ comp-collect-rhs do (cl-loop for insn in (comp-block-insns b) for (op . args) = insn - if (comp-assign-op-p op) + if (comp--assign-op-p op) do (comp-collect-mvars (cdr args)) else do (comp-collect-mvars args)))) @@ -1822,7 +1822,7 @@ comp-emit-assume (comp-cstr-negation-make rhs) rhs))) (comp-block-insns bb)))) - ((pred comp-arithm-cmp-fun-p) + ((pred comp--arithm-cmp-fun-p) (when-let ((kind (if negated (comp-negate-arithm-cmp-fun kind) kind))) @@ -1855,7 +1855,7 @@ comp-add-new-block-between (cl-loop with new-bb = (make-comp-block-cstr :name bb-symbol :insns `((jump ,(comp-block-name bb-b)))) - with new-edge = (make-comp-edge :src bb-a :dst new-bb) + with new-edge = (comp--edge-make :src bb-a :dst new-bb) for ed in (comp-block-in-edges bb-b) when (eq (comp-edge-src ed) bb-a) do @@ -1886,7 +1886,7 @@ comp-cond-cstrs-target-mvar when (eq insn exit-insn) do (cl-return (and (comp-mvar-p res) res)) do (pcase insn - (`(,(pred comp-assign-op-p) ,(pred targetp) ,rhs) + (`(,(pred comp--assign-op-p) ,(pred targetp) ,rhs) (setf res rhs))) finally (cl-assert nil)))) @@ -1972,9 +1972,9 @@ comp-add-cond-cstrs (push `(assume ,mvar-tested ,(make-comp-mvar :type (comp-cstr-cl-tag mvar-tag) :neg t)) (comp-block-insns (comp-add-cond-cstrs-target-block b bb1)))) (`((set ,(and (pred comp-mvar-p) cmp-res) - (,(pred comp-call-op-p) - ,(and (or (pred comp-equality-fun-p) - (pred comp-arithm-cmp-fun-p)) + (,(pred comp--call-op-p) + ,(and (or (pred comp--equality-fun-p) + (pred comp--arithm-cmp-fun-p)) fun) ,op1 ,op2)) ;; (comment ,_comment-str) @@ -2006,14 +2006,14 @@ comp-add-cond-cstrs block-target negated))) finally (cl-return-from in-the-basic-block))) (`((set ,(and (pred comp-mvar-p) cmp-res) - (,(pred comp-call-op-p) - ,(and (pred comp-known-predicate-p) fun) + (,(pred comp--call-op-p) + ,(and (pred comp--known-predicate-p) fun) ,op)) ;; (comment ,_comment-str) (cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks)) (cl-loop with target-mvar = (comp-cond-cstrs-target-mvar op (car insns-seq) b) - with cstr = (comp-pred-to-cstr fun) + with cstr = (comp--pred-to-cstr fun) for branch-target-cell on blocks for branch-target = (car branch-target-cell) for negated in '(t nil) @@ -2025,14 +2025,14 @@ comp-add-cond-cstrs finally (cl-return-from in-the-basic-block))) ;; Match predicate on the negated branch (unless). (`((set ,(and (pred comp-mvar-p) cmp-res) - (,(pred comp-call-op-p) - ,(and (pred comp-known-predicate-p) fun) + (,(pred comp--call-op-p) + ,(and (pred comp--known-predicate-p) fun) ,op)) (set ,neg-cmp-res (call eq ,cmp-res ,(pred comp-cstr-null-p))) (cond-jump ,neg-cmp-res ,(pred comp-mvar-p) . ,blocks)) (cl-loop with target-mvar = (comp-cond-cstrs-target-mvar op (car insns-seq) b) - with cstr = (comp-pred-to-cstr fun) + with cstr = (comp--pred-to-cstr fun) for branch-target-cell on blocks for branch-target = (car branch-target-cell) for negated in '(nil t) @@ -2084,10 +2084,10 @@ comp-add-call-cstr (comp-loop-insn-in-block bb (when-let ((match (pcase insn - (`(set ,lhs (,(pred comp-call-op-p) ,f . ,args)) + (`(set ,lhs (,(pred comp--call-op-p) ,f . ,args)) (when-let ((cstr-f (gethash f comp-known-func-cstr-h))) (cl-values f cstr-f lhs args))) - (`(,(pred comp-call-op-p) ,f . ,args) + (`(,(pred comp--call-op-p) ,f . ,args) (when-let ((cstr-f (gethash f comp-known-func-cstr-h))) (cl-values f cstr-f nil args)))))) (cl-multiple-value-bind (f cstr-f lhs args) match @@ -2126,7 +2126,7 @@ comp-add-cstrs (comp-add-cond-cstrs-simple) (comp-add-cond-cstrs) (comp-add-call-cstr) - (comp-log-func comp-func 3)))) + (comp--log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -2145,9 +2145,9 @@ comp-collect-calls do (cl-loop for insn in (comp-block-insns b) do (pcase insn - (`(set ,_lval (,(pred comp-call-op-p) ,f . ,_rest)) + (`(set ,_lval (,(pred comp--call-op-p) ,f . ,_rest)) (puthash f t h)) - (`(,(pred comp-call-op-p) ,f . ,_rest) + (`(,(pred comp--call-op-p) ,f . ,_rest) (puthash f t h)))) finally return (cl-loop for f being each hash-key of h @@ -2160,7 +2160,7 @@ comp-collect-calls (defun comp-pure-infer-func (f) "If all functions called by F are pure then F is pure too." (when (and (cl-every (lambda (x) - (or (comp-function-pure-p x) + (or (comp--function-pure-p x) (eq x (comp-func-name f)))) (comp-collect-calls f)) (not (eq (comp-func-pure f) t))) @@ -2224,16 +2224,16 @@ comp-compute-edges for (op first second third forth) = last-insn do (cl-case op (jump - (make-comp-edge :src bb :dst (gethash first blocks))) + (comp--edge-make :src bb :dst (gethash first blocks))) (cond-jump - (make-comp-edge :src bb :dst (gethash third blocks)) - (make-comp-edge :src bb :dst (gethash forth blocks))) + (comp--edge-make :src bb :dst (gethash third blocks)) + (comp--edge-make :src bb :dst (gethash forth blocks))) (cond-jump-narg-leq - (make-comp-edge :src bb :dst (gethash second blocks)) - (make-comp-edge :src bb :dst (gethash third blocks))) + (comp--edge-make :src bb :dst (gethash second blocks)) + (comp--edge-make :src bb :dst (gethash third blocks))) (push-handler - (make-comp-edge :src bb :dst (gethash third blocks)) - (make-comp-edge :src bb :dst (gethash forth blocks))) + (comp--edge-make :src bb :dst (gethash third blocks)) + (comp--edge-make :src bb :dst (gethash forth blocks))) (return) (unreachable) (otherwise @@ -2250,7 +2250,7 @@ comp-compute-edges (comp-block-out-edges (comp-edge-src edge))) (push edge (comp-block-in-edges (comp-edge-dst edge)))) - (comp-log-edges comp-func))) + (comp--log-edges comp-func))) (defun comp-collect-rev-post-order (basic-block) "Walk BASIC-BLOCK children and return their name in reversed post-order." @@ -2306,7 +2306,7 @@ comp-compute-dominator-tree do (cl-loop for name in (cdr rev-bb-list) for b = (gethash name blocks) - for preds = (comp-block-preds b) + for preds = (comp--block-preds b) for new-idom = (first-processed preds) initially (setf changed nil) do (cl-loop for p in (delq new-idom preds) @@ -2326,7 +2326,7 @@ comp-compute-dominator-frontiers (cl-loop with blocks = (comp-func-blocks comp-func) for b-name being each hash-keys of blocks using (hash-value b) - for preds = (comp-block-preds b) + for preds = (comp--block-preds b) when (length> preds 1) ; All joins do (cl-loop for p in preds for runner = p @@ -2358,7 +2358,7 @@ comp-place-phis ;; Return t if a SLOT-N was assigned within BB. (cl-loop for insn in (comp-block-insns bb) for op = (car insn) - when (or (and (comp-assign-op-p op) + when (or (and (comp--assign-op-p op) (eql slot-n (comp-mvar-slot (cadr insn)))) ;; fetch-handler is after a non local ;; therefore clobbers all frame!!! @@ -2424,7 +2424,7 @@ comp-ssa-rename-insn (setf (comp-vec-aref frame slot-n) mvar (cadr insn) mvar)))) (pcase insn - (`(,(pred comp-assign-op-p) ,(pred targetp) . ,_) + (`(,(pred comp--assign-op-p) ,(pred targetp) . ,_) (let ((mvar (comp-vec-aref frame slot-n))) (setf (cddr insn) (cl-nsubst-if mvar #'targetp (cddr insn)))) (new-lvalue)) @@ -2511,7 +2511,7 @@ comp-ssa (comp-place-phis) (comp-ssa-rename) (comp-finalize-phis) - (comp-log-func comp-func 3) + (comp--log-func comp-func 3) (setf (comp-func-ssa-status f) t)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -2574,7 +2574,7 @@ comp-fwprop-prologue (defun comp-function-foldable-p (f args) "Given function F called with ARGS, return non-nil when optimizable." - (and (comp-function-pure-p f) + (and (comp--function-pure-p f) (cl-every #'comp-cstr-imm-vld-p args))) (defun comp-function-call-maybe-fold (insn f args) @@ -2582,7 +2582,7 @@ comp-function-call-maybe-fold Return non-nil if the function is folded successfully." (cl-flet ((rewrite-insn-as-setimm (insn value) ;; See `comp-emit-setimm'. - (comp-add-const-to-relocs value) + (comp--add-const-to-relocs value) (setf (car insn) 'setimm (cddr insn) `(,value)))) (cond @@ -2599,7 +2599,7 @@ comp-function-call-maybe-fold ;; should do basic block pruning in order to be sure that this ;; is not dead-code. This is now left to gcc, to be ;; implemented only if we want a reliable diagnostic here. - (let* ((f (if-let (f-in-ctxt (comp-symbol-func-to-fun f)) + (let* ((f (if-let (f-in-ctxt (comp--symbol-func-to-fun f)) ;; If the function is IN the compilation ctxt ;; and know to be pure. (comp-func-byte-func f-in-ctxt) @@ -2676,7 +2676,7 @@ comp-fwprop-insn (comp-func-blocks comp-func)))) (or (comp-latch-p bb) (when (comp-block-cstr-p bb) - (comp-latch-p (car (comp-block-preds bb))))))) + (comp-latch-p (car (comp--block-preds bb))))))) rest)) (prop-fn (if from-latch #'comp-cstr-union-no-range @@ -2743,7 +2743,7 @@ comp-fwprop (format "fwprop pass jammed into %s?" (comp-func-name f)))) (comp-log (format "Propagation run %d times\n" i) 2)) (comp-rewrite-non-locals) - (comp-log-func comp-func 3)))) + (comp--log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -2766,7 +2766,7 @@ comp-func-in-unit "Given FUNC return the `comp-fun' definition in the current context. FUNCTION can be a function-name or byte compiled function." (if (symbolp func) - (comp-symbol-func-to-fun func) + (comp--symbol-func-to-fun func) (cl-assert (byte-code-function-p func)) (gethash func (comp-ctxt-byte-func-to-func-h comp-ctxt)))) @@ -2804,7 +2804,7 @@ comp-call-optim-form-call ((and comp-func-callee (comp-func-c-name comp-func-callee) (or (and (>= (comp-func-speed comp-func) 3) - (comp-func-unique-in-cu-p callee)) + (comp--func-unique-in-cu-p callee)) (and (>= (comp-func-speed comp-func) 2) ;; Anonymous lambdas can't be redefined so are ;; always safe to optimize. @@ -2816,7 +2816,7 @@ comp-call-optim-form-call args (fill-args args (comp-args-max func-args))))) `(,call-type ,(comp-func-c-name comp-func-callee) ,@args))) - ((comp-type-hint-p callee) + ((comp--type-hint-p callee) `(call ,callee ,@args))))))) (defun comp-call-optim-func () @@ -2873,7 +2873,7 @@ comp-dead-assignments-func do (cl-loop for insn in (comp-block-insns b) for (op arg0 . rest) = insn - if (comp-assign-op-p op) + if (comp--assign-op-p op) do (push (comp-mvar-id arg0) l-vals) (setf r-vals (nconc (comp-collect-mvar-ids rest) r-vals)) else @@ -2891,10 +2891,10 @@ comp-dead-assignments-func for b being each hash-value of (comp-func-blocks comp-func) do (comp-loop-insn-in-block b (cl-destructuring-bind (op &optional arg0 arg1 &rest rest) insn - (when (and (comp-assign-op-p op) + (when (and (comp--assign-op-p op) (memq (comp-mvar-id arg0) nuke-list)) (setf insn - (if (comp-limple-insn-call-p arg1) + (if (comp--limple-insn-call-p arg1) arg1 `(comment ,(format "optimized out: %s" insn)))))))) @@ -2911,7 +2911,7 @@ comp-dead-code for i from 1 while (comp-dead-assignments-func) finally (comp-log (format "dead code rm run %d times\n" i) 2) - (comp-log-func comp-func 3)))) + (comp--log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -2951,7 +2951,7 @@ comp-tco (not (comp-func-has-non-local f))) (let ((comp-func f)) (comp-tco-func) - (comp-log-func comp-func 3)))) + (comp--log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -2967,7 +2967,7 @@ comp-remove-type-hints-func for b being each hash-value of (comp-func-blocks comp-func) do (comp-loop-insn-in-block b (pcase insn - (`(set ,l-val (call ,(pred comp-type-hint-p) ,r-val)) + (`(set ,l-val (call ,(pred comp--type-hint-p) ,r-val)) (setf insn `(set ,l-val ,r-val))))))) (defun comp-remove-type-hints (_) @@ -2976,7 +2976,7 @@ comp-remove-type-hints (when (>= (comp-func-speed f) 2) (let ((comp-func f)) (comp-remove-type-hints-func) - (comp-log-func comp-func 3)))) + (comp--log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -3029,7 +3029,7 @@ comp-compute-function-type finally return res))) (type `(function ,(comp-args-to-lambda-list (comp-func-l-args func)) ,(comp-cstr-to-type-spec res-mvar)))) - (comp-add-const-to-relocs type) + (comp--add-const-to-relocs type) ;; Fix it up. (setf (comp-cstr-imm (comp-func-type func)) type)))) @@ -3058,7 +3058,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 symbol-with-pos-p)) (let* ((d-default (comp-ctxt-d-default comp-ctxt)) (d-default-idx (comp-data-container-idx d-default)) @@ -3113,7 +3113,7 @@ comp-compile-ctxt-to-file (let ((dir (file-name-directory name))) (comp-finalize-relocs) (maphash (lambda (_ f) - (comp-log-func f 1)) + (comp--log-func f 1)) (comp-ctxt-funcs-h comp-ctxt)) (unless (file-exists-p dir) ;; In case it's created in the meanwhile. commit 7a7d41e07c4627c5de08a66368309b478c88edfc Author: Eli Zaretskii Date: Mon Dec 4 15:10:06 2023 +0200 Avoid infloop with wide images * src/xdisp.c (produce_image_glyph): Avoid inflooping under visual-line-mode when wide images are displayed. (Bug#67533) diff --git a/src/xdisp.c b/src/xdisp.c index ca8583869df..75d769600c4 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -31364,7 +31364,10 @@ produce_image_glyph (struct it *it) the cursor on same display row. But don't do that under word-wrap, unless the image starts at column zero, because wrapping correctly needs the real pixel width of the image. */ - if ((it->line_wrap != WORD_WRAP || it->hpos == 0) + if ((it->line_wrap != WORD_WRAP + || it->hpos == 0 + /* Always crop images larger than the window-width, minus 1 space. */ + || it->pixel_width > it->last_visible_x - FRAME_COLUMN_WIDTH (it->f)) && (crop = it->pixel_width - (it->last_visible_x - it->current_x), crop > 0) && (it->hpos == 0 || it->pixel_width > it->last_visible_x / 4)) commit cf11fdfd8e460d966ba279f00633ab378038de68 Author: Andrea Corallo Date: Sun Dec 3 22:14:32 2023 +0100 * lisp/emacs-lisp/comp-run.el (bytecomp): Require it (bug#67590) diff --git a/lisp/emacs-lisp/comp-run.el b/lisp/emacs-lisp/comp-run.el index 5335003e25b..4b1d2451a4e 100644 --- a/lisp/emacs-lisp/comp-run.el +++ b/lisp/emacs-lisp/comp-run.el @@ -33,6 +33,7 @@ (eval-when-compile (require 'cl-lib)) (require 'comp-common) +(require 'bytecomp) ;; For `emacs-lisp-compilation-mode'. (defgroup comp-run nil "Emacs Lisp native compiler runtime." commit 9c1f24d7a497ee8b9c1ec3f1161a3ed7d6e34bd0 Author: Stefan Monnier Date: Sun Dec 3 14:22:48 2023 -0500 * lisp/emacs-lisp/macroexp.el (macroexp-parse-body): Fix bug#67568 This fixes a regression introduced in commit f616edb4ccce. diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 6eb670d6dc1..615a6622ce6 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -533,17 +533,18 @@ macroexpand--all-toplevel (defun macroexp-parse-body (body) "Parse a function BODY into (DECLARATIONS . EXPS)." (let ((decls ())) - ;; If there is only a string literal with nothing following, we - ;; consider this to be part of the body (the return value) rather - ;; than a declaration at this point. - (unless (and (null (cdr body)) (stringp (car body))) - (while - (and body - (let ((e (car body))) - (or (stringp e) - (memq (car-safe e) - '(:documentation declare interactive cl-declare))))) - (push (pop body) decls))) + (while + (and body + (let ((e (car body))) + (or (and (stringp e) + ;; If there is only a string literal with + ;; nothing following, we consider this to be + ;; part of the body (the return value) rather + ;; than a declaration at this point. + (cdr body)) + (memq (car-safe e) + '(:documentation declare interactive cl-declare))))) + (push (pop body) decls)) (cons (nreverse decls) body))) (defun macroexp-progn (exps) commit e33f560badac3fd6bd23a6ffc1244afee7dec5f3 Author: Spencer Baugh Date: Tue Oct 17 09:09:55 2023 -0400 Add historical option to completions-sort Support sorting candidates in *Completions* by the order they show up in the minibuffer history. Also add minibuffer-sort-alphabetically and minibuffer-sort-by-history, which are usable for both completions-sort and display-sort-function. * lisp/minibuffer.el (completions-sort): Document 'historical option. (minibuffer-completion-help): Support 'historical option. (minibuffer-sort-alphabetically) (minibuffer-completion-base, minibuffer-sort-by-history): Add. * etc/NEWS: Announce it. diff --git a/etc/NEWS b/etc/NEWS index 3d26f276604..29f4e5c0b66 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -637,6 +637,11 @@ new command 'minibuffer-choose-completion-or-exit' (bound by contents instead. The deselection behavior can be controlled with the new user option 'completion-auto-deselect'. +*** New value 'historical' for user option 'completions-sort' +When 'completions-sort' is set to 'historical', completion candidates +will be sorted by their chronological order in the minibuffer history, +with more recent candidates appearing first. + ** Pcomplete --- diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 382d4458e26..03b64198bcf 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -1314,14 +1314,27 @@ completion-cycle-threshold (defcustom completions-sort 'alphabetical "Sort candidates in the *Completions* buffer. -The value can be nil to disable sorting, `alphabetical' for -alphabetical sorting or a custom sorting function. The sorting -function takes and returns a list of completion candidate -strings." +Completion candidates in the *Completions* buffer are sorted +depending on the value. + +If it's nil, sorting is disabled. +If it's the symbol `alphabetical', candidates are sorted by +`minibuffer-sort-alphabetically'. +If it's the symbol `historical', candidates are sorted by +`minibuffer-sort-by-history'. +If it's a function, the function is called to sort the candidates. +The sorting function takes a list of completion candidate +strings, which it may modify; it should return a sorted list, +which may be the same. + +If the completion-specific metadata provides a +`display-sort-function', that function overrides the value of +this variable." :type '(choice (const :tag "No sorting" nil) (const :tag "Alphabetical sorting" alphabetical) + (const :tag "Historical sorting" historical) (function :tag "Custom function")) - :version "29.1") + :version "30.1") (defcustom completions-group nil "Enable grouping of completion candidates in the *Completions* buffer. @@ -1647,6 +1660,44 @@ minibuffer--sort-preprocess-history (substring c base-size))) hist))))) +(defun minibuffer-sort-alphabetically (completions) + "Sort COMPLETIONS alphabetically. + +COMPLETIONS are sorted alphabetically by `string-lessp'. + +This is a suitable function to use for `completions-sort' or to +include as `display-sort-function' in completion metadata." + (sort completions #'string-lessp)) + +(defvar minibuffer-completion-base nil + "The base for the current completion. + +This is the part of the current minibuffer input which comes +before the current completion field, as determined by +`completion-boundaries'. This is primarily relevant for file +names, where this is the directory component of the file name.") + +(defun minibuffer-sort-by-history (completions) + "Sort COMPLETIONS by their position in `minibuffer-history-variable'. + +COMPLETIONS are sorted first by `minibuffer-sort-alphbetically', +then any elements occuring in the minibuffer history list are +moved to the front based on the chronological order they occur in +the history. If a history variable hasn't been specified for +this call of `completing-read', COMPLETIONS are sorted only by +`minibuffer-sort-alphbetically'. + +This is a suitable function to use for `completions-sort' or to +include as `display-sort-function' in completion metadata." + (let ((alphabetized (sort completions #'string-lessp))) + ;; Only use history when it's specific to these completions. + (if (eq minibuffer-history-variable + (default-value minibuffer-history-variable)) + alphabetized + (minibuffer--sort-by-position + (minibuffer--sort-preprocess-history minibuffer-completion-base) + alphabetized)))) + (defun minibuffer--group-by (group-fun sort-fun elems) "Group ELEMS by GROUP-FUN and sort groups by SORT-FUN." (let ((groups)) @@ -2440,6 +2491,7 @@ minibuffer-completion-help (let* ((last (last completions)) (base-size (or (cdr last) 0)) (prefix (unless (zerop base-size) (substring string 0 base-size))) + (minibuffer-completion-base (substring string 0 base-size)) (base-prefix (buffer-substring (minibuffer--completion-prompt-end) (+ start base-size))) (base-suffix @@ -2506,7 +2558,8 @@ minibuffer-completion-help (funcall sort-fun completions) (pcase completions-sort ('nil completions) - ('alphabetical (sort completions #'string-lessp)) + ('alphabetical (minibuffer-sort-alphabetically completions)) + ('historical (minibuffer-sort-by-history completions)) (_ (funcall completions-sort completions))))) ;; After sorting, group the candidates using the commit 3c093148958d56e0ed8e12a8e00ced1ef052259a Author: Spencer Baugh Date: Thu Nov 23 13:37:29 2023 +0000 Deselect the selected completion candidate when typing minibuffer-choose-completion-or-exit submits the selected completion candidate, if any, ignoring the contents of the minibuffer. But a user might select a completion candidate and then want to type something else in the minibuffer and submit what they typed. Now typing will automatically deselect the selected completion candidate so that minibuffer-choose-completion-or-exit will not choose it. minibuffer-choose-completion has the same behavior as before, and is not affected by the deselection. * lisp/minibuffer.el (completion-auto-deselect, completions--deselect) (completions--after-change): Add. (minibuffer-completion-help): Add completions--after-change hook. (minibuffer-next-completion): Bind completion-auto-deselect to nil to avoid immediately deselecting the completion. (minibuffer-choose-completion-or-exit): Bind choose-completion-deselect-if-after so deselection takes effect. (display-completion-list): Guarantee a newline at the beginning of *Completions* to avoid ambiguity about candidate selection. * lisp/simple.el (choose-completion-deselect-if-after): Add. (choose-completion): Check choose-completion-deselect-if-after. * etc/NEWS: Announce. diff --git a/etc/NEWS b/etc/NEWS index da00ea9dbda..3d26f276604 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -628,6 +628,15 @@ completions window. When the completions window is not visible, then all these keys have their usual meaning in the minibuffer. This option is supported for in-buffer completion as well. +*** Selected completion candidates are deselected on typing. +When a user types, point in the *Completions* window will be moved off +any completion candidates. 'minibuffer-choose-completion' ('M-RET') +will still choose a previously-selected completion candidate, but the +new command 'minibuffer-choose-completion-or-exit' (bound by +'minibuffer-visible-completions') will exit with the minibuffer +contents instead. The deselection behavior can be controlled with the +new user option 'completion-auto-deselect'. + ** Pcomplete --- diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 5c12d9fc914..382d4458e26 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -2310,8 +2310,11 @@ display-completion-list (with-current-buffer standard-output (goto-char (point-max)) - (when completions-header-format - (insert (format completions-header-format (length completions)))) + (if completions-header-format + (insert (format completions-header-format (length completions))) + (unless completion-show-help + ;; Ensure beginning-of-buffer isn't a completion. + (insert (propertize "\n" 'face '(:height 0))))) (completion--insert-strings completions group-fun))) (run-hooks 'completion-setup-hook) @@ -2378,6 +2381,33 @@ completions--fit-window-to-buffer (resize-temp-buffer-window win)) (fit-window-to-buffer win completions-max-height))) +(defcustom completion-auto-deselect t + "If non-nil, deselect the selected completion candidate when you type. + +A non-nil value means that after typing, point in *Completions* +will be moved off any completion candidates. This means +`minibuffer-choose-completion-or-exit' will exit with the +minibuffer's current contents, instead of a completion candidate." + :type '(choice (const :tag "Candidates in *Completions* stay selected as you type" nil) + (const :tag "Typing deselects any completion candidate in *Completions*" t)) + :version "30.1") + +(defun completions--deselect () + "If point is in a completion candidate, move to just after the end of it. + +The candidate will still be chosen by `choose-completion' unless +`choose-completion-deselect-if-after' is non-nil." + (when (get-text-property (point) 'completion--string) + (goto-char (or (next-single-property-change (point) 'completion--string) + (point-max))))) + +(defun completions--after-change (_start _end _old-len) + "Update displayed *Completions* buffer after change in buffer contents." + (when completion-auto-deselect + (when-let (window (get-buffer-window "*Completions*" 0)) + (with-selected-window window + (completions--deselect))))) + (defun minibuffer-completion-help (&optional start end) "Display a list of possible completions of the current minibuffer contents." (interactive) @@ -2400,6 +2430,7 @@ minibuffer-completion-help ;; If there are no completions, or if the current input is already ;; the sole completion, then hide (previous&stale) completions. (minibuffer-hide-completions) + (remove-hook 'after-change-functions #'completions--after-change t) (if completions (completion--message "Sole completion") (unless completion-fail-discreetly @@ -2460,6 +2491,8 @@ minibuffer-completion-help (body-function . ,#'(lambda (_window) (with-current-buffer mainbuf + (when completion-auto-deselect + (add-hook 'after-change-functions #'completions--after-change t)) ;; Remove the base-size tail because `sort' requires a properly ;; nil-terminated list. (when last (setcdr last nil)) @@ -4673,7 +4706,8 @@ minibuffer-next-completion (next-line-completion (or n 1)) (next-completion (or n 1))) (when auto-choose - (let ((completion-use-base-affixes t)) + (let ((completion-use-base-affixes t) + (completion-auto-deselect nil)) (choose-completion nil t t)))))) (defun minibuffer-previous-completion (&optional n) @@ -4721,7 +4755,8 @@ minibuffer-choose-completion-or-exit contents." (interactive "P") (condition-case nil - (minibuffer-choose-completion no-exit no-quit) + (let ((choose-completion-deselect-if-after t)) + (minibuffer-choose-completion no-exit no-quit)) (error (minibuffer-complete-and-exit)))) (defun minibuffer-complete-history () diff --git a/lisp/simple.el b/lisp/simple.el index 652fc7ba540..e0b27658df6 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -10094,6 +10094,11 @@ next-line-completion (if pos (goto-char pos)))) (setq n (1+ n))))) +(defvar choose-completion-deselect-if-after nil + "If non-nil, don't choose a completion candidate if point is right after it. + +This makes `completions--deselect' effective.") + (defun choose-completion (&optional event no-exit no-quit) "Choose the completion at point. If EVENT, use EVENT's position to determine the starting position. @@ -10114,6 +10119,10 @@ choose-completion (insert-function completion-list-insert-choice-function) (completion-no-auto-exit (if no-exit t completion-no-auto-exit)) (choice + (if choose-completion-deselect-if-after + (if-let ((str (get-text-property (posn-point (event-start event)) 'completion--string))) + (substring-no-properties str) + (error "No completion here")) (save-excursion (goto-char (posn-point (event-start event))) (let (beg) @@ -10129,7 +10138,7 @@ choose-completion beg 'completion--string) beg)) (substring-no-properties - (get-text-property beg 'completion--string)))))) + (get-text-property beg 'completion--string))))))) (unless (buffer-live-p buffer) (error "Destination buffer is dead")) commit 33b6de7acec0536290939303855947c0c2af57d2 Author: Eli Zaretskii Date: Sun Dec 3 18:29:09 2023 +0200 Improve 'window-text-pixel-size' when buffer includes images * src/xdisp.c (window_text_pixel_size): Fix computation of Y when IGNORE_LINE_AT_END is non-nil and there's a 'display' property at TO. Improve movement to beginning of screen line at start. Fix computation of Y when lines are truncated and a line begins with a 'display' property at TO. (produce_image_glyph): Don't crop image glyph when word-wrap is in effect. (Bug#67533) diff --git a/src/xdisp.c b/src/xdisp.c index 0b2508cdf17..ca8583869df 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -11436,7 +11436,7 @@ window_text_pixel_size (Lisp_Object window, Lisp_Object from, Lisp_Object to, /* Start at the beginning of the line containing FROM. Otherwise IT.current_x will be incorrectly set to zero at some arbitrary non-zero X coordinate. */ - reseat_at_previous_visible_line_start (&it); + move_it_by_lines (&it, 0); it.current_x = it.hpos = 0; if (IT_CHARPOS (it) != start) { @@ -11513,6 +11513,8 @@ window_text_pixel_size (Lisp_Object window, Lisp_Object from, Lisp_Object to, the width of the last buffer position manually. */ if (IT_CHARPOS (it) > end) { + int end_y = it.current_y; + end--; RESTORE_IT (&it, &it2, it2data); x = move_it_to (&it, end, to_x, max_y, -1, move_op); @@ -11525,14 +11527,29 @@ window_text_pixel_size (Lisp_Object window, Lisp_Object from, Lisp_Object to, /* DTRT if ignore_line_at_end is t. */ if (!NILP (ignore_line_at_end)) - doff = (max (it.max_ascent, it.ascent) - + max (it.max_descent, it.descent)); + { + /* If END-1 is on the previous screen line, we need to + account for the vertical dimensions of previous line. */ + if (it.current_y < end_y) + doff = (max (it.max_ascent, it.ascent) + + max (it.max_descent, it.descent)); + } else { it.max_ascent = max (it.max_ascent, it.ascent); it.max_descent = max (it.max_descent, it.descent); } } + else if (IT_CHARPOS (it) > end + && it.line_wrap == TRUNCATE + && it.current_x - it.first_visible_x >= it.last_visible_x) + { + /* If the display property at END is at the beginning of the + line, and the previous line was truncated, we are at END, + but it.current_y is not yet updated to reflect that. */ + it.current_y += max (it.max_ascent, it.ascent) + + max (it.max_descent, it.descent); + } } else bidi_unshelve_cache (it2data, true); @@ -31343,9 +31360,13 @@ produce_image_glyph (struct it *it) take_vertical_position_into_account (it); - /* Automatically crop wide image glyphs at right edge so we can - draw the cursor on same display row. */ - if ((crop = it->pixel_width - (it->last_visible_x - it->current_x), crop > 0) + /* Automatically crop wide image glyphs at right edge so we can draw + the cursor on same display row. But don't do that under + word-wrap, unless the image starts at column zero, because + wrapping correctly needs the real pixel width of the image. */ + if ((it->line_wrap != WORD_WRAP || it->hpos == 0) + && (crop = it->pixel_width - (it->last_visible_x - it->current_x), + crop > 0) && (it->hpos == 0 || it->pixel_width > it->last_visible_x / 4)) { it->pixel_width -= crop; commit a42e0c6918e905e10dbfcf74b39426b8250f160d Author: Eric Abrahamsen Date: Sun Dec 3 07:16:32 2023 -0800 Fix to "Simplify gnus-group-search-forward" This updates commit 7304cc8a9ca8a7d19baaa24f0a72c7ad9a6a9716. diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index 9a1a6f9b27d..a9c38334933 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -1755,33 +1755,35 @@ gnus-group-search-forward (low gnus-level-killed) (beg (point)) pos found lev) - (unless first-too - (forward-line way)) - (while (and - (not (if backward (bobp) (eobp))) - (not (setq - found - (and - (get-text-property (point) 'gnus-group) - (or all - (and - (let ((unread - (get-text-property (point) 'gnus-unread))) - (and (numberp unread) (> unread 0))) - (setq lev (get-text-property (point) - 'gnus-level)) - (<= lev gnus-level-subscribed))) - (or (not level) - (and (setq lev (get-text-property (point) - 'gnus-level)) - (or (= lev level) - (and (< lev low) - (< level lev) - (progn - (setq low lev) - (setq pos (point)) - nil)))))))) - (zerop (forward-line way)))) + (if (and backward (progn (beginning-of-line) (bobp))) + nil + (unless first-too + (forward-line way)) + (while (and + (not (eobp)) + (not (setq + found + (and + (get-text-property (point) 'gnus-group) + (or all + (and + (let ((unread + (get-text-property (point) 'gnus-unread))) + (and (numberp unread) (> unread 0))) + (setq lev (get-text-property (point) + 'gnus-level)) + (<= lev gnus-level-subscribed))) + (or (not level) + (and (setq lev (get-text-property (point) + 'gnus-level)) + (or (= lev level) + (and (< lev low) + (< level lev) + (progn + (setq low lev) + (setq pos (point)) + nil)))))))) + (zerop (forward-line way))))) (if found (progn (gnus-group-position-point) t) (goto-char (or pos beg)) commit c03d3fbf41f97866db11c6454068fc299223d4ac Author: Vladimir Kazanov Date: Sun Nov 26 11:48:16 2023 +0000 Add ert-font-lock Add ert-font-lock as well as unit tests and testing resources. * lisp/emacs-lisp/ert-font-lock.el: New library. * test/lisp/emacs-lisp/ert-font-lock-resources/broken.js: * test/lisp/emacs-lisp/ert-font-lock-resources/correct.js: * test/lisp/emacs-lisp/ert-font-lock-tests.el: Unit tests. (Bug#67460) diff --git a/lisp/emacs-lisp/ert-font-lock.el b/lisp/emacs-lisp/ert-font-lock.el new file mode 100644 index 00000000000..6a02cf7acc4 --- /dev/null +++ b/lisp/emacs-lisp/ert-font-lock.el @@ -0,0 +1,364 @@ +;;; ert-font-lock.el --- ERT Font Lock -*- lexical-binding: t -*- + +;; Copyright (C) 2023 Free Software Foundation, Inc. + +;; Author: Vladimir Kazanov +;; Keywords: lisp, tools + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; ERT Font Lock is an extension to the Emacs Lisp Regression Test +;; library (ERT) providing a convenient way to check syntax +;; highlighting provided by font-lock. +;; +;; ert-font-lock entry points are functions +;; `ert-font-lock-test-string' and `ert-font-lock-test-file' and +;; covenience macros: `ert-font-lock-deftest' and +;; `ert-font-lock-deftest-file'. +;; +;; See unit tests in ert-font-lock-tests.el for usage examples. + +;;; Code: + +(require 'ert) +(require 'newcomment) +(require 'pcase) + +(defconst ert-font-lock--assertion-re + (rx + ;; column specifiers + (group (or "^" "<-")) + (one-or-more " ") + ;; optional negation of the face specification + (group (optional "!")) + ;; face symbol name + (group (one-or-more (or alphanumeric "-" "_" ".")))) + "An ert-font-lock assertion regex.") + +(defun ert-font-lock--validate-major-mode (mode) + "Validate if MODE is a valid major mode." + (unless (functionp mode) + (error "Invalid major mode: %S. Please specify a valid major mode for + syntax highlighting tests" mode))) + +(defun ert-font-lock--test-body-str (mode str test-name) + "Run assertions from STR. +Argument MODE - major mode to test. +Argument TEST-NAME - name of the currently running ert test." + (ert-font-lock--validate-major-mode mode) + (with-temp-buffer + (insert str) + (funcall mode) + (font-lock-ensure) + (let ((tests (ert-font-lock--parse-comments))) + (ert-font-lock--check-faces tests))) + test-name) + +(defun ert-font-lock--test-body-file (mode file test-name) + "Run assertions from FILE. +Argument MODE - major mode to test. +Argument TEST-NAME - name of the currently running ert test." + (ert-font-lock--validate-major-mode mode) + (ert-font-lock-test-file file mode) + test-name) + +(defun ert-font-lock--parse-macro-args (doc-keys-mode-arg) + "Parse DOC-KEYS-MODE-ARG macro argument list." + (let (doc doc-p mode arg) + + (when (stringp (car doc-keys-mode-arg)) + (setq doc (pop doc-keys-mode-arg) + doc-p t)) + + (pcase-let + ((`(,keys ,mode-arg) + (ert--parse-keys-and-body doc-keys-mode-arg))) + + (unless (symbolp (car mode-arg)) + (error "A major mode symbol expected: %S" (car mode-arg))) + (setq mode (pop mode-arg)) + + (unless (stringp (car mode-arg)) + (error "A string or file with assertions expected: %S" (car mode-arg))) + (setq arg (pop mode-arg)) + + (list doc doc-p keys mode arg)))) + +;;;###autoload +(defmacro ert-font-lock-deftest (name &rest docstring-keys-mode-and-str) + "Define test NAME (a symbol) using assertions from TEST-STR. + +Other than MAJOR-MODE and TEST-STR parameters, this macro accepts +the same parameters and keywords as `ert-deftest' and is intended +to be used through `ert'. + +\(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \ +[:tags \\='(TAG...)] MAJOR-MODE TEST-STR)" + (declare (debug (&define [&name "test@" symbolp] + sexp [&optional stringp] + [&rest keywordp sexp] + symbolp + stringp)) + (doc-string 3) + (indent 2)) + (pcase-let ((`(,documentation + ,documentation-supplied-p + ,keys ,mode ,arg) + (ert-font-lock--parse-macro-args docstring-keys-mode-and-str))) + + `(ert-set-test ',name + (make-ert-test + :name ',name + ,@(when documentation-supplied-p + `(:documentation ,documentation)) + ,@(when (map-contains-key keys :expected-result) + `(:expected-result-type ,(map-elt keys :expected-result))) + ,@(when (map-contains-key keys :tags) + `(:tags ,(map-elt keys :tags))) + :body (lambda () (ert-font-lock--test-body-str ',mode ,arg ',name)) + + :file-name ,(or (macroexp-file-name) buffer-file-name))))) + +;;;###autoload +(defmacro ert-font-lock-deftest-file (name &rest docstring-keys-mode-and-file) + "Define test NAME (a symbol) using assertions from FILE. + +FILE - path to a file with assertions in ERT resource director as +return by `ert-resource-directory'. + +Other than MAJOR-MODE and FILE parameters, this macro accepts the +same parameters and keywords as `ert-deftest' and is intended to +be used through `ert'. + +\(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \ +[:tags \\='(TAG...)] MAJOR-MODE FILE)" + (declare (debug (&define [&name "test@" symbolp] + sexp [&optional stringp] + [&rest keywordp sexp] + symbolp + stringp)) + (doc-string 3) + (indent 2)) + + (pcase-let ((`(,documentation + ,documentation-supplied-p + ,keys ,mode ,arg) + (ert-font-lock--parse-macro-args docstring-keys-mode-and-file))) + + `(ert-set-test ',name + (make-ert-test + :name ',name + ,@(when documentation-supplied-p + `(:documentation ,documentation)) + ,@(when (map-contains-key keys :expected-result) + `(:expected-result-type ,(map-elt keys :expected-result))) + ,@(when (map-contains-key keys :tags) + `(:tags ,(map-elt keys :tags))) + :body (lambda () (ert-font-lock--test-body-file + ',mode (ert-resource-file ,arg) ',name)) + :file-name ,(or (macroexp-file-name) buffer-file-name))))) + +(defun ert-font-lock--in-comment-p () + "Check if the current point is inside a comment." + (nth 4 (syntax-ppss))) + +(defun ert-font-lock--comment-start-p () + "Check if the current point starts a comment." + (or + ;; regexps use syntax tables so let's check that first + (looking-at "\\s<") + + ;; check newcomment.el facilities + (and comment-start (looking-at (regexp-quote comment-start))) + (and comment-start-skip (looking-at comment-start-skip)) + + ;; sometimes comment syntax is just hardcoded + (and (derived-mode-p '(c-mode c++-mode java-mode)) + (looking-at-p "//")))) + +(defun ert-font-lock--line-comment-p () + "Return t if the current line is a comment-only line." + (syntax-ppss) + (save-excursion + (beginning-of-line) + (skip-syntax-forward " ") + ;; skip empty lines + (unless (eolp) + (or + ;; multiline comments + (ert-font-lock--in-comment-p) + + ;; single line comments + (ert-font-lock--comment-start-p))))) + +(defun ert-font-lock--line-assertion-p () + "Return t if the current line contains an assertion." + (syntax-ppss) + (save-excursion + (beginning-of-line) + (skip-syntax-forward " ") + (re-search-forward ert-font-lock--assertion-re + (line-end-position) t 1))) + +(defun ert-font-lock--goto-first-char () + "Move the point to the first character." + (beginning-of-line) + (skip-syntax-forward " ")) + +(defun ert-font-lock--get-first-char-column () + "Get the position of the first non-empty char in the current line." + (save-excursion + (ert-font-lock--goto-first-char) + (- (point) (line-beginning-position)))) + +(defun ert-font-lock--parse-comments () + "Read test assertions from comments in the current buffer." + (let ((tests '()) + (curline 1) + (linetocheck -1)) + + (goto-char (point-min)) + + ;; Go through all lines, for comments check if there are + ;; assertions. For non-comment and comment/non-assert lines + ;; remember the last line seen. + (while (not (eobp)) + (catch 'nextline + + ;; Not a comment? remember the line, move to the next one + (unless (ert-font-lock--line-comment-p) + (setq linetocheck curline) + (throw 'nextline t)) + + ;; A comment. Not an assertion? remember the line to be + ;; checked, move to the next line + (unless (ert-font-lock--line-assertion-p) + (setq linetocheck curline) + (throw 'nextline t)) + + + ;; Collect the assertion + (when (re-search-forward ert-font-lock--assertion-re + (line-end-position) t 1) + + (unless (> linetocheck -1) + (user-error "Invalid test comment syntax at line %d. Expected a line to test before the comment line" curline)) + + ;; construct a test + (let* (;; either comment start char column (for arrows) or + ;; caret column + (column-checked (if (equal (match-string-no-properties 1) "^") + (- (match-beginning 1) (line-beginning-position)) + (ert-font-lock--get-first-char-column))) + ;; negate the face? + (negation (string-equal (match-string-no-properties 2) "!")) + ;; the face that is supposed to be in the position specified + (face (match-string-no-properties 3))) + + (push (list :line-checked linetocheck + :line-assert curline + :column-checked column-checked + :face face + :negation negation) + tests)))) + + ;; next line + (setq curline (1+ curline)) + (forward-line 1)) + + (reverse tests))) + +(defun ert-font-lock--point-at-line-and-column (line column) + "Get the buffer position for LINE and COLUMN." + (save-excursion + (goto-char (point-min)) + (forward-line (1- line)) + (move-to-column column) + (point))) + +(defun ert-font-lock--get-line (line-number) + "Return the content of the line specified by LINE-NUMBER." + (save-excursion + (goto-char (point-min)) + (forward-line (1- line-number)) + (buffer-substring-no-properties (line-beginning-position) (line-end-position)))) + +(defun ert-font-lock--check-faces (tests) + "Check if the current buffer is fontified correctly. +TESTS - tests to run. + +The function is meant to be run from within an ERT test." + (dolist (test tests) + (let* ((line-checked (plist-get test :line-checked)) + (line-assert (plist-get test :line-assert)) + (column-checked (plist-get test :column-checked)) + (expected-face (intern (plist-get test :face))) + (negation (plist-get test :negation)) + + (actual-face (get-text-property (ert-font-lock--point-at-line-and-column line-checked column-checked) 'face)) + (line-str (ert-font-lock--get-line line-checked)) + (line-assert-str (ert-font-lock--get-line line-assert))) + + (when (not (eq actual-face expected-face)) + (ert-fail + (list (format "Expected face %S, got %S on line %d column %d" + expected-face actual-face line-checked column-checked) + :line line-str + :assert line-assert-str))) + + (when (and negation (eq actual-face expected-face)) + (ert-fail + (list (format "Did not expect face %S face on line %d, column %d" + actual-face line-checked column-checked) + :line line-str + :assert line-assert-str)))))) + +;;;###autoload +(defun ert-font-lock-test-string (test-string mode) + "Check font faces in TEST-STRING set by MODE. + +The function is meant to be run from within an ERT test." + (ert-font-lock--validate-major-mode mode) + (with-temp-buffer + (insert test-string) + (funcall mode) + (font-lock-ensure) + + (ert-font-lock--check-faces (ert-font-lock--parse-comments))) + + (ert-pass)) + +;;;###autoload +(defun ert-font-lock-test-file (filename mode) + "Check font faces in FILENAME set by MODE. + +The function is meant to be run from within an ERT test." + (ert-font-lock--validate-major-mode mode) + (with-temp-buffer + (insert-file-contents filename) + (funcall mode) + (font-lock-ensure) + + (ert-font-lock--check-faces (ert-font-lock--parse-comments))) + + (ert-pass)) + + +(provide 'ert-font-lock) + +;;; ert-font-lock.el ends here diff --git a/test/lisp/emacs-lisp/ert-font-lock-resources/broken.js b/test/lisp/emacs-lisp/ert-font-lock-resources/broken.js new file mode 100644 index 00000000000..69c1c5cca88 --- /dev/null +++ b/test/lisp/emacs-lisp/ert-font-lock-resources/broken.js @@ -0,0 +1,3 @@ +var abc = function(d) { +// ^ wrong-face +}; diff --git a/test/lisp/emacs-lisp/ert-font-lock-resources/correct.js b/test/lisp/emacs-lisp/ert-font-lock-resources/correct.js new file mode 100644 index 00000000000..5e614c64755 --- /dev/null +++ b/test/lisp/emacs-lisp/ert-font-lock-resources/correct.js @@ -0,0 +1,3 @@ +var abc = function(d) { +// ^ font-lock-variable-name-face +}; diff --git a/test/lisp/emacs-lisp/ert-font-lock-tests.el b/test/lisp/emacs-lisp/ert-font-lock-tests.el new file mode 100644 index 00000000000..33ef0c6eede --- /dev/null +++ b/test/lisp/emacs-lisp/ert-font-lock-tests.el @@ -0,0 +1,464 @@ +;;; ert-font-lock-tests.el --- ERT Font Lock tests -*- lexical-binding: t -*- + +;; Copyright (C) 2023 Free Software Foundation, Inc. + +;; Author: Vladimir Kazanov + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This file is part of ERT Font Lock, an extension to the Emacs Lisp +;; Regression Test library (ERT) providing a convenient way to check +;; syntax highlighting provided by font-lock. +;; +;; See ert-font-lock.el for details, and below for example usage of +;; ert-font-lock facilities. + +(require 'ert) +(require 'ert-x) +(require 'ert-font-lock) + +;;; Helpers +;; + +(defmacro with-temp-buffer-str-mode (mode str &rest body) + "Create a buffer with STR contents and MODE. " + (declare (indent 1) (debug t)) + `(with-temp-buffer + (insert ,str) + (,mode) + (goto-char (point-min)) + ,@body)) + +;;; Comment parsing tests +;; + +(ert-deftest test-line-comment-p--fundamental () + (with-temp-buffer-str-mode fundamental-mode + "// comment\n" + (should-not (ert-font-lock--line-comment-p)))) + +(ert-deftest test-line-comment-p--emacs-lisp () + (with-temp-buffer-str-mode emacs-lisp-mode + "not comment +;; comment +" + (should-not (ert-font-lock--line-comment-p)) + (forward-line) + (should (ert-font-lock--line-comment-p)) + (forward-line) + (should-not (ert-font-lock--line-comment-p)))) + +(ert-deftest test-line-comment-p--shell-script () + (with-temp-buffer-str-mode shell-script-mode + "echo Not a comment +# comment +" + (should-not (ert-font-lock--line-comment-p)) + (forward-line) + (should (ert-font-lock--line-comment-p)))) + +(declare-function php-mode "php-mode") +(ert-deftest test-line-comment-p--php () + (skip-unless (featurep 'php-mode)) + + (with-temp-buffer-str-mode php-mode + "echo 'Not a comment' +// comment +/* comment */ +" + (should-not (ert-font-lock--line-comment-p)) + (forward-line) + (should (ert-font-lock--line-comment-p)) + (forward-line) + (should (ert-font-lock--line-comment-p)))) + + +(ert-deftest test-line-comment-p--javascript () + (with-temp-buffer-str-mode javascript-mode + "// comment + + // comment, after a blank line + +var abc = function(d) {}; +" + (should (ert-font-lock--line-comment-p)) + + (forward-line) + (should-not (ert-font-lock--line-comment-p)) + + (forward-line) + (should (ert-font-lock--line-comment-p)) + + (forward-line) + (should-not (ert-font-lock--line-comment-p)) + + (forward-line) + (should-not (ert-font-lock--line-comment-p)))) + +(ert-deftest test-line-comment-p--python () + + (with-temp-buffer-str-mode python-mode + "# comment + + # comment +print(\"Hello, world!\")" + (should (ert-font-lock--line-comment-p)) + + (forward-line) + (should-not (ert-font-lock--line-comment-p)) + + (forward-line) + (should (ert-font-lock--line-comment-p)) + + (forward-line) + (should-not (ert-font-lock--line-comment-p)))) + +(ert-deftest test-line-comment-p--c () + + (with-temp-buffer-str-mode c-mode + "// comment +/* also comment */" + (should (ert-font-lock--line-comment-p)) + + (forward-line) + (should (ert-font-lock--line-comment-p)))) + +(ert-deftest test-parse-comments--single-line-error () + (let* ((str "// ^ face.face1")) + (with-temp-buffer + (insert str) + (javascript-mode) + + (should-error (ert-font-lock--parse-comments))))) + +(ert-deftest test-parse-comments--single-line-single-caret () + (let* ((str " +first +// ^ face.face1 +") + asserts) + (with-temp-buffer + (insert str) + (javascript-mode) + + (setq asserts (ert-font-lock--parse-comments)) + (should (eql (length asserts) 1)) + (should (equal (car asserts) + '(:line-checked 2 :line-assert 3 :column-checked 3 :face "face.face1" :negation nil)))))) + +(ert-deftest test-parse-comments--caret-negation () + (let* ((str " +first +// ^ !face +// ^ face +") + asserts) + (with-temp-buffer + (insert str) + (javascript-mode) + + (setq asserts (ert-font-lock--parse-comments)) + (should (eql (length asserts) 2)) + (should (equal asserts + '((:line-checked 2 :line-assert 3 :column-checked 3 :face "face" :negation t) + (:line-checked 2 :line-assert 4 :column-checked 3 :face "face" :negation nil))))))) + + +(ert-deftest test-parse-comments--single-line-multiple-carets () + (let* ((str " +first +// ^ face1 +// ^ face.face2 +// ^ face-face.face3 + // ^ face_face.face4 +") + asserts) + + (with-temp-buffer + (insert str) + (javascript-mode) + + (setq asserts (ert-font-lock--parse-comments)) + (should (eql (length asserts) 4)) + (should (equal asserts + '((:line-checked 2 :line-assert 3 :column-checked 3 :face "face1" :negation nil) + (:line-checked 2 :line-assert 4 :column-checked 7 :face "face.face2" :negation nil) + (:line-checked 2 :line-assert 5 :column-checked 7 :face "face-face.face3" :negation nil) + (:line-checked 2 :line-assert 6 :column-checked 7 :face "face_face.face4" :negation nil))))))) + +(ert-deftest test-parse-comments--multiple-line-multiple-carets () + (let* ((str " +first +// ^ face1 +second +// ^ face2 +// ^ face3 +third +") + asserts) + (with-temp-buffer + (insert str) + (javascript-mode) + + (setq asserts (ert-font-lock--parse-comments)) + (should (eql (length asserts) 3)) + (should (equal asserts + '((:line-checked 2 :line-assert 3 :column-checked 3 :face "face1" :negation nil) + (:line-checked 4 :line-assert 5 :column-checked 3 :face "face2" :negation nil) + (:line-checked 4 :line-assert 6 :column-checked 5 :face "face3" :negation nil))))))) + + +(ert-deftest test-parse-comments--arrow-single-line-single () + (let* ((str " +first +// <- face1 +") + asserts) + (with-temp-buffer + (insert str) + (javascript-mode) + + (setq asserts (ert-font-lock--parse-comments)) + (should (eql (length asserts) 1)) + (should (equal (car asserts) + '(:line-checked 2 :line-assert 3 :column-checked 0 :face "face1" :negation nil)))))) + + +(ert-deftest test-parse-comments-arrow-multiple-line-single () + (let* ((str " +first +// <- face1 + // <- face2 + // <- face3 +") + asserts) + (with-temp-buffer + (insert str) + (javascript-mode) + + (setq asserts (ert-font-lock--parse-comments)) + (should (eql (length asserts) 3)) + (should (equal asserts + '((:line-checked 2 :line-assert 3 :column-checked 0 :face "face1" :negation nil) + (:line-checked 2 :line-assert 4 :column-checked 2 :face "face2" :negation nil) + (:line-checked 2 :line-assert 5 :column-checked 4 :face "face3" :negation nil))))))) + +(ert-deftest test-parse-comments--non-assert-comment-single () + (let* ((str " +// first +// ^ comment-face +") + asserts) + (with-temp-buffer + (insert str) + (javascript-mode) + + (setq asserts (ert-font-lock--parse-comments)) + (should (eql (length asserts) 1)) + (should (equal (car asserts) + '(:line-checked 2 :line-assert 3 :column-checked 4 :face "comment-face" :negation nil)))))) + +(ert-deftest test-parse-comments--non-assert-comment-multiple () + (let* ((str " +// first second third +// ^ comment-face +// ^ comment-face +// ^ comment-face +") + asserts) + (with-temp-buffer + (insert str) + (javascript-mode) + + (setq asserts (ert-font-lock--parse-comments)) + (should (eql (length asserts) 3)) + (should (equal asserts + '((:line-checked 2 :line-assert 3 :column-checked 4 :face "comment-face" :negation nil) + (:line-checked 2 :line-assert 4 :column-checked 10 :face "comment-face" :negation nil) + (:line-checked 2 :line-assert 5 :column-checked 18 :face "comment-face" :negation nil))))))) + + +(ert-deftest test-parse-comments--multiline-comment-single () + (let* ((str " +/* + this is a comment + ^ comment-face + */ +") + asserts) + (with-temp-buffer + (insert str) + (c-mode) + + (setq asserts (ert-font-lock--parse-comments)) + (should (eql (length asserts) 1)) + (should (equal (car asserts) + '(:line-checked 3 :line-assert 4 :column-checked 3 :face "comment-face" :negation nil)))))) + +(ert-deftest test-parse-comments--multiline-comment-multiple () + (let* ((str " +/* + this is a comment + ^ comment-face + another comment + ^ comment-face + */ +") + asserts) + (with-temp-buffer + (insert str) + (c-mode) + + (setq asserts (ert-font-lock--parse-comments)) + (should (eql (length asserts) 2)) + (should (equal asserts + '((:line-checked 3 :line-assert 4 :column-checked 3 :face "comment-face" :negation nil) + (:line-checked 5 :line-assert 6 :column-checked 4 :face "comment-face" :negation nil))))))) + +;;; Syntax highlighting assertion tests +;; + +(ert-deftest test-syntax-highlight-inline--caret-multiple-faces () + (let ((str " +var abc = function(d) { +// ^ font-lock-variable-name-face + // ^ font-lock-keyword-face + // ^ font-lock-variable-name-face +}; + +")) + (with-temp-buffer + (insert str) + (javascript-mode) + (font-lock-ensure) + + (ert-font-lock--check-faces + (ert-font-lock--parse-comments))))) + +(ert-deftest test-syntax-highlight-inline--caret-wrong-face () + (let* ((str " +var abc = function(d) { +// ^ not-a-face +}; +")) + (with-temp-buffer + (insert str) + (javascript-mode) + (font-lock-ensure) + + (should-error (ert-font-lock--check-faces + (ert-font-lock--parse-comments)))))) + + +(ert-deftest test-syntax-highlight-inline--comment-face () + (let* ((str " +// this is a comment +// ^ font-lock-comment-face +// ^ font-lock-comment-face +// ^ font-lock-comment-face +")) + (with-temp-buffer + (insert str) + (javascript-mode) + (font-lock-ensure) + + (ert-font-lock--check-faces + (ert-font-lock--parse-comments))))) + + +(ert-deftest test-syntax-highlight-inline--multiline-comment-face () + (let* ((str " +/* + this is a comment + ^ font-lock-comment-face + another comment + more comments + ^ font-lock-comment-face + */ +")) + (with-temp-buffer + (insert str) + (c-mode) + (font-lock-ensure) + + (ert-font-lock--check-faces + (ert-font-lock--parse-comments))))) + + +(ert-deftest test-font-lock-test-string--correct () + (ert-font-lock-test-string + " +var abc = function(d) { +// <- font-lock-keyword-face +// ^ font-lock-variable-name-face + // ^ font-lock-keyword-face + // ^ font-lock-variable-name-face +}; + +" + 'javascript-mode)) + +(ert-deftest test-font-lock-test-file--correct () + (ert-font-lock-test-file + (ert-resource-file "correct.js") + 'javascript-mode)) + +(ert-deftest test-font-lock-test-file--wrong () + :expected-result :failed + (ert-font-lock-test-file + (ert-resource-file "broken.js") + 'javascript-mode)) + +;;; Macro tests +;; + +(ert-font-lock-deftest test-macro-test--correct-highlighting + emacs-lisp-mode + " +(defun fun ()) +;; ^ font-lock-keyword-face +;; ^ font-lock-function-name-face") + +(ert-font-lock-deftest test-macro-test--docstring + "A test with a docstring." + emacs-lisp-mode + " +(defun fun ()) +;; ^ font-lock-keyword-face" + ) + +(ert-font-lock-deftest test-macro-test--failing + "A failing test." + :expected-result :failed + emacs-lisp-mode + " +(defun fun ()) +;; ^ wrong-face") + +(ert-font-lock-deftest-file test-macro-test--file + "Test reading correct assertions from a file" + javascript-mode + "correct.js") + +(ert-font-lock-deftest-file test-macro-test--file-failing + "Test reading wrong assertions from a file" + :expected-result :failed + javascript-mode + "broken.js") + +;;; ert-font-lock-tests.el ends here