config/doom
config/doom
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Fix cl warning and other issues in ace-jump-mode

Browse Source
This commit is contained in:
Wojciech Kozlowski 2022-04-10 19:34:40 +02:00
parent de96963e2a
commit 265ac8aa8a
2 changed files with 233 additions and 235 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

200
repos/ace-jump-mode/ace-jump-mode.el
View File

@ -1,11 +1,12 @@
;;; ace-jump-mode.el --- a quick cursor location minor mode for emacs -*- coding: utf-8-unix -*-
;;; ace-jump-mode.el --- A quick cursor location minor mode -*- coding: utf-8-unix; lexical-binding: t -*-
;; Copyright (C) 2012 Free Software Foundation, Inc.
;; Author : winterTTr <winterTTr@gmail.com>
;; URL : https://github.com/winterTTr/ace-jump-mode/
;; Version : 2.0.RC
;; Keywords : motion, location, cursor
;; Keywords : convenience, matching
;; Package-Requires: ((emacs "24.3"))
;; This file is part of GNU Emacs.
@ -92,76 +93,75 @@
;;; Code:
(require 'cl)
(require 'cl-lib)
(require 'server)
;;;; ============================================
;;;; Utilities for ace-jump-mode
;;;; ============================================
;; ---------------------
;; aj-position
;; ace-jump-position
;; ---------------------
;; make a position in a visual area
(defstruct aj-position offset visual-area)
(cl-defstruct ace-jump-position offset visual-area)
(defmacro aj-position-buffer (aj-pos)
"Get the buffer object from `aj-position'."
`(aj-visual-area-buffer (aj-position-visual-area ,aj-pos)))
(defmacro ace-jump-position-buffer (ace-jump-pos)
"Get the buffer object from `ace-jump-position'."
`(ace-jump-visual-area-buffer (ace-jump-position-visual-area ,ace-jump-pos)))
(defmacro aj-position-window (aj-pos)
"Get the window object from `aj-position'."
`(aj-visual-area-window (aj-position-visual-area ,aj-pos)))
(defmacro ace-jump-position-window (ace-jump-pos)
"Get the window object from `ace-jump-position'."
`(ace-jump-visual-area-window (ace-jump-position-visual-area ,ace-jump-pos)))
(defmacro aj-position-frame (aj-pos)
"Get the frame object from `aj-position'."
`(aj-visual-area-frame (aj-position-visual-area ,aj-pos)))
(defmacro ace-jump-position-frame (ace-jump-pos)
"Get the frame object from `ace-jump-position'."
`(ace-jump-visual-area-frame (ace-jump-position-visual-area ,ace-jump-pos)))
(defmacro aj-position-recover-buffer (aj-pos)
"Get the recover-buffer object from `aj-position'."
`(aj-visual-area-recover-buffer (aj-position-visual-area ,aj-pos)))
(defmacro ace-jump-position-recover-buffer (ace-jump-pos)
"Get the recover-buffer object from `ace-jump-position'."
`(ace-jump-visual-area-recover-buffer (ace-jump-position-visual-area ,ace-jump-pos)))
;; ---------------------
;; aj-visual-area
;; ace-jump-visual-area
;; ---------------------
;; a record for all the possible visual area
;; a visual area is a window that showing some buffer in some frame.
(defstruct aj-visual-area buffer window frame recover-buffer)
(cl-defstruct ace-jump-visual-area buffer window frame recover-buffer)
;; ---------------------
;; a FIFO queue implementation
;; ---------------------
(defstruct aj-queue head tail)
(cl-defstruct ace-jump-queue head tail)
(defun aj-queue-push (item q)
(defun ace-jump-queue-push (item q)
"enqueue"
(let ( (head (aj-queue-head q) )
(tail (aj-queue-tail q) )
(c (list item) ) )
(let ( (c (list item) ) )
(cond
((null (aj-queue-head q))
(setf (aj-queue-head q) c)
(setf (aj-queue-tail q) c))
((null (ace-jump-queue-head q))
(setf (ace-jump-queue-head q) c)
(setf (ace-jump-queue-tail q) c))
(t
(setf (cdr (aj-queue-tail q)) c)
(setf (aj-queue-tail q) c)))))
(setf (cdr (ace-jump-queue-tail q)) c)
(setf (ace-jump-queue-tail q) c)))))
(defun aj-queue-pop (q)
(defun ace-jump-queue-pop (q)
"dequeue"
(if (null (aj-queue-head q))
(if (null (ace-jump-queue-head q))
(error "[AceJump] Interal Error: Empty queue"))
(let ((ret (aj-queue-head q)))
(if (eq ret (aj-queue-tail q))
(let ((ret (ace-jump-queue-head q)))
(if (eq ret (ace-jump-queue-tail q))
;; only one item left
(progn
(setf (aj-queue-head q) nil)
(setf (aj-queue-tail q) nil))
(setf (ace-jump-queue-head q) nil)
(setf (ace-jump-queue-tail q) nil))
;; multi item left, move forward the head
(setf (aj-queue-head q) (cdr ret)))
(setf (ace-jump-queue-head q) (cdr ret)))
(car ret)))
@ -240,8 +240,8 @@ Currently, the valid submode is:
")
(defvar ace-jump-mode-move-keys
(nconc (loop for i from ?a to ?z collect i)
(loop for i from ?A to ?Z collect i))
(nconc (cl-loop for i from ?a to ?z collect i)
(cl-loop for i from ?A to ?Z collect i))
"*The keys that used to move when enter AceJump mode.
Each key should only an printable character, whose name will
fill each possible location.
@ -354,16 +354,16 @@ RE-QUERY-STRING should be an valid regex used for `search-forward-regexp'.
You can control whether use the case sensitive or not by `ace-jump-mode-case-fold'.
Every possible `match-beginning' will be collected.
The returned value is a list of `aj-position' record."
(loop for va in visual-area-list
append (let* ((current-window (aj-visual-area-window va))
The returned value is a list of `ace-jump-position' record."
(cl-loop for va in visual-area-list
append (let* ((current-window (ace-jump-visual-area-window va))
(start-point (window-start current-window))
(end-point (window-end current-window t)))
(with-selected-window current-window
(save-excursion
(goto-char start-point)
(let ((case-fold-search ace-jump-mode-case-fold))
(loop while (re-search-forward re-query-string nil t)
(cl-loop while (re-search-forward re-query-string nil t)
until (or
(> (point) end-point)
(eobp))
@ -371,7 +371,7 @@ The returned value is a list of `aj-position' record."
(or (null ace-jump-search-filter)
(ignore-errors
(funcall ace-jump-search-filter))))
collect (make-aj-position :offset (match-beginning 0)
collect (make-ace-jump-position :offset (match-beginning 0)
:visual-area va)
;; when we use "^" to search line mode,
;; re-search-backward will not move one
@ -387,14 +387,14 @@ The (car tree-node) is the type, which should be only 'branch or 'leaf.
The (cdr tree-node) is data stored in a leaf when type is 'leaf,
while a child node list when type is 'branch"
(let ((left-leaf-node (- total-leaf-node 1))
(q (make-aj-queue))
(q (make-ace-jump-queue))
(node nil)
(root (cons 'leaf nil)) )
;; we push the node into queue and make candidate-sum -1, so
;; create the start condition for the while loop
(aj-queue-push root q)
(ace-jump-queue-push root q)
(while (> left-leaf-node 0)
(setq node (aj-queue-pop q))
(setq node (ace-jump-queue-pop q))
;; when a node is picked up from stack, it will be changed to a
;; branch node, we lose a leaft node
(setf (car node) 'branch)
@ -404,7 +404,7 @@ while a child node list when type is 'branch"
;; current child can fill the left leaf
(progn
(setf (cdr node)
(loop for i from 1 to left-leaf-node
(cl-loop for i from 1 to left-leaf-node
collect (cons 'leaf nil)))
;; so this should be the last action for while
(setq left-leaf-node 0))
@ -413,9 +413,9 @@ while a child node list when type is 'branch"
;; fill as much as possible. Push them to queue, so it have
;; the oppotunity to become 'branch node if necessary
(setf (cdr node)
(loop for i from 1 to max-child-node
(cl-loop for i from 1 to max-child-node
collect (let ((n (cons 'leaf nil)))
(aj-queue-push n q)
(ace-jump-queue-push n q)
n)))
(setq left-leaf-node (- left-leaf-node max-child-node)))))
;; return the root node
@ -448,7 +448,7 @@ node and call LEAF-FUNC on each leaf node"
(defun ace-jump-populate-overlay-to-search-tree (tree candidate-list)
"Populate the overlay to search tree, every leaf will give one overlay"
(lexical-let* (;; create the locally dynamic variable for the following function
(let* (;; create the locally dynamic variable for the following function
(position-list candidate-list)
;; make the function to create overlay for each leaf node,
@ -457,9 +457,9 @@ node and call LEAF-FUNC on each leaf node"
;; which will be fill in "update-overlay" function
(func-create-overlay (lambda (node)
(let* ((p (car position-list))
(o (aj-position-offset p))
(w (aj-position-window p))
(b (aj-position-buffer p))
(o (ace-jump-position-offset p))
(w (ace-jump-position-window p))
(b (ace-jump-position-buffer p))
;; create one char overlay
(ol (make-overlay o (1+ o) b)))
;; update leaf node to remember the ol
@ -471,9 +471,9 @@ node and call LEAF-FUNC on each leaf node"
;; will show at the same time on both window
;; So we make it only on the specific window
(overlay-put ol 'window w)
;; associate the aj-position data with overlay
;; associate the ace-jump-position data with overlay
;; so that we can use it to do the final jump
(overlay-put ol 'aj-data p)
(overlay-put ol 'ace-jump-data p)
;; next candidate node
(setq position-list (cdr position-list))))))
(ace-jump-tree-preorder-traverse tree func-create-overlay)
@ -488,15 +488,15 @@ node and call LEAF-FUNC on each leaf node"
(ace-jump-tree-preorder-traverse tree func-delete-overlay)))
(defun ace-jump-buffer-substring (pos)
"Get the char under the POS, which is aj-position structure."
(let* ((w (aj-position-window pos))
(offset (aj-position-offset pos)))
"Get the char under the POS, which is ace-jump-position structure."
(let* ((w (ace-jump-position-window pos))
(offset (ace-jump-position-offset pos)))
(with-selected-window w
(buffer-substring offset (1+ offset)))))
(defun ace-jump-update-overlay-in-search-tree (tree keys)
"Update overlay 'display property using each name in keys"
(lexical-let* (;; create dynamic variable for following function
(let* (;; create dynamic variable for following function
(key ?\0)
;; populdate each leaf node to be the specific key,
;; this only update 'display' property of overlay,
@ -508,7 +508,7 @@ node and call LEAF-FUNC on each leaf node"
ol
'display
(concat (make-string 1 key)
(let* ((pos (overlay-get ol 'aj-data))
(let* ((pos (overlay-get ol 'ace-jump-data))
(subs (ace-jump-buffer-substring pos)))
(cond
;; when tab, we use more space to prevent screen
@ -523,7 +523,7 @@ node and call LEAF-FUNC on each leaf node"
;; there are wide-width characters
;; so, we need paddings
(make-string (max 0 (1- (string-width subs))) ? ))))))))))
(loop for k in keys
(cl-loop for k in keys
for n in (cdr tree)
do (progn
;; update "key" variable so that the function can use
@ -540,26 +540,26 @@ node and call LEAF-FUNC on each leaf node"
"Based on `ace-jump-mode-scope', search the possible buffers that is showing now."
(cond
((eq ace-jump-mode-scope 'global)
(loop for f in (frame-list)
append (loop for w in (window-list f)
collect (make-aj-visual-area :buffer (window-buffer w)
(cl-loop for f in (frame-list)
append (cl-loop for w in (window-list f)
collect (make-ace-jump-visual-area :buffer (window-buffer w)
:window w
:frame f))))
((eq ace-jump-mode-scope 'visible)
(loop for f in (frame-list)
(cl-loop for f in (frame-list)
if (eq t (frame-visible-p f))
append (loop for w in (window-list f)
collect (make-aj-visual-area :buffer (window-buffer w)
append (cl-loop for w in (window-list f)
collect (make-ace-jump-visual-area :buffer (window-buffer w)
:window w
:frame f))))
((eq ace-jump-mode-scope 'frame)
(loop for w in (window-list (selected-frame))
collect (make-aj-visual-area :buffer (window-buffer w)
(cl-loop for w in (window-list (selected-frame))
collect (make-ace-jump-visual-area :buffer (window-buffer w)
:window w
:frame (selected-frame))))
((eq ace-jump-mode-scope 'window)
(list
(make-aj-visual-area :buffer (current-buffer)
(make-ace-jump-visual-area :buffer (current-buffer)
:window (selected-window)
:frame (selected-frame))))
(t
@ -576,7 +576,7 @@ You can constrol whether use the case sensitive via `ace-jump-mode-case-fold'.
;; we check the move key to make it valid, cause it can be customized by user
(if (or (null ace-jump-mode-move-keys)
(< (length ace-jump-mode-move-keys) 2)
(not (every #'characterp ace-jump-mode-move-keys)))
(not (cl-every #'characterp ace-jump-mode-move-keys)))
(error "[AceJump] Invalid move keys: check ace-jump-mode-move-keys"))
;; search candidate position
(let* ((visual-area-list (ace-jump-list-visual-area))
@ -598,9 +598,9 @@ You can constrol whether use the case sensitive via `ace-jump-mode-case-fold'.
;; create background for each visual area
(if ace-jump-mode-gray-background
(setq ace-jump-background-overlay-list
(loop for va in visual-area-list
collect (let* ((w (aj-visual-area-window va))
(b (aj-visual-area-buffer va))
(cl-loop for va in visual-area-list
collect (let* ((w (ace-jump-visual-area-window va))
(b (ace-jump-visual-area-buffer va))
(ol (make-overlay (window-start w)
(window-end w)
b)))
@ -643,11 +643,11 @@ You can constrol whether use the case sensitive via `ace-jump-mode-case-fold'.
(defun ace-jump-jump-to (position)
"Jump to the POSITION, which is a `aj-position' structure storing the position information"
(let ((offset (aj-position-offset position))
(frame (aj-position-frame position))
(window (aj-position-window position))
(buffer (aj-position-buffer position))
"Jump to the POSITION, which is a `ace-jump-position' structure storing the position information"
(let ((offset (ace-jump-position-offset position))
(frame (ace-jump-position-frame position))
(window (ace-jump-position-window position))
(buffer (ace-jump-position-buffer position))
(line-mode-column 0))
;; save the column before do line jump, so that we can jump to the
@ -677,8 +677,7 @@ You can constrol whether use the case sensitive via `ace-jump-mode-case-fold'.
;; recover to the same column if we use the line jump mode
(if (eq ace-jump-current-mode 'ace-jump-line-mode)
(move-to-column line-mode-column))
))
(move-to-column line-mode-column))))
(defun ace-jump-push-mark ()
"Push the current position information onto the `ace-jump-mode-mark-ring'."
@ -686,8 +685,8 @@ You can constrol whether use the case sensitive via `ace-jump-mode-case-fold'.
(push-mark (point) t)
;; we also push the mark on the `ace-jump-mode-mark-ring', which has
;; more information for better jump back
(let ((pos (make-aj-position :offset (point)
:visual-area (make-aj-visual-area :buffer (current-buffer)
(let ((pos (make-ace-jump-position :offset (point)
:visual-area (make-ace-jump-visual-area :buffer (current-buffer)
:window (selected-window)
:frame (selected-frame)))))
(setq ace-jump-mode-mark-ring (cons pos ace-jump-mode-mark-ring)))
@ -702,7 +701,7 @@ You can constrol whether use the case sensitive via `ace-jump-mode-case-fold'.
(interactive)
;; we jump over the killed buffer position
(while (and ace-jump-mode-mark-ring
(not (buffer-live-p (aj-position-buffer
(not (buffer-live-p (ace-jump-position-buffer
(car ace-jump-mode-mark-ring)))))
(setq ace-jump-mode-mark-ring (cdr ace-jump-mode-mark-ring)))
@ -714,8 +713,8 @@ You can constrol whether use the case sensitive via `ace-jump-mode-case-fold'.
(let ((p (car ace-jump-mode-mark-ring)))
;; if we are jump back in the current buffer, that means we
;; only need to sync the buffer local mark-ring
(if (eq (current-buffer) (aj-position-buffer p))
(if (equal (aj-position-offset p) (marker-position (mark-marker)))
(if (eq (current-buffer) (ace-jump-position-buffer p))
(if (equal (ace-jump-position-offset p) (marker-position (mark-marker)))
;; if the current marker is the same as where we need
;; to jump back, we do the same as pop-mark actually,
;; copy implementation from pop-mark, cannot use it
@ -743,7 +742,7 @@ You can constrol whether use the case sensitive via `ace-jump-mode-case-fold'.
;; +---+---+---+ +---+---+---+
;;
;; So what we need to do, is put the found mark in mark-ring to the end
(lexical-let ((po (aj-position-offset p)))
(let ((po (ace-jump-position-offset p)))
(setq mark-ring
(ace-jump-move-first-to-end-if mark-ring
(lambda (x)
@ -753,7 +752,7 @@ You can constrol whether use the case sensitive via `ace-jump-mode-case-fold'.
;; when we jump back to another buffer, do as the
;; pop-global-mark does. But we move the marker with the
;; same target buffer to the end, not always the first one
(lexical-let ((pb (aj-position-buffer p)))
(let ((pb (ace-jump-position-buffer p)))
(setq global-mark-ring
(ace-jump-move-first-to-end-if global-mark-ring
(lambda (x)
@ -895,7 +894,7 @@ You can constrol whether use the case sensitive via
(defun ace-jump-move ()
"move cursor based on user input"
(interactive)
(let* ((index (let ((ret (position (aref (this-command-keys) 0)
(let* ((index (let ((ret (cl-position (aref (this-command-keys) 0)
ace-jump-mode-move-keys)))
(if ret ret (length ace-jump-mode-move-keys))))
(node (nth index (cdr ace-jump-search-tree))))
@ -923,10 +922,10 @@ You can constrol whether use the case sensitive via
;; if the node is leaf node, this is the final one
((eq (car node) 'leaf)
;; need to save aj data, as `ace-jump-done' will clean it
(let ((aj-data (overlay-get (cdr node) 'aj-data)))
(let ((ace-jump-data (overlay-get (cdr node) 'ace-jump-data)))
(ace-jump-push-mark)
(run-hooks 'ace-jump-mode-before-jump-hook)
(ace-jump-jump-to aj-data))
(ace-jump-jump-to ace-jump-data))
(ace-jump-done)
(run-hooks 'ace-jump-mode-end-hook))
(t
@ -947,7 +946,7 @@ You can constrol whether use the case sensitive via
(force-mode-line-update)
;; delete background overlay
(loop for ol in ace-jump-background-overlay-list
(cl-loop for ol in ace-jump-background-overlay-list
do (delete-overlay ol))
(setq ace-jump-background-overlay-list nil)
@ -981,7 +980,7 @@ PRED is a function object which can pass to funcall and accept
one argument, which will be every element in the list.
Such as : (lambda (x) (equal x 1)) "
(let (true-list false-list)
(loop for e in l
(cl-loop for e in l
do (if (funcall pred e)
(setq true-list (cons e true-list))
(setq false-list (cons e false-list))))
@ -990,7 +989,7 @@ Such as : (lambda (x) (equal x 1)) "
(defun ace-jump-move-first-to-end-if (l pred)
"Only move the first found one to the end of list"
(lexical-let ((pred pred)
(let ((pred pred)
found)
(ace-jump-move-to-end-if l
(lambda (x)
@ -1003,19 +1002,19 @@ Such as : (lambda (x) (equal x 1)) "
(defadvice pop-mark (before ace-jump-pop-mark-advice)
"When `pop-mark' is called to jump back, this advice will sync the mark ring.
Move the same position to the end of `ace-jump-mode-mark-ring'."
(lexical-let ((mp (mark t))
(let ((mp (mark t))
(cb (current-buffer)))
(if mp
(setq ace-jump-mode-mark-ring
(ace-jump-move-first-to-end-if ace-jump-mode-mark-ring
(lambda (x)
(and (equal (aj-position-offset x) mp)
(eq (aj-position-buffer x) cb))))))))
(and (equal (ace-jump-position-offset x) mp)
(eq (ace-jump-position-buffer x) cb))))))))
(defadvice pop-global-mark (before ace-jump-pop-global-mark-advice)
"When `pop-global-mark' is called to jump back, this advice will sync the mark ring.
Move the aj-position with the same buffer to the end of `ace-jump-mode-mark-ring'."
Move the ace-jump-position with the same buffer to the end of `ace-jump-mode-mark-ring'."
(interactive)
;; find the one that will be jump to
(let ((index global-mark-ring))
@ -1024,11 +1023,11 @@ Move the aj-position with the same buffer to the end of `ace-jump-mode-mark-ring
(setq index (cdr index)))
(if index
;; find the mark
(lexical-let ((mb (marker-buffer (car index))))
(let ((mb (marker-buffer (car index))))
(setq ace-jump-mode-mark-ring
(ace-jump-move-to-end-if ace-jump-mode-mark-ring
(lambda (x)
(eq (aj-position-buffer x) mb))))))))
(eq (ace-jump-position-buffer x) mb))))))))
(defun ace-jump-mode-enable-mark-sync ()
@ -1071,4 +1070,3 @@ will stop synchronizing mark information with emacs mark ring. "
;; Local Variables:
;; byte-compile-warnings: (not cl-functions)
;; End: