diff options
author | Stefan Monnier <monnier@iro.umontreal.ca> | 2011-04-01 13:19:52 -0400 |
---|---|---|
committer | Stefan Monnier <monnier@iro.umontreal.ca> | 2011-04-01 13:19:52 -0400 |
commit | 034086489cff2a23cb4d9f8c536e18456be617ef (patch) | |
tree | 93fa6987e56af7b5fd452f7f909ea0653c5b47de /lisp/minibuffer.el | |
parent | 1c412c000a5d61d1be7f6fa7e632a517b89de95b (diff) | |
parent | 7200d79c65c65686495dd95e9f6dd436cf6db55e (diff) | |
download | emacs-034086489cff2a23cb4d9f8c536e18456be617ef.tar.gz |
Merge from lexical-binding branch.
* doc/lispref/eval.texi (Eval): Discourage the use of `eval'.
Document its new `lexical' argument.
* doc/lispref/variables.texi (Defining Variables): Mention the new meaning of `defvar'.
(Lexical Binding): New sub-section.
* lisp/Makefile.in (BIG_STACK_DEPTH, BIG_STACK_OPTS, BYTE_COMPILE_FLAGS):
New variables.
(compile-onefile, .el.elc, compile-calc, recompile): Use them.
(COMPILE_FIRST): Add macroexp and cconv.
* lisp/makefile.w32-in: Mirror changes in Makefile.in.
* lisp/vc/cvs-status.el:
* lisp/vc/diff-mode.el:
* lisp/vc/log-edit.el:
* lisp/vc/log-view.el:
* lisp/vc/smerge-mode.el:
* lisp/textmodes/bibtex-style.el:
* textmodes/css.el:
* lisp/startup.el:
* lisp/uniquify.el:
* lisp/minibuffer.el:
* lisp/newcomment.el:
* lisp/reveal.el:
* lisp/server.el:
* lisp/mpc.el:
* lisp/emacs-lisp/smie.el:
* lisp/doc-view.el:
* lisp/dired.el:
* lisp/abbrev.el: Use lexical binding.
* lisp/custom.el (custom-initialize-default, custom-declare-variable):
Use `defvar'.
* lisp/files.el (lexical-binding): Declare safe.
* lisp/help-fns.el (help-split-fundoc): Return nil if there's nothing else
than the arglist.
(help-add-fundoc-usage): Don't add `Not documented'.
(help-function-arglist): Handle closures, subroutines, and new
byte-code-functions.
(help-make-usage): Remove leading underscores.
(describe-function-1): Handle closures.
(describe-variable): Use special-variable-p for completion.
* lisp/simple.el (with-wrapper-hook, apply-partially): Move to subr.el.
* lisp/subr.el (apply-partially): Use new closures rather than CL.
(--dolist-tail--, --dotimes-limit--): Don't declare dynamic.
(dolist, dotimes): Use slightly different expansion for lexical code.
(functionp): Move to C.
(letrec): New macro.
(with-wrapper-hook): Use it and apply-partially instead of CL.
(eval-after-load): Preserve lexical-binding.
(save-window-excursion, with-output-to-temp-buffer): Turn them
into macros.
* lisp/emacs-lisp/advice.el (ad-arglist): Use help-function-arglist.
* lisp/emacs-lisp/autoload.el (make-autoload): Don't burp on trivial macros.
* lisp/emacs-lisp/byte-opt.el: Use lexical binding.
(byte-inline-lapcode): Remove (to bytecomp).
(byte-compile-inline-expand): Pay attention to inlining to/from
lexically bound code.
(byte-compile-unfold-lambda): Don't handle byte-code-functions
any more.
(byte-optimize-form-code-walker): Don't handle save-window-excursion
any more and don't call compiler-macros.
(byte-compile-splice-in-already-compiled-code): Remove.
(byte-code): Don't inline any more.
(disassemble-offset): Receive `bytes' as argument rather than via
dynamic scoping.
(byte-compile-tag-number): Declare before first use.
(byte-decompile-bytecode-1): Handle new byte-codes, don't change
`return' even if make-spliceable.
(byte-compile-side-effect-and-error-free-ops): Add stack-ref, remove
obsolete interactive-p.
(byte-optimize-lapcode): Optimize new lap-codes.
Don't trip up on new form of `byte-constant' lap code.
* lisp/emacs-lisp/byte-run.el (make-obsolete): Don't set the `byte-compile'
handler any more.
* lisp/emacs-lisp/bytecomp.el: Use lexical binding instead of
a "bytecomp-" prefix. Macroexpand everything as a separate phase.
(byte-compile-initial-macro-environment):
Handle declare-function here.
(byte-compile--lexical-environment): New var.
(byte-stack-ref, byte-stack-set, byte-discardN)
(byte-discardN-preserve-tos): New lap codes.
(byte-interactive-p): Don't use any more.
(byte-compile-push-bytecodes, byte-compile-push-bytecode-const2):
New macros.
(byte-compile-lapcode): Use them and handle new lap codes.
(byte-compile-obsolete): Remove.
(byte-compile-arglist-signature): Handle new byte-code arg"lists".
(byte-compile-arglist-warn): Check late def of inlinable funs.
(byte-compile-cl-warn): Don't silence warnings for compiler-macros
since they should have been expanded by now.
(byte-compile--outbuffer): Rename from bytecomp-outbuffer.
(byte-compile-from-buffer): Remove unused second arg.
(byte-compile-preprocess): New function.
(byte-compile-toplevel-file-form): New function to distinguish
file-form calls from outside from file-form calls from hunk-handlers.
(byte-compile-file-form): Simplify.
(byte-compile-file-form-defsubst): Remove.
(byte-compile-file-form-defmumble): Simplify now that
byte-compile-lambda always returns a byte-code-function.
(byte-compile): Preprocess.
(byte-compile-byte-code-maker, byte-compile-byte-code-unmake):
Remove, not used any more.
(byte-compile-arglist-vars, byte-compile-make-lambda-lexenv)
(byte-compile-make-args-desc): New funs.
(byte-compile-lambda): Handle lexical functions. Always return
a byte-code-function.
(byte-compile-reserved-constants): New var, to make up room for
closed-over variables.
(byte-compile-constants-vector): Obey it.
(byte-compile-top-level): New args `lexenv' and `reserved-csts'.
(byte-compile-macroexpand-declare-function): New function.
(byte-compile-form): Call byte-compile-unfold-bcf to inline immediate
byte-code-functions.
(byte-compile-form): Check obsolescence here.
(byte-compile-inline-lapcode, byte-compile-unfold-bcf): New functions.
(byte-compile-variable-ref): Remove.
(byte-compile-dynamic-variable-op): New fun.
(byte-compile-dynamic-variable-bind, byte-compile-variable-ref)
(byte-compile-variable-set): New funs.
(byte-compile-discard): Add 2 args.
(byte-compile-stack-ref, byte-compile-stack-set)
(byte-compile-make-closure, byte-compile-get-closed-var): New funs.
(byte-compile-funarg, byte-compile-funarg-2): Remove, handled in
macroexpand-all instead.
(byte-compile-quote-form): Remove.
(byte-compile-push-binding-init, byte-compile-not-lexical-var-p)
(byte-compile-bind, byte-compile-unbind): New funs.
(byte-compile-let): Handle let* and lexical binding.
(byte-compile-let*): Remove.
(byte-compile-catch, byte-compile-unwind-protect)
(byte-compile-track-mouse, byte-compile-condition-case):
Handle a new :fun-body form, used for lexical scoping.
(byte-compile-save-window-excursion)
(byte-compile-with-output-to-temp-buffer): Remove.
(byte-compile-defun): Simplify.
(byte-compile-stack-adjustment): New fun.
(byte-compile-out): Use it.
(byte-compile-refresh-preloaded): Don't reload byte-compiler files.
* lisp/emacs-lisp/cconv.el: New file.
* lisp/emacs-lisp/cl-extra.el (cl-macroexpand-all): Properly quote CL
closures.
* lisp/emacs-lisp/cl-macs.el (cl-byte-compile-block)
(cl-byte-compile-throw): Remove.
(cl-block-wrapper, cl-block-throw): Use compiler-macros instead.
* lisp/emacs-lisp/cl.el (pushnew): Silence warning.
* lisp/emacs-lisp/disass.el (disassemble-internal): Handle new
`closure' objects.
(disassemble-1): Handle new byte codes.
* lisp/emacs-lisp/edebug.el (edebug-eval-defun)
(edebug-eval-top-level-form): Use eval-sexp-add-defvars.
(edebug-toggle): Avoid `eval'.
* lisp/emacs-lisp/eieio-comp.el: Remove.
* lisp/emacs-lisp/eieio.el (byte-compile-file-form-defmethod):
Don't autoload.
(eieio-defgeneric-form-primary-only-one): Use `byte-compile' rather
than the internal `byte-compile-lambda'.
(defmethod): Don't hide code under quotes.
(eieio-defmethod): New `code' argument.
* lisp/emacs-lisp/float-sup.el (pi): Don't declare as dynamically bound.
* lisp/emacs-lisp/lisp-mode.el (eval-last-sexp-1):
Use eval-sexp-add-defvars.
(eval-sexp-add-defvars): New fun.
* lisp/emacs-lisp/macroexp.el: Use lexical binding.
(macroexpand-all-1): Check obsolete macros. Expand compiler-macros.
Don't convert ' to #' without checking that it's indeed quoting
a lambda.
* lisp/emacs-lisp/pcase.el: Don't use destructuring-bind.
(pcase--memoize): Rename from pcase-memoize. Change weakness.
(pcase): Add `let' pattern.
Change memoization so it actually works.
(pcase-mutually-exclusive-predicates): Add byte-code-function-p.
(pcase--u1) <guard, pred>: Fix possible shadowing problem.
<let>: New case.
* src/alloc.c (Fmake_symbol): Init new `declared_special' field.
* src/buffer.c (defvar_per_buffer): Set new `declared_special' field.
* src/bytecode.c (Bstack_ref, Bstack_set, Bstack_set2, BdiscardN):
New byte-codes.
(exec_byte_code): New function extracted from Fbyte_code to handle new
calling convention for byte-code-functions. Add new byte-codes.
* src/callint.c (Fcall_interactively): Preserve lexical-binding mode for
interactive spec.
* src/doc.c (Fdocumentation, store_function_docstring):
* src/data.c (Finteractive_form): Handle closures.
* src/eval.c (Fsetq): Handle lexical vars.
(Fdefun, Fdefmacro, Ffunction): Make closures when needed.
(Fdefconst, Fdefvaralias, Fdefvar): Mark as dynamic.
(FletX, Flet): Obey lexical binding.
(Fcommandp): Handle closures.
(Feval): New `lexical' arg.
(eval_sub): New function extracted from Feval. Use it almost
everywhere where Feval was used. Look up vars in lexical env.
Handle closures.
(Ffunctionp): Move from subr.el.
(Ffuncall): Handle closures.
(apply_lambda): Remove `eval_flags'.
(funcall_lambda): Handle closures and new byte-code-functions.
(Fspecial_variable_p): New function.
(syms_of_eval): Initialize the Vinternal_interpreter_environment var,
but without exporting it to Lisp.
* src/fns.c (concat, mapcar1): Accept byte-code-functions.
* src/image.c (parse_image_spec): Use Ffunctionp.
* src/keyboard.c (eval_dyn): New fun.
(menu_item_eval_property): Use it.
* src/lisp.h (struct Lisp_Symbol): New field `declared_special'.
* src/lread.c (lisp_file_lexically_bound_p): New function.
(Fload): Bind Qlexical_binding.
(readevalloop): Remove `evalfun' arg.
Bind Qinternal_interpreter_environment.
(Feval_buffer): Bind Qlexical_binding.
(defvar_int, defvar_bool, defvar_lisp_nopro, defvar_kboard):
Mark as dynamic.
(syms_of_lread): Declare `lexical-binding'.
* src/window.c (Ftemp_output_buffer_show): New fun.
(Fsave_window_excursion):
* src/print.c (Fwith_output_to_temp_buffer): Move to subr.el.
Diffstat (limited to 'lisp/minibuffer.el')
-rw-r--r-- | lisp/minibuffer.el | 562 |
1 files changed, 276 insertions, 286 deletions
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 4aa34698809..83358ba2f01 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -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,16 +171,15 @@ 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) - (if (eq (car-safe action) 'boundaries) - ;; `fun' is not supposed to return another function but a plain old - ;; completion table, whose boundaries are always trivial. - nil - (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) + (if (eq (car-safe action) 'boundaries) + ;; `fun' is not supposed to return another function but a plain old + ;; completion table, whose boundaries are always trivial. + nil + (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. @@ -209,19 +208,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)))) @@ -300,11 +298,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) @@ -314,11 +311,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)) @@ -560,16 +556,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) @@ -584,13 +579,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. @@ -672,16 +666,16 @@ scroll the window of possible completions." (setq minibuffer-scroll-window nil)) (cond - ;; If there's a fresh completion window with a live buffer, - ;; and this command is repeated, scroll that window. + ;; If there's a fresh completion window with a live buffer, + ;; and this command is repeated, scroll that window. ((window-live-p minibuffer-scroll-window) (let ((window minibuffer-scroll-window)) - (with-current-buffer (window-buffer window) - (if (pos-visible-in-window-p (point-max) window) - ;; If end is in view, scroll up to the beginning. - (set-window-start window (point-min) nil) - ;; Else scroll down one screen. - (scroll-other-window)) + (with-current-buffer (window-buffer window) + (if (pos-visible-in-window-p (point-max) window) + ;; If end is in view, scroll up to the beginning. + (set-window-start window (point-min) nil) + ;; Else scroll down one screen. + (scroll-other-window)) nil))) ;; If we're cycling, keep on cycling. ((and completion-cycling completion-all-sorted-completions) @@ -695,7 +689,7 @@ scroll the window of possible completions." t) (t t))))) -(defun completion--flush-all-sorted-completions (&rest ignore) +(defun completion--flush-all-sorted-completions (&rest _ignore) (remove-hook 'after-change-functions 'completion--flush-all-sorted-completions t) (setq completion-cycling nil) @@ -783,8 +777,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)) @@ -1029,7 +1023,7 @@ It also eliminates runs of equal strings." 'mouse-face 'highlight) (add-text-properties (point) (progn (insert (cadr str)) (point)) '(mouse-face nil - face completions-annotations))) + face completions-annotations))) (cond ((eq completions-format 'vertical) ;; Vertical format @@ -1161,14 +1155,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)) @@ -1462,7 +1456,7 @@ The completion method is determined by `completion-at-point-functions'." (concat "\\(?:^\\|[^$]\\(?:\\$\\$\\)*\\)" "$\\([[:alnum:]_]*\\|{\\([^}]*\\)\\)\\'")) -(defun completion--embedded-envvar-table (string pred action) +(defun completion--embedded-envvar-table (string _pred action) "Completion table for envvars embedded in a string. The envvar syntax (and escaping) rules followed by this table are the same as `substitute-in-file-name'." @@ -1482,20 +1476,20 @@ same as `substitute-in-file-name'." ;; other table handle the test-completion case. nil) ((eq (car-safe action) 'boundaries) - ;; Only return boundaries if there's something to complete, - ;; since otherwise when we're used in - ;; completion-table-in-turn, we could return boundaries and - ;; let some subsequent table return a list of completions. - ;; FIXME: Maybe it should rather be fixed in - ;; completion-table-in-turn instead, but it's difficult to - ;; do it efficiently there. + ;; Only return boundaries if there's something to complete, + ;; since otherwise when we're used in + ;; completion-table-in-turn, we could return boundaries and + ;; let some subsequent table return a list of completions. + ;; FIXME: Maybe it should rather be fixed in + ;; completion-table-in-turn instead, but it's difficult to + ;; do it efficiently there. (when (try-completion (substring string beg) table nil) - ;; Compute the boundaries of the subfield to which this - ;; completion applies. - (let ((suffix (cdr action))) - (list* 'boundaries - (or (match-beginning 2) (match-beginning 1)) - (when (string-match "[^[:alnum:]_]" suffix) + ;; Compute the boundaries of the subfield to which this + ;; completion applies. + (let ((suffix (cdr action))) + (list* 'boundaries + (or (match-beginning 2) (match-beginning 1)) + (when (string-match "[^[:alnum:]_]" suffix) (match-beginning 0)))))) (t (if (eq (aref string (1- beg)) ?{) @@ -1510,55 +1504,55 @@ same as `substitute-in-file-name'." (defun completion-file-name-table (string pred action) "Completion table for file names." (ignore-errors - (cond - ((eq (car-safe action) 'boundaries) - (let ((start (length (file-name-directory string))) - (end (string-match-p "/" (cdr action)))) - (list* 'boundaries - ;; if `string' is "C:" in w32, (file-name-directory string) - ;; returns "C:/", so `start' is 3 rather than 2. - ;; Not quite sure what is The Right Fix, but clipping it - ;; back to 2 will work for this particular case. We'll - ;; see if we can come up with a better fix when we bump - ;; into more such problematic cases. - (min start (length string)) end))) - - ((eq action 'lambda) - (if (zerop (length string)) - nil ;Not sure why it's here, but it probably doesn't harm. - (funcall (or pred 'file-exists-p) string))) + (cond + ((eq (car-safe action) 'boundaries) + (let ((start (length (file-name-directory string))) + (end (string-match-p "/" (cdr action)))) + (list* 'boundaries + ;; if `string' is "C:" in w32, (file-name-directory string) + ;; returns "C:/", so `start' is 3 rather than 2. + ;; Not quite sure what is The Right Fix, but clipping it + ;; back to 2 will work for this particular case. We'll + ;; see if we can come up with a better fix when we bump + ;; into more such problematic cases. + (min start (length string)) end))) + + ((eq action 'lambda) + (if (zerop (length string)) + nil ;Not sure why it's here, but it probably doesn't harm. + (funcall (or pred 'file-exists-p) string))) - (t + (t (let* ((name (file-name-nondirectory string)) (specdir (file-name-directory string)) (realdir (or specdir default-directory))) - (cond - ((null action) + (cond + ((null action) (let ((comp (file-name-completion name realdir pred))) (if (stringp comp) (concat specdir comp) comp))) - ((eq action t) - (let ((all (file-name-all-completions name realdir))) + ((eq action t) + (let ((all (file-name-all-completions name realdir))) - ;; Check the predicate, if necessary. + ;; Check the predicate, if necessary. (unless (memq pred '(nil file-exists-p)) - (let ((comp ()) - (pred + (let ((comp ()) + (pred (if (eq pred 'file-directory-p) - ;; Brute-force speed up for directory checking: - ;; Discard strings which don't end in a slash. - (lambda (s) - (let ((len (length s))) - (and (> len 0) (eq (aref s (1- len)) ?/)))) - ;; Must do it the hard (and slow) way. + ;; Brute-force speed up for directory checking: + ;; Discard strings which don't end in a slash. + (lambda (s) + (let ((len (length s))) + (and (> len 0) (eq (aref s (1- len)) ?/)))) + ;; Must do it the hard (and slow) way. pred))) (let ((default-directory (expand-file-name realdir))) - (dolist (tem all) - (if (funcall pred tem) (push tem comp)))) - (setq all (nreverse comp)))) + (dolist (tem all) + (if (funcall pred tem) (push tem comp)))) + (setq all (nreverse comp)))) all)))))))) @@ -1755,122 +1749,122 @@ See `read-file-name' for the meaning of the arguments." (minibuffer--double-dollars dir))) (initial (cons (minibuffer--double-dollars initial) 0))))) - (let ((completion-ignore-case read-file-name-completion-ignore-case) - (minibuffer-completing-file-name t) - (pred (or predicate 'file-exists-p)) - (add-to-history nil)) - - (let* ((val - (if (or (not (next-read-file-uses-dialog-p)) - ;; Graphical file dialogs can't handle remote - ;; files (Bug#99). - (file-remote-p dir)) - ;; We used to pass `dir' to `read-file-name-internal' by - ;; abusing the `predicate' argument. It's better to - ;; 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)))) - (minibuffer-with-setup-hook - (lambda () - (setq default-directory dir) - ;; When the first default in `minibuffer-default' - ;; duplicates initial input `insdef', - ;; reset `minibuffer-default' to nil. - (when (equal (or (car-safe insdef) insdef) - (or (car-safe minibuffer-default) - minibuffer-default)) - (setq minibuffer-default - (cdr-safe minibuffer-default))) - ;; On the first request on `M-n' fill - ;; `minibuffer-default' with a list of defaults - ;; relevant for file-name reading. - (set (make-local-variable 'minibuffer-default-add-function) - (lambda () - (with-current-buffer - (window-buffer (minibuffer-selected-window)) + (let ((completion-ignore-case read-file-name-completion-ignore-case) + (minibuffer-completing-file-name t) + (pred (or predicate 'file-exists-p)) + (add-to-history nil)) + + (let* ((val + (if (or (not (next-read-file-uses-dialog-p)) + ;; Graphical file dialogs can't handle remote + ;; files (Bug#99). + (file-remote-p dir)) + ;; We used to pass `dir' to `read-file-name-internal' by + ;; abusing the `predicate' argument. It's better to + ;; just use `default-directory', but in order to avoid + ;; changing `default-directory' in the current buffer, + ;; we don't let-bind it. + (let ((dir (file-name-as-directory + (expand-file-name dir)))) + (minibuffer-with-setup-hook + (lambda () + (setq default-directory dir) + ;; When the first default in `minibuffer-default' + ;; duplicates initial input `insdef', + ;; reset `minibuffer-default' to nil. + (when (equal (or (car-safe insdef) insdef) + (or (car-safe minibuffer-default) + minibuffer-default)) + (setq minibuffer-default + (cdr-safe minibuffer-default))) + ;; On the first request on `M-n' fill + ;; `minibuffer-default' with a list of defaults + ;; relevant for file-name reading. + (set (make-local-variable 'minibuffer-default-add-function) + (lambda () + (with-current-buffer + (window-buffer (minibuffer-selected-window)) (read-file-name--defaults dir initial))))) - (completing-read prompt 'read-file-name-internal - pred mustmatch insdef - 'file-name-history default-filename))) - ;; If DEFAULT-FILENAME not supplied and DIR contains - ;; a file name, split it. - (let ((file (file-name-nondirectory dir)) - ;; When using a dialog, revert to nil and non-nil - ;; interpretation of mustmatch. confirm options - ;; need to be interpreted as nil, otherwise - ;; it is impossible to create new files using - ;; dialogs with the default settings. - (dialog-mustmatch - (not (memq mustmatch - '(nil confirm confirm-after-completion))))) - (when (and (not default-filename) - (not (zerop (length file)))) - (setq default-filename file) - (setq dir (file-name-directory dir))) - (when default-filename - (setq default-filename - (expand-file-name (if (consp default-filename) - (car default-filename) - default-filename) - dir))) - (setq add-to-history t) - (x-file-dialog prompt dir default-filename - dialog-mustmatch - (eq predicate 'file-directory-p))))) - - (replace-in-history (eq (car-safe file-name-history) val))) - ;; If completing-read returned the inserted default string itself - ;; (rather than a new string with the same contents), - ;; it has to mean that the user typed RET with the minibuffer empty. - ;; In that case, we really want to return "" - ;; so that commands such as set-visited-file-name can distinguish. - (when (consp default-filename) - (setq default-filename (car default-filename))) - (when (eq val default-filename) - ;; In this case, completing-read has not added an element - ;; to the history. Maybe we should. - (if (not replace-in-history) - (setq add-to-history t)) - (setq val "")) - (unless val (error "No file name specified")) - - (if (and default-filename - (string-equal val (if (consp insdef) (car insdef) insdef))) - (setq val default-filename)) - (setq val (substitute-in-file-name val)) - - (if replace-in-history - ;; Replace what Fcompleting_read added to the history - ;; with what we will actually return. As an exception, - ;; if that's the same as the second item in - ;; file-name-history, it's really a repeat (Bug#4657). + (completing-read prompt 'read-file-name-internal + pred mustmatch insdef + 'file-name-history default-filename))) + ;; If DEFAULT-FILENAME not supplied and DIR contains + ;; a file name, split it. + (let ((file (file-name-nondirectory dir)) + ;; When using a dialog, revert to nil and non-nil + ;; interpretation of mustmatch. confirm options + ;; need to be interpreted as nil, otherwise + ;; it is impossible to create new files using + ;; dialogs with the default settings. + (dialog-mustmatch + (not (memq mustmatch + '(nil confirm confirm-after-completion))))) + (when (and (not default-filename) + (not (zerop (length file)))) + (setq default-filename file) + (setq dir (file-name-directory dir))) + (when default-filename + (setq default-filename + (expand-file-name (if (consp default-filename) + (car default-filename) + default-filename) + dir))) + (setq add-to-history t) + (x-file-dialog prompt dir default-filename + dialog-mustmatch + (eq predicate 'file-directory-p))))) + + (replace-in-history (eq (car-safe file-name-history) val))) + ;; If completing-read returned the inserted default string itself + ;; (rather than a new string with the same contents), + ;; it has to mean that the user typed RET with the minibuffer empty. + ;; In that case, we really want to return "" + ;; so that commands such as set-visited-file-name can distinguish. + (when (consp default-filename) + (setq default-filename (car default-filename))) + (when (eq val default-filename) + ;; In this case, completing-read has not added an element + ;; to the history. Maybe we should. + (if (not replace-in-history) + (setq add-to-history t)) + (setq val "")) + (unless val (error "No file name specified")) + + (if (and default-filename + (string-equal val (if (consp insdef) (car insdef) insdef))) + (setq val default-filename)) + (setq val (substitute-in-file-name val)) + + (if replace-in-history + ;; Replace what Fcompleting_read added to the history + ;; with what we will actually return. As an exception, + ;; if that's the same as the second item in + ;; file-name-history, it's really a repeat (Bug#4657). + (let ((val1 (minibuffer--double-dollars val))) + (if history-delete-duplicates + (setcdr file-name-history + (delete val1 (cdr file-name-history)))) + (if (string= val1 (cadr file-name-history)) + (pop file-name-history) + (setcar file-name-history val1))) + (if add-to-history + ;; Add the value to the history--but not if it matches + ;; the last value already there. (let ((val1 (minibuffer--double-dollars val))) - (if history-delete-duplicates - (setcdr file-name-history - (delete val1 (cdr file-name-history)))) - (if (string= val1 (cadr file-name-history)) - (pop file-name-history) - (setcar file-name-history val1))) - (if add-to-history - ;; Add the value to the history--but not if it matches - ;; the last value already there. - (let ((val1 (minibuffer--double-dollars val))) - (unless (and (consp file-name-history) - (equal (car file-name-history) val1)) - (setq file-name-history - (cons val1 - (if history-delete-duplicates - (delete val1 file-name-history) - file-name-history))))))) + (unless (and (consp file-name-history) + (equal (car file-name-history) val1)) + (setq file-name-history + (cons val1 + (if history-delete-duplicates + (delete val1 file-name-history) + file-name-history))))))) val)))) (defun internal-complete-buffer-except (&optional buffer) "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) @@ -1879,13 +1873,13 @@ Like `internal-complete-buffer', but removes BUFFER from the completion list." ;;; Old-style completion, used in Emacs-21 and Emacs-22. -(defun completion-emacs21-try-completion (string table pred point) +(defun completion-emacs21-try-completion (string table pred _point) (let ((completion (try-completion string table pred))) (if (stringp completion) (cons completion (length completion)) completion))) -(defun completion-emacs21-all-completions (string table pred point) +(defun completion-emacs21-all-completions (string table pred _point) (completion-hilit-commonality (all-completions string table pred) (length string) @@ -1942,10 +1936,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. @@ -1956,30 +1949,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. @@ -2142,13 +2133,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)) @@ -2163,7 +2153,7 @@ filter out additional entries (because TABLE migth not obey PRED)." ;; The prefix has no completions at all, so we should try and fix ;; that first. (let ((substring (substring prefix 0 -1))) - (destructuring-bind (subpat suball subprefix subsuffix) + (destructuring-bind (subpat suball subprefix _subsuffix) (completion-pcm--find-all-completions substring table pred (length substring) filter) (let ((sep (aref prefix (1- (length prefix)))) @@ -2228,7 +2218,7 @@ filter out additional entries (because TABLE migth not obey PRED)." (list pattern all prefix suffix))))) (defun completion-pcm-all-completions (string table pred point) - (destructuring-bind (pattern all &optional prefix suffix) + (destructuring-bind (pattern all &optional prefix _suffix) (completion-pcm--find-all-completions string table pred point) (when all (nconc (completion-pcm--hilit-commonality pattern all) @@ -2323,9 +2313,9 @@ filter out additional entries (because TABLE migth not obey PRED)." (defun completion-pcm--pattern->string (pattern) (mapconcat (lambda (x) (cond - ((stringp x) x) - ((eq x 'star) "*") - (t ""))) ;any, point, prefix. + ((stringp x) x) + ((eq x 'star) "*") + (t ""))) ;any, point, prefix. pattern "")) @@ -2341,7 +2331,7 @@ filter out additional entries (because TABLE migth not obey PRED)." ;; second alternative. (defun completion-pcm--filename-try-filter (all) "Filter to adjust `all' file completion to the behavior of `try'." - (when all + (when all (let ((try ()) (re (concat "\\(?:\\`\\.\\.?/\\|" (regexp-opt completion-ignored-extensions) @@ -2359,23 +2349,23 @@ filter out additional entries (because TABLE migth not obey PRED)." (equal (completion-pcm--pattern->string pattern) (car all))) t) (t - (let* ((mergedpat (completion-pcm--merge-completions all pattern)) - ;; `mergedpat' is in reverse order. Place new point (by - ;; order of preference) either at the old point, or at - ;; the last place where there's something to choose, or - ;; at the very end. - (pointpat (or (memq 'point mergedpat) - (memq 'any mergedpat) - (memq 'star mergedpat) - ;; Not `prefix'. - mergedpat)) - ;; New pos from the start. - (newpos (length (completion-pcm--pattern->string pointpat))) - ;; Do it afterwards because it changes `pointpat' by sideeffect. - (merged (completion-pcm--pattern->string (nreverse mergedpat)))) + (let* ((mergedpat (completion-pcm--merge-completions all pattern)) + ;; `mergedpat' is in reverse order. Place new point (by + ;; order of preference) either at the old point, or at + ;; the last place where there's something to choose, or + ;; at the very end. + (pointpat (or (memq 'point mergedpat) + (memq 'any mergedpat) + (memq 'star mergedpat) + ;; Not `prefix'. + mergedpat)) + ;; New pos from the start. + (newpos (length (completion-pcm--pattern->string pointpat))) + ;; Do it afterwards because it changes `pointpat' by sideeffect. + (merged (completion-pcm--pattern->string (nreverse mergedpat)))) (setq suffix (completion--merge-suffix merged newpos suffix)) - (cons (concat prefix merged suffix) (+ newpos (length prefix))))))) + (cons (concat prefix merged suffix) (+ newpos (length prefix))))))) (defun completion-pcm-try-completion (string table pred point) (destructuring-bind (pattern all prefix suffix) @@ -2403,14 +2393,14 @@ filter out additional entries (because TABLE migth not obey PRED)." (list all pattern prefix suffix (car bounds)))) (defun completion-substring-try-completion (string table pred point) - (destructuring-bind (all pattern prefix suffix carbounds) + (destructuring-bind (all pattern prefix suffix _carbounds) (completion-substring--all-completions string table pred point) (if minibuffer-completing-file-name (setq all (completion-pcm--filename-try-filter all))) (completion-pcm--merge-try pattern all prefix suffix))) (defun completion-substring-all-completions (string table pred point) - (destructuring-bind (all pattern prefix suffix carbounds) + (destructuring-bind (all pattern prefix _suffix _carbounds) (completion-substring--all-completions string table pred point) (when all (nconc (completion-pcm--hilit-commonality pattern all) @@ -2447,12 +2437,12 @@ filter out additional entries (because TABLE migth not obey PRED)." (concat (substring str 0 (car bounds)) (mapconcat 'string (substring str (car bounds)) sep)))))))) -(defun completion-initials-all-completions (string table pred point) +(defun completion-initials-all-completions (string table pred _point) (let ((newstr (completion-initials-expand string table pred))) (when newstr (completion-pcm-all-completions newstr table pred (length newstr))))) -(defun completion-initials-try-completion (string table pred point) +(defun completion-initials-try-completion (string table pred _point) (let ((newstr (completion-initials-expand string table pred))) (when newstr (completion-pcm-try-completion newstr table pred (length newstr))))) |