(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)
;; 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
(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.
((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:
;;
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))))
;;
'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:
(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)))
;;
(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
(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)
(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)
(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
(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
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
;; 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))
'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))
(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 -->
(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)))
;;
;; 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)
-;;; minibuffer.el --- Minibuffer completion functions
+;;; minibuffer.el --- Minibuffer completion functions -*- lexical-binding: t -*-
;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
"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)))
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.
;; 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))))
(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)
"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))
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)
;; `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.
`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))
"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))
;; 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)
"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)
(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.
(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.
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))