mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2025-01-04 11:40:22 +00:00
Missing files in last commit; remove stack-depth in byte-optimize-lapcode
This commit is contained in:
Stefan Monnier
parent
3e21b6a72b
commit
a647cb26b6
@ -186,8 +186,10 @@
|
||||
(eval-when-compile (require 'cl))
|
||||
|
||||
(defun byte-compile-log-lap-1 (format &rest args)
|
||||
;; (if (aref byte-code-vector 0)
|
||||
;; (error "The old version of the disassembler is loaded. Reload new-bytecomp as well"))
|
||||
;; Newer byte codes for stack-ref make the slot 0 non-nil again.
|
||||
;; But the "old disassembler" is *really* ancient by now.
|
||||
;; (if (aref byte-code-vector 0)
|
||||
;; (error "The old version of the disassembler is loaded. Reload new-bytecomp as well"))
|
||||
(byte-compile-log-1
|
||||
(apply 'format format
|
||||
(let (c a)
|
||||
@ -1512,50 +1514,12 @@
|
||||
;; The variable `byte-boolean-vars' is now primitive and updated
|
||||
;; automatically by DEFVAR_BOOL.
|
||||
|
||||
(defmacro byte-opt-update-stack-params (stack-adjust stack-depth lap0 rest lap)
|
||||
"...macro used by byte-optimize-lapcode..."
|
||||
`(progn
|
||||
(byte-compile-log-lap "Before %s [depth = %s]" ,lap0 ,stack-depth)
|
||||
(cond ((eq (car ,lap0) 'TAG)
|
||||
;; A tag can encode the expected stack depth.
|
||||
(when (cddr ,lap0)
|
||||
;; First, check to see if our notion of the current stack
|
||||
;; depth agrees with this tag. We don't check at the
|
||||
;; beginning of the function, because the presence of
|
||||
;; lexical arguments means the first tag will have a
|
||||
;; non-zero offset.
|
||||
(when (and (not (eq ,rest ,lap)) ; not at first insn
|
||||
,stack-depth ; not just after a goto
|
||||
(not (= (cddr ,lap0) ,stack-depth)))
|
||||
(error "Compiler error: optimizer is confused about %s:
|
||||
%s != %s at lapcode %s" ',stack-depth (cddr ,lap0) ,stack-depth ,lap0))
|
||||
;; Now set out current depth from this tag
|
||||
(setq ,stack-depth (cddr ,lap0)))
|
||||
(setq ,stack-adjust 0))
|
||||
((memq (car ,lap0) '(byte-goto byte-return))
|
||||
;; These insns leave us in an unknown state
|
||||
(setq ,stack-adjust nil))
|
||||
((car ,lap0)
|
||||
;; Not a no-op, set ,stack-adjust for lap0. ,stack-adjust will
|
||||
;; be added to ,stack-depth at the end of the loop, so any code
|
||||
;; that modifies the instruction sequence must adjust this too.
|
||||
(setq ,stack-adjust
|
||||
(byte-compile-stack-adjustment (car ,lap0) (cdr ,lap0)))))
|
||||
(byte-compile-log-lap "Before %s [depth => %s, adj = %s]" ,lap0 ,stack-depth ,stack-adjust)
|
||||
))
|
||||
|
||||
(defun byte-optimize-lapcode (lap &optional for-effect)
|
||||
"Simple peephole optimizer. LAP is both modified and returned.
|
||||
If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
|
||||
(let (lap0
|
||||
lap1
|
||||
lap2
|
||||
stack-adjust
|
||||
stack-depth
|
||||
(initial-stack-depth
|
||||
(if (and lap (eq (car (car lap)) 'TAG))
|
||||
(cdr (cdr (car lap)))
|
||||
0))
|
||||
(keep-going 'first-time)
|
||||
(add-depth 0)
|
||||
rest tmp tmp2 tmp3
|
||||
@ -1566,15 +1530,12 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
|
||||
(or (eq keep-going 'first-time)
|
||||
(byte-compile-log-lap " ---- next pass"))
|
||||
(setq rest lap
|
||||
stack-depth initial-stack-depth
|
||||
keep-going nil)
|
||||
(while rest
|
||||
(setq lap0 (car rest)
|
||||
lap1 (nth 1 rest)
|
||||
lap2 (nth 2 rest))
|
||||
|
||||
(byte-opt-update-stack-params stack-adjust stack-depth lap0 rest lap)
|
||||
|
||||
;; You may notice that sequences like "dup varset discard" are
|
||||
;; optimized but sequences like "dup varset TAG1: discard" are not.
|
||||
;; You may be tempted to change this; resist that temptation.
|
||||
@ -1588,22 +1549,22 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
|
||||
((and (eq 'byte-discard (car lap1))
|
||||
(memq (car lap0) side-effect-free))
|
||||
(setq keep-going t)
|
||||
(setq tmp (aref byte-stack+-info (symbol-value (car lap0))))
|
||||
(setq rest (cdr rest))
|
||||
(cond ((= stack-adjust 1)
|
||||
(cond ((= tmp 1)
|
||||
(byte-compile-log-lap
|
||||
" %s discard\t-->\t<deleted>" lap0)
|
||||
(setq lap (delq lap0 (delq lap1 lap))))
|
||||
((= stack-adjust 0)
|
||||
((= tmp 0)
|
||||
(byte-compile-log-lap
|
||||
" %s discard\t-->\t<deleted> discard" lap0)
|
||||
(setq lap (delq lap0 lap)))
|
||||
((= stack-adjust -1)
|
||||
((= tmp -1)
|
||||
(byte-compile-log-lap
|
||||
" %s discard\t-->\tdiscard discard" lap0)
|
||||
(setcar lap0 'byte-discard)
|
||||
(setcdr lap0 0))
|
||||
((error "Optimizer error: too much on the stack")))
|
||||
(setq stack-adjust (1- stack-adjust)))
|
||||
((error "Optimizer error: too much on the stack"))))
|
||||
;;
|
||||
;; goto*-X X: --> X:
|
||||
;;
|
||||
@ -1673,8 +1634,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
|
||||
byte-stack-set)))
|
||||
(byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1)
|
||||
(setq keep-going t
|
||||
rest (cdr rest)
|
||||
stack-adjust -1)
|
||||
rest (cdr rest))
|
||||
(if (eq 'byte-stack-set (car lap1)) (decf (cdr lap1)))
|
||||
(setq lap (delq lap0 (delq lap2 lap))))
|
||||
;;
|
||||
@ -1697,8 +1657,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
|
||||
'byte-goto-if-not-nil
|
||||
'byte-goto-if-nil))
|
||||
(setq lap (delq lap0 lap))
|
||||
(setq keep-going t
|
||||
stack-adjust 0))
|
||||
(setq keep-going t))
|
||||
;;
|
||||
;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X:
|
||||
;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X:
|
||||
@ -1714,8 +1673,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
|
||||
(byte-compile-log-lap " %s %s %s:\t-->\t%s %s:"
|
||||
lap0 lap1 lap2
|
||||
(cons inverse (cdr lap1)) lap2)
|
||||
(setq lap (delq lap0 lap)
|
||||
stack-adjust 0)
|
||||
(setq lap (delq lap0 lap))
|
||||
(setcar lap1 inverse)
|
||||
(setq keep-going t)))
|
||||
;;
|
||||
@ -1738,8 +1696,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
|
||||
(when (memq (car lap1) byte-goto-always-pop-ops)
|
||||
(setq lap (delq lap0 lap)))
|
||||
(setcar lap1 'byte-goto)))
|
||||
(setq keep-going t
|
||||
stack-adjust 0))
|
||||
(setq keep-going t))
|
||||
;;
|
||||
;; varref-X varref-X --> varref-X dup
|
||||
;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup
|
||||
@ -1772,8 +1729,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
|
||||
(setq keep-going t)
|
||||
(setcar (car tmp) 'byte-dup)
|
||||
(setcdr (car tmp) 0)
|
||||
(setq rest tmp
|
||||
stack-adjust (+ 2 tmp2)))
|
||||
(setq rest tmp))
|
||||
;;
|
||||
;; TAG1: TAG2: --> TAG1: <deleted>
|
||||
;; (and other references to TAG2 are replaced with TAG1)
|
||||
@ -1840,8 +1796,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
|
||||
(byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0)
|
||||
(setcar rest lap1)
|
||||
(setcar (cdr rest) lap0)
|
||||
(setq keep-going t
|
||||
stack-adjust 0))
|
||||
(setq keep-going t))
|
||||
;;
|
||||
;; varbind-X unbind-N --> discard unbind-(N-1)
|
||||
;; save-excursion unbind-N --> unbind-(N-1)
|
||||
@ -1943,8 +1898,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
|
||||
(cdr tmp))))
|
||||
(setcdr lap1 (car (cdr tmp)))
|
||||
(setq lap (delq lap0 lap))))
|
||||
(setq keep-going t
|
||||
stack-adjust 0))
|
||||
(setq keep-going t))
|
||||
;;
|
||||
;; X: varref-Y ... varset-Y goto-X -->
|
||||
;; X: varref-Y Z: ... dup varset-Y goto-Z
|
||||
@ -1960,12 +1914,9 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
|
||||
(eq (car lap2) 'byte-goto)
|
||||
(not (memq (cdr lap2) rest)) ;Backwards jump
|
||||
(eq (car (car (setq tmp (cdr (memq (cdr lap2) lap)))))
|
||||
(if (eq (car lap1) 'byte-varset) 'byte-varref
|
||||
;; 'byte-stack-ref
|
||||
))
|
||||
'byte-varref)
|
||||
(eq (cdr (car tmp)) (cdr lap1))
|
||||
(not (and (eq (car lap1) 'byte-varref)
|
||||
(memq (car (cdr lap1)) byte-boolean-vars))))
|
||||
(not (memq (car (cdr lap1)) byte-boolean-vars)))
|
||||
;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp))
|
||||
(let ((newtag (byte-compile-make-tag)))
|
||||
(byte-compile-log-lap
|
||||
@ -2022,15 +1973,10 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
|
||||
byte-goto-if-not-nil
|
||||
byte-goto byte-goto))))
|
||||
)
|
||||
(setq keep-going t
|
||||
stack-adjust (and (not (eq (car lap0) 'byte-goto)) -1)))
|
||||
(setq keep-going t))
|
||||
)
|
||||
|
||||
(setq stack-depth
|
||||
(and stack-depth stack-adjust (+ stack-depth stack-adjust)))
|
||||
(setq rest (cdr rest)))
|
||||
)
|
||||
|
||||
;; Cleanup stage:
|
||||
;; Rebuild byte-compile-constants / byte-compile-variables.
|
||||
;; Simple optimizations that would inhibit other optimizations if they
|
||||
@ -2038,13 +1984,11 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
|
||||
;; need to do more than once.
|
||||
(setq byte-compile-constants nil
|
||||
byte-compile-variables nil)
|
||||
(setq rest lap
|
||||
stack-depth initial-stack-depth)
|
||||
(setq rest lap)
|
||||
(byte-compile-log-lap " ---- final pass")
|
||||
(while rest
|
||||
(setq lap0 (car rest)
|
||||
lap1 (nth 1 rest))
|
||||
(byte-opt-update-stack-params stack-adjust stack-depth lap0 rest lap)
|
||||
(if (memq (car lap0) byte-constref-ops)
|
||||
(if (or (eq (car lap0) 'byte-constant)
|
||||
(eq (car lap0) 'byte-constant2))
|
||||
@ -2127,7 +2071,6 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
|
||||
'byte-discardN))
|
||||
(setcdr lap1 (1+ tmp3))
|
||||
(setcdr (cdr rest) tmp)
|
||||
(setq stack-adjust 0)
|
||||
(byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s"
|
||||
lap0 lap1))
|
||||
|
||||
@ -2148,8 +2091,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
|
||||
(if (eq (car lap1) 'byte-discard) 1 (cdr lap1))))
|
||||
(setcdr lap1 (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0))
|
||||
(if (eq (car lap1) 'byte-discard) 1 (cdr lap1))))
|
||||
(setcar lap1 'byte-discardN)
|
||||
(setq stack-adjust 0))
|
||||
(setcar lap1 'byte-discardN))
|
||||
|
||||
;;
|
||||
;; discardN-preserve-tos-X discardN-preserve-tos-Y -->
|
||||
@ -2159,7 +2101,6 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
|
||||
(eq (car lap1) 'byte-discardN-preserve-tos))
|
||||
(setq lap (delq lap0 lap))
|
||||
(setcdr lap1 (+ (cdr lap0) (cdr lap1)))
|
||||
(setq stack-adjust 0)
|
||||
(byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (car rest)))
|
||||
|
||||
;;
|
||||
@ -2174,14 +2115,9 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
|
||||
;; The byte-code interpreter will pop the stack for us, so
|
||||
;; we can just leave stuff on it.
|
||||
(setq lap (delq lap0 lap))
|
||||
(setq stack-adjust 0)
|
||||
(byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1))
|
||||
)
|
||||
|
||||
(setq stack-depth
|
||||
(and stack-depth stack-adjust (+ stack-depth stack-adjust)))
|
||||
(setq rest (cdr rest)))
|
||||
|
||||
(setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth)))
|
||||
lap)
|
||||
|
||||
|
||||
@ -771,10 +771,11 @@ This also does some trivial optimizations to make the form prettier."
|
||||
(sublis sub (nreverse decls))
|
||||
(list
|
||||
(list* 'list '(quote apply)
|
||||
(list 'function
|
||||
(list* 'lambda
|
||||
(append new (cadadr form))
|
||||
(sublis sub body)))
|
||||
(list 'quote
|
||||
(list 'function
|
||||
(list* 'lambda
|
||||
(append new (cadadr form))
|
||||
(sublis sub body))))
|
||||
(nconc (mapcar (function
|
||||
(lambda (x)
|
||||
(list 'list '(quote quote) x)))
|
||||
|
||||
@ -10,7 +10,7 @@
|
||||
;;;;;; ceiling* floor* isqrt lcm gcd cl-progv-before cl-set-frame-visible-p
|
||||
;;;;;; cl-map-overlays cl-map-intervals cl-map-keymap-recursively
|
||||
;;;;;; notevery notany every some mapcon mapcan mapl maplist map
|
||||
;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "60f6b85256416c5f2a0a3954a11523b6")
|
||||
;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "2bfbae6523c842d511b8c8d88658825a")
|
||||
;;; Generated autoloads from cl-extra.el
|
||||
|
||||
(autoload 'coerce "cl-extra" "\
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
;;; minibuffer.el --- Minibuffer completion functions
|
||||
;;; minibuffer.el --- Minibuffer completion functions -*- lexical-binding: t -*-
|
||||
|
||||
;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
|
||||
|
||||
@ -133,8 +133,8 @@ the closest directory separators."
|
||||
"Apply FUN to each element of XS in turn.
|
||||
Return the first non-nil returned value.
|
||||
Like CL's `some'."
|
||||
(lexical-let ((firsterror nil)
|
||||
res)
|
||||
(let ((firsterror nil)
|
||||
res)
|
||||
(while (and (not res) xs)
|
||||
(condition-case err
|
||||
(setq res (funcall fun (pop xs)))
|
||||
@ -171,12 +171,11 @@ FUN will be called in the buffer from which the minibuffer was entered.
|
||||
The result of the `completion-table-dynamic' form is a function
|
||||
that can be used as the COLLECTION argument to `try-completion' and
|
||||
`all-completions'. See Info node `(elisp)Programmed Completion'."
|
||||
(lexical-let ((fun fun))
|
||||
(lambda (string pred action)
|
||||
(with-current-buffer (let ((win (minibuffer-selected-window)))
|
||||
(if (window-live-p win) (window-buffer win)
|
||||
(current-buffer)))
|
||||
(complete-with-action action (funcall fun string) string pred)))))
|
||||
(lambda (string pred action)
|
||||
(with-current-buffer (let ((win (minibuffer-selected-window)))
|
||||
(if (window-live-p win) (window-buffer win)
|
||||
(current-buffer)))
|
||||
(complete-with-action action (funcall fun string) string pred))))
|
||||
|
||||
(defmacro lazy-completion-table (var fun)
|
||||
"Initialize variable VAR as a lazy completion table.
|
||||
@ -201,19 +200,18 @@ You should give VAR a non-nil `risky-local-variable' property."
|
||||
;; Notice that `pred' may not be a function in some abusive cases.
|
||||
(when (functionp pred)
|
||||
(setq pred
|
||||
(lexical-let ((pred pred))
|
||||
;; Predicates are called differently depending on the nature of
|
||||
;; the completion table :-(
|
||||
(cond
|
||||
((vectorp table) ;Obarray.
|
||||
(lambda (sym) (funcall pred (concat prefix (symbol-name sym)))))
|
||||
((hash-table-p table)
|
||||
(lambda (s v) (funcall pred (concat prefix s))))
|
||||
((functionp table)
|
||||
(lambda (s) (funcall pred (concat prefix s))))
|
||||
(t ;Lists and alists.
|
||||
(lambda (s)
|
||||
(funcall pred (concat prefix (if (consp s) (car s) s)))))))))
|
||||
;; Predicates are called differently depending on the nature of
|
||||
;; the completion table :-(
|
||||
(cond
|
||||
((vectorp table) ;Obarray.
|
||||
(lambda (sym) (funcall pred (concat prefix (symbol-name sym)))))
|
||||
((hash-table-p table)
|
||||
(lambda (s v) (funcall pred (concat prefix s))))
|
||||
((functionp table)
|
||||
(lambda (s) (funcall pred (concat prefix s))))
|
||||
(t ;Lists and alists.
|
||||
(lambda (s)
|
||||
(funcall pred (concat prefix (if (consp s) (car s) s))))))))
|
||||
(if (eq (car-safe action) 'boundaries)
|
||||
(let* ((len (length prefix))
|
||||
(bound (completion-boundaries string table pred (cdr action))))
|
||||
@ -288,11 +286,10 @@ Note: TABLE needs to be a proper completion table which obeys predicates."
|
||||
(t
|
||||
(or (complete-with-action action table string
|
||||
(if (null pred2) pred1
|
||||
(lexical-let ((pred1 pred2) (pred2 pred2))
|
||||
(lambda (x)
|
||||
;; Call `pred1' first, so that `pred2'
|
||||
;; really can't tell that `x' is in table.
|
||||
(if (funcall pred1 x) (funcall pred2 x))))))
|
||||
(lambda (x)
|
||||
;; Call `pred1' first, so that `pred2'
|
||||
;; really can't tell that `x' is in table.
|
||||
(if (funcall pred1 x) (funcall pred2 x)))))
|
||||
;; If completion failed and we're not applying pred1 strictly, try
|
||||
;; again without pred1.
|
||||
(and (not strict)
|
||||
@ -302,11 +299,10 @@ Note: TABLE needs to be a proper completion table which obeys predicates."
|
||||
"Create a completion table that tries each table in TABLES in turn."
|
||||
;; FIXME: the boundaries may come from TABLE1 even when the completion list
|
||||
;; is returned by TABLE2 (because TABLE1 returned an empty list).
|
||||
(lexical-let ((tables tables))
|
||||
(lambda (string pred action)
|
||||
(completion--some (lambda (table)
|
||||
(complete-with-action action table string pred))
|
||||
tables))))
|
||||
(lambda (string pred action)
|
||||
(completion--some (lambda (table)
|
||||
(complete-with-action action table string pred))
|
||||
tables)))
|
||||
|
||||
;; (defmacro complete-in-turn (a b) `(completion-table-in-turn ,a ,b))
|
||||
;; (defmacro dynamic-completion-table (fun) `(completion-table-dynamic ,fun))
|
||||
@ -548,16 +544,15 @@ E = after completion we now have an Exact match.
|
||||
101 5 ??? impossible
|
||||
110 6 some completion happened
|
||||
111 7 completed to an exact completion"
|
||||
(lexical-let*
|
||||
((beg (field-beginning))
|
||||
(end (field-end))
|
||||
(string (buffer-substring beg end))
|
||||
(comp (funcall (or try-completion-function
|
||||
'completion-try-completion)
|
||||
string
|
||||
minibuffer-completion-table
|
||||
minibuffer-completion-predicate
|
||||
(- (point) beg))))
|
||||
(let* ((beg (field-beginning))
|
||||
(end (field-end))
|
||||
(string (buffer-substring beg end))
|
||||
(comp (funcall (or try-completion-function
|
||||
'completion-try-completion)
|
||||
string
|
||||
minibuffer-completion-table
|
||||
minibuffer-completion-predicate
|
||||
(- (point) beg))))
|
||||
(cond
|
||||
((null comp)
|
||||
(minibuffer-hide-completions)
|
||||
@ -572,13 +567,12 @@ E = after completion we now have an Exact match.
|
||||
;; `completed' should be t if some completion was done, which doesn't
|
||||
;; include simply changing the case of the entered string. However,
|
||||
;; for appearance, the string is rewritten if the case changes.
|
||||
(lexical-let*
|
||||
((comp-pos (cdr comp))
|
||||
(completion (car comp))
|
||||
(completed (not (eq t (compare-strings completion nil nil
|
||||
string nil nil t))))
|
||||
(unchanged (eq t (compare-strings completion nil nil
|
||||
string nil nil nil))))
|
||||
(let* ((comp-pos (cdr comp))
|
||||
(completion (car comp))
|
||||
(completed (not (eq t (compare-strings completion nil nil
|
||||
string nil nil t))))
|
||||
(unchanged (eq t (compare-strings completion nil nil
|
||||
string nil nil nil))))
|
||||
(if unchanged
|
||||
(goto-char end)
|
||||
;; Insert in minibuffer the chars we got.
|
||||
@ -759,8 +753,8 @@ If `minibuffer-completion-confirm' is `confirm-after-completion',
|
||||
`minibuffer-confirm-exit-commands', and accept the input
|
||||
otherwise."
|
||||
(interactive)
|
||||
(lexical-let ((beg (field-beginning))
|
||||
(end (field-end)))
|
||||
(let ((beg (field-beginning))
|
||||
(end (field-end)))
|
||||
(cond
|
||||
;; Allow user to specify null string
|
||||
((= beg end) (exit-minibuffer))
|
||||
@ -1137,14 +1131,14 @@ variables.")
|
||||
"Display a list of possible completions of the current minibuffer contents."
|
||||
(interactive)
|
||||
(message "Making completion list...")
|
||||
(lexical-let* ((start (field-beginning))
|
||||
(end (field-end))
|
||||
(string (field-string))
|
||||
(completions (completion-all-completions
|
||||
string
|
||||
minibuffer-completion-table
|
||||
minibuffer-completion-predicate
|
||||
(- (point) (field-beginning)))))
|
||||
(let* ((start (field-beginning))
|
||||
(end (field-end))
|
||||
(string (field-string))
|
||||
(completions (completion-all-completions
|
||||
string
|
||||
minibuffer-completion-table
|
||||
minibuffer-completion-predicate
|
||||
(- (point) (field-beginning)))))
|
||||
(message nil)
|
||||
(if (and completions
|
||||
(or (consp (cdr completions))
|
||||
@ -1619,8 +1613,8 @@ and `read-file-name-function'."
|
||||
;; just use `default-directory', but in order to avoid
|
||||
;; changing `default-directory' in the current buffer,
|
||||
;; we don't let-bind it.
|
||||
(lexical-let ((dir (file-name-as-directory
|
||||
(expand-file-name dir))))
|
||||
(let ((dir (file-name-as-directory
|
||||
(expand-file-name dir))))
|
||||
(minibuffer-with-setup-hook
|
||||
(lambda ()
|
||||
(setq default-directory dir)
|
||||
@ -1719,7 +1713,7 @@ and `read-file-name-function'."
|
||||
"Perform completion on all buffers excluding BUFFER.
|
||||
BUFFER nil or omitted means use the current buffer.
|
||||
Like `internal-complete-buffer', but removes BUFFER from the completion list."
|
||||
(lexical-let ((except (if (stringp buffer) buffer (buffer-name buffer))))
|
||||
(let ((except (if (stringp buffer) buffer (buffer-name buffer))))
|
||||
(apply-partially 'completion-table-with-predicate
|
||||
'internal-complete-buffer
|
||||
(lambda (name)
|
||||
@ -1791,10 +1785,9 @@ Return the new suffix."
|
||||
(substring afterpoint 0 (cdr bounds)))))
|
||||
|
||||
(defun completion-basic-try-completion (string table pred point)
|
||||
(lexical-let*
|
||||
((beforepoint (substring string 0 point))
|
||||
(afterpoint (substring string point))
|
||||
(bounds (completion-boundaries beforepoint table pred afterpoint)))
|
||||
(let* ((beforepoint (substring string 0 point))
|
||||
(afterpoint (substring string point))
|
||||
(bounds (completion-boundaries beforepoint table pred afterpoint)))
|
||||
(if (zerop (cdr bounds))
|
||||
;; `try-completion' may return a subtly different result
|
||||
;; than `all+merge', so try to use it whenever possible.
|
||||
@ -1805,30 +1798,28 @@ Return the new suffix."
|
||||
(concat completion
|
||||
(completion--merge-suffix completion point afterpoint))
|
||||
(length completion))))
|
||||
(lexical-let*
|
||||
((suffix (substring afterpoint (cdr bounds)))
|
||||
(prefix (substring beforepoint 0 (car bounds)))
|
||||
(pattern (delete
|
||||
"" (list (substring beforepoint (car bounds))
|
||||
'point
|
||||
(substring afterpoint 0 (cdr bounds)))))
|
||||
(all (completion-pcm--all-completions prefix pattern table pred)))
|
||||
(let* ((suffix (substring afterpoint (cdr bounds)))
|
||||
(prefix (substring beforepoint 0 (car bounds)))
|
||||
(pattern (delete
|
||||
"" (list (substring beforepoint (car bounds))
|
||||
'point
|
||||
(substring afterpoint 0 (cdr bounds)))))
|
||||
(all (completion-pcm--all-completions prefix pattern table pred)))
|
||||
(if minibuffer-completing-file-name
|
||||
(setq all (completion-pcm--filename-try-filter all)))
|
||||
(completion-pcm--merge-try pattern all prefix suffix)))))
|
||||
|
||||
(defun completion-basic-all-completions (string table pred point)
|
||||
(lexical-let*
|
||||
((beforepoint (substring string 0 point))
|
||||
(afterpoint (substring string point))
|
||||
(bounds (completion-boundaries beforepoint table pred afterpoint))
|
||||
(suffix (substring afterpoint (cdr bounds)))
|
||||
(prefix (substring beforepoint 0 (car bounds)))
|
||||
(pattern (delete
|
||||
"" (list (substring beforepoint (car bounds))
|
||||
'point
|
||||
(substring afterpoint 0 (cdr bounds)))))
|
||||
(all (completion-pcm--all-completions prefix pattern table pred)))
|
||||
(let* ((beforepoint (substring string 0 point))
|
||||
(afterpoint (substring string point))
|
||||
(bounds (completion-boundaries beforepoint table pred afterpoint))
|
||||
(suffix (substring afterpoint (cdr bounds)))
|
||||
(prefix (substring beforepoint 0 (car bounds)))
|
||||
(pattern (delete
|
||||
"" (list (substring beforepoint (car bounds))
|
||||
'point
|
||||
(substring afterpoint 0 (cdr bounds)))))
|
||||
(all (completion-pcm--all-completions prefix pattern table pred)))
|
||||
(completion-hilit-commonality all point (car bounds))))
|
||||
|
||||
;;; Partial-completion-mode style completion.
|
||||
@ -1991,13 +1982,12 @@ POINT is a position inside STRING.
|
||||
FILTER is a function applied to the return value, that can be used, e.g. to
|
||||
filter out additional entries (because TABLE migth not obey PRED)."
|
||||
(unless filter (setq filter 'identity))
|
||||
(lexical-let*
|
||||
((beforepoint (substring string 0 point))
|
||||
(afterpoint (substring string point))
|
||||
(bounds (completion-boundaries beforepoint table pred afterpoint))
|
||||
(prefix (substring beforepoint 0 (car bounds)))
|
||||
(suffix (substring afterpoint (cdr bounds)))
|
||||
firsterror)
|
||||
(let* ((beforepoint (substring string 0 point))
|
||||
(afterpoint (substring string point))
|
||||
(bounds (completion-boundaries beforepoint table pred afterpoint))
|
||||
(prefix (substring beforepoint 0 (car bounds)))
|
||||
(suffix (substring afterpoint (cdr bounds)))
|
||||
firsterror)
|
||||
(setq string (substring string (car bounds) (+ point (cdr bounds))))
|
||||
(let* ((relpoint (- point (car bounds)))
|
||||
(pattern (completion-pcm--string->pattern string relpoint))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user