* lisp/abbrev.el: Remove use of cl-lib functions.
* lisp/frame.el: Remove use of cl-lib functions.
* lisp/international/mule-cmds.el: Remove use of cl-lib functions.
* lisp/minibuffer.el: Remove uses of cl-lib functions.
* lisp/byte-run.el: (defun-declarations-alist)
(macro-declarations-alist): Define at compile time.
* lisp/faces.el: Move face-listing code to "faces2.el".
* lisp/faces2.el: New file.
* lisp/files.el: Move minibuffer-with-setup-hook to subr.el.
* lisp/help.el: Move definition of with-help-window.
* lisp/international/mule.el: Define temporary defcustom macro.
* lisp/jka-cmpr-hook.el: Disable auto-compression-mode.
* lisp/loadup.el: Load mule and mule-conf earlier. Load gv
explicitly. Load subr2, derived, easy-mmode, cl-lib, cl-macs,
help-macro, help-fns, faces2, ccl, and kmacro explicitly.
* lisp/simple.el: Move defs of internal-push-keymap,
internal-pop-keymap, set-temporary-overlay-map from subr.el.
* lisp/subr.el (push): Use eval after loading macros.
(dolist): Remove.
(with-current-buffer, with-temp-buffer): Move definitions earlier.
(with-demoted-errors): Use `progn' instead of `macroexp-progn'.
(called-interactively-p-functions, called-interactively-p,
interactive-p): Move to "subr2.el".
* lisp/subr2.el: New file.
;;; Code:
-(eval-when-compile (require 'cl-lib))
+;;(eval-when-compile (require 'cl-lib))
(defgroup abbrev-mode nil
"Word abbreviations mode."
(dotimes (i (length table))
(aset table i 0))
;; Preserve the table's properties.
- (cl-assert sym)
+ ;;(cl-assert sym)
(let ((newsym (intern "" table)))
(set newsym nil) ; Make sure it won't be confused for an abbrev.
(setplist newsym (symbol-plist sym)))
(let ((badchars ())
(pos 0))
(while (string-match "\\W" abbrev pos)
- (cl-pushnew (aref abbrev (match-beginning 0)) badchars)
+ (let ((x (aref abbrev (match-beginning 0))))
+ (if (not (memql x badchars))
+ (setq badchars (cons x badchars))))
(setq pos (1+ pos)))
(error "Some abbrev characters (%s) are not word constituents %s"
(apply 'string (nreverse badchars))
list nil))
;; Otherwise, put any preceding nonspliced items into LISTS.
(if list
- (push (backquote-listify list '(0 . nil)) lists))
- (push (cdr item) lists)
+ (setq lists (cons (backquote-listify list '(0 . nil)) lists)))
+ (setq lists (cons (cdr item) lists))
(setq list nil))
(t
(setq list (cons item list))))
;; Handle nonsplicing final elements, and the tail of the list
;; (which remains in REST).
(if (or rest list)
- (push (backquote-listify list (backquote-process rest level))
- lists))
+ (setq lists (cons (backquote-listify list
+ (backquote-process rest level))
+ lists)))
;; Turn LISTS into a form that produces the combined list.
(setq expression
(if (or (cdr lists)
;; loaded by loadup.el that uses declarations in macros.
;; Add any new entries to info node `(elisp)Declare Form'.
-(defvar defun-declarations-alist
- (list
- ;; We can only use backquotes inside the lambdas and not for those
- ;; properties that are used by functions loaded before backquote.el.
- (list 'advertised-calling-convention
- #'(lambda (f _args arglist when)
- (list 'set-advertised-calling-convention
- (list 'quote f) (list 'quote arglist) (list 'quote when))))
- (list 'obsolete
- #'(lambda (f _args new-name when)
- (list 'make-obsolete
- (list 'quote f) (list 'quote new-name) (list 'quote when))))
- (list 'interactive-only
- #'(lambda (f _args instead)
- (list 'function-put (list 'quote f)
- ''interactive-only (list 'quote instead))))
- ;; FIXME: Merge `pure' and `side-effect-free'.
- (list 'pure
- #'(lambda (f _args val)
- (list 'function-put (list 'quote f)
- ''pure (list 'quote val)))
- "If non-nil, the compiler can replace calls with their return value.
+(eval-and-compile
+ (defvar defun-declarations-alist
+ (list
+ ;; We can only use backquotes inside the lambdas and not for those
+ ;; properties that are used by functions loaded before backquote.el.
+ (list 'advertised-calling-convention
+ #'(lambda (f _args arglist when)
+ (list 'set-advertised-calling-convention
+ (list 'quote f) (list 'quote arglist) (list 'quote when))))
+ (list 'obsolete
+ #'(lambda (f _args new-name when)
+ (list 'make-obsolete
+ (list 'quote f) (list 'quote new-name) (list 'quote when))))
+ (list 'interactive-only
+ #'(lambda (f _args instead)
+ (list 'function-put (list 'quote f)
+ ''interactive-only (list 'quote instead))))
+ ;; FIXME: Merge `pure' and `side-effect-free'.
+ (list 'pure
+ #'(lambda (f _args val)
+ (list 'function-put (list 'quote f)
+ ''pure (list 'quote val)))
+ "If non-nil, the compiler can replace calls with their return value.
This may shift errors from run-time to compile-time.")
- (list 'side-effect-free
- #'(lambda (f _args val)
- (list 'function-put (list 'quote f)
- ''side-effect-free (list 'quote val)))
- "If non-nil, calls can be ignored if their value is unused.
+ (list 'side-effect-free
+ #'(lambda (f _args val)
+ (list 'function-put (list 'quote f)
+ ''side-effect-free (list 'quote val)))
+ "If non-nil, calls can be ignored if their value is unused.
If `error-free', drop calls even if `byte-compile-delete-errors' is nil.")
- (list 'compiler-macro
- #'(lambda (f args compiler-function)
- `(eval-and-compile
- (function-put ',f 'compiler-macro
- ,(if (eq (car-safe compiler-function) 'lambda)
- `(lambda ,(append (cadr compiler-function) args)
- ,@(cddr compiler-function))
- `#',compiler-function)))))
- (list 'doc-string
- #'(lambda (f _args pos)
- (list 'function-put (list 'quote f)
- ''doc-string-elt (list 'quote pos))))
- (list 'indent
- #'(lambda (f _args val)
- (list 'function-put (list 'quote f)
- ''lisp-indent-function (list 'quote val)))))
- "List associating function properties to their macro expansion.
+ (list 'compiler-macro
+ #'(lambda (f args compiler-function)
+ `(eval-and-compile
+ (function-put ',f 'compiler-macro
+ ,(if (eq (car-safe compiler-function) 'lambda)
+ `(lambda ,(append (cadr compiler-function) args)
+ ,@(cddr compiler-function))
+ `#',compiler-function)))))
+ (list 'doc-string
+ #'(lambda (f _args pos)
+ (list 'function-put (list 'quote f)
+ ''doc-string-elt (list 'quote pos))))
+ (list 'indent
+ #'(lambda (f _args val)
+ (list 'function-put (list 'quote f)
+ ''lisp-indent-function (list 'quote val)))))
+ "List associating function properties to their macro expansion.
Each element of the list takes the form (PROP FUN) where FUN is
a function. For each (PROP . VALUES) in a function's declaration,
the FUN corresponding to PROP is called with the function name,
This is used by `declare'.")
-(defvar macro-declarations-alist
- (cons
- (list 'debug
- #'(lambda (name _args spec)
- (list 'progn :autoload-end
- (list 'put (list 'quote name)
- ''edebug-form-spec (list 'quote spec)))))
- defun-declarations-alist)
- "List associating properties of macros to their macro expansion.
+ (defvar macro-declarations-alist
+ (cons
+ (list 'debug
+ #'(lambda (name _args spec)
+ (list 'progn :autoload-end
+ (list 'put (list 'quote name)
+ ''edebug-form-spec (list 'quote spec)))))
+ defun-declarations-alist)
+ "List associating properties of macros to their macro expansion.
Each element of the list takes the form (PROP FUN) where FUN is a function.
For each (PROP . VALUES) in a macro's declaration, the FUN corresponding
to PROP is called with the macro name, the macro's arglist, and the VALUES
and should return the code to use to set this property.
-This is used by `declare'.")
+This is used by `declare'."))
(defalias 'defmacro
(cons
\f
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Listing faces.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defconst list-faces-sample-text
- "abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ"
- "Text string to display as the sample text for `list-faces-display'.")
-
-
-;; The name list-faces would be more consistent, but let's avoid a
-;; conflict with Lucid, which uses that name differently.
-
-(defvar help-xref-stack)
-(defun list-faces-display (&optional regexp)
- "List all faces, using the same sample text in each.
-The sample text is a string that comes from the variable
-`list-faces-sample-text'.
-
-If REGEXP is non-nil, list only those faces with names matching
-this regular expression. When called interactively with a prefix
-argument, prompt for a regular expression using `read-regexp'."
- (interactive (list (and current-prefix-arg
- (read-regexp "List faces matching regexp"))))
- (let ((all-faces (zerop (length regexp)))
- (frame (selected-frame))
- (max-length 0)
- faces line-format
- disp-frame window face-name)
- ;; We filter and take the max length in one pass
- (setq faces
- (delq nil
- (mapcar (lambda (f)
- (let ((s (symbol-name f)))
- (when (or all-faces (string-match-p regexp s))
- (setq max-length (max (length s) max-length))
- f)))
- (sort (face-list) #'string-lessp))))
- (unless faces
- (error "No faces matching \"%s\"" regexp))
- (setq max-length (1+ max-length)
- line-format (format "%%-%ds" max-length))
- (with-help-window "*Faces*"
- (with-current-buffer standard-output
- (setq truncate-lines t)
- (insert
- (substitute-command-keys
- (concat
- "\\<help-mode-map>Use "
- (if (display-mouse-p) "\\[help-follow-mouse] or ")
- "\\[help-follow] on a face name to customize it\n"
- "or on its sample text for a description of the face.\n\n")))
- (setq help-xref-stack nil)
- (dolist (face faces)
- (setq face-name (symbol-name face))
- (insert (format line-format face-name))
- ;; Hyperlink to a customization buffer for the face. Using
- ;; the help xref mechanism may not be the best way.
- (save-excursion
- (save-match-data
- (search-backward face-name)
- (setq help-xref-stack-item `(list-faces-display ,regexp))
- (help-xref-button 0 'help-customize-face face)))
- (let ((beg (point))
- (line-beg (line-beginning-position)))
- (insert list-faces-sample-text)
- ;; Hyperlink to a help buffer for the face.
- (save-excursion
- (save-match-data
- (search-backward list-faces-sample-text)
- (help-xref-button 0 'help-face face)))
- (insert "\n")
- (put-text-property beg (1- (point)) 'face face)
- ;; Make all face commands default to the proper face
- ;; anywhere in the line.
- (put-text-property line-beg (1- (point)) 'read-face-name face)
- ;; If the sample text has multiple lines, line up all of them.
- (goto-char beg)
- (forward-line 1)
- (while (not (eobp))
- (insert-char ?\s max-length)
- (forward-line 1))))
- (goto-char (point-min))))
- ;; If the *Faces* buffer appears in a different frame,
- ;; copy all the face definitions from FRAME,
- ;; so that the display will reflect the frame that was selected.
- (setq window (get-buffer-window (get-buffer "*Faces*") t))
- (setq disp-frame (if window (window-frame window)
- (car (frame-list))))
- (or (eq frame disp-frame)
- (dolist (face (face-list))
- (copy-face face face frame disp-frame)))))
-
-
-(defun describe-face (face &optional frame)
- "Display the properties of face FACE on FRAME.
-Interactively, FACE defaults to the faces of the character after point
-and FRAME defaults to the selected frame.
-
-If the optional argument FRAME is given, report on face FACE in that frame.
-If FRAME is t, report on the defaults for face FACE (for new frames).
-If FRAME is omitted or nil, use the selected frame."
- (interactive (list (read-face-name "Describe face"
- (or (face-at-point t) 'default)
- t)))
- (let* ((attrs '((:family . "Family")
- (:foundry . "Foundry")
- (:width . "Width")
- (:height . "Height")
- (:weight . "Weight")
- (:slant . "Slant")
- (:foreground . "Foreground")
- (:distant-foreground . "DistantForeground")
- (:background . "Background")
- (:underline . "Underline")
- (:overline . "Overline")
- (:strike-through . "Strike-through")
- (:box . "Box")
- (:inverse-video . "Inverse")
- (:stipple . "Stipple")
- (:font . "Font")
- (:fontset . "Fontset")
- (:inherit . "Inherit")))
- (max-width (apply #'max (mapcar #'(lambda (x) (length (cdr x)))
- attrs))))
- (help-setup-xref (list #'describe-face face)
- (called-interactively-p 'interactive))
- (unless face
- (setq face 'default))
- (if (not (listp face))
- (setq face (list face)))
- (with-help-window (help-buffer)
- (with-current-buffer standard-output
- (dolist (f face)
- (if (stringp f) (setq f (intern f)))
- ;; We may get called for anonymous faces (i.e., faces
- ;; expressed using prop-value plists). Those can't be
- ;; usefully customized, so ignore them.
- (when (symbolp f)
- (insert "Face: " (symbol-name f))
- (if (not (facep f))
- (insert " undefined face.\n")
- (let ((customize-label "customize this face")
- file-name)
- (insert (concat " (" (propertize "sample" 'font-lock-face f) ")"))
- (princ (concat " (" customize-label ")\n"))
- ;; FIXME not sure how much of this belongs here, and
- ;; how much in `face-documentation'. The latter is
- ;; not used much, but needs to return nil for
- ;; undocumented faces.
- (let ((alias (get f 'face-alias))
- (face f)
- obsolete)
- (when alias
- (setq face alias)
- (insert
- (format "\n %s is an alias for the face `%s'.\n%s"
- f alias
- (if (setq obsolete (get f 'obsolete-face))
- (format " This face is obsolete%s; use `%s' instead.\n"
- (if (stringp obsolete)
- (format " since %s" obsolete)
- "")
- alias)
- ""))))
- (insert "\nDocumentation:\n"
- (or (face-documentation face)
- "Not documented as a face.")
- "\n\n"))
- (with-current-buffer standard-output
- (save-excursion
- (re-search-backward
- (concat "\\(" customize-label "\\)") nil t)
- (help-xref-button 1 'help-customize-face f)))
- (setq file-name (find-lisp-object-file-name f 'defface))
- (when file-name
- (princ "Defined in `")
- (princ (file-name-nondirectory file-name))
- (princ "'")
- ;; Make a hyperlink to the library.
- (save-excursion
- (re-search-backward "`\\([^`']+\\)'" nil t)
- (help-xref-button 1 'help-face-def f file-name))
- (princ ".")
- (terpri)
- (terpri))
- (dolist (a attrs)
- (let ((attr (face-attribute f (car a) frame)))
- (insert (make-string (- max-width (length (cdr a))) ?\s)
- (cdr a) ": " (format "%s" attr))
- (if (and (eq (car a) :inherit)
- (not (eq attr 'unspecified)))
- ;; Make a hyperlink to the parent face.
- (save-excursion
- (re-search-backward ": \\([^:]+\\)" nil t)
- (help-xref-button 1 'help-face attr)))
- (insert "\n")))))
- (terpri)))))))
-
-\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Face specifications (defface).
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
--- /dev/null
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Listing faces.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defconst list-faces-sample-text
+ "abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+ "Text string to display as the sample text for `list-faces-display'.")
+
+
+;; The name list-faces would be more consistent, but let's avoid a
+;; conflict with Lucid, which uses that name differently.
+
+(defvar help-xref-stack)
+(defun list-faces-display (&optional regexp)
+ "List all faces, using the same sample text in each.
+The sample text is a string that comes from the variable
+`list-faces-sample-text'.
+
+If REGEXP is non-nil, list only those faces with names matching
+this regular expression. When called interactively with a prefix
+arg, prompt for a regular expression."
+ (interactive (list (and current-prefix-arg
+ (read-regexp "List faces matching regexp"))))
+ (let ((all-faces (zerop (length regexp)))
+ (frame (selected-frame))
+ (max-length 0)
+ faces line-format
+ disp-frame window face-name)
+ ;; We filter and take the max length in one pass
+ (setq faces
+ (delq nil
+ (mapcar (lambda (f)
+ (let ((s (symbol-name f)))
+ (when (or all-faces (string-match-p regexp s))
+ (setq max-length (max (length s) max-length))
+ f)))
+ (sort (face-list) #'string-lessp))))
+ (unless faces
+ (error "No faces matching \"%s\"" regexp))
+ (setq max-length (1+ max-length)
+ line-format (format "%%-%ds" max-length))
+ (with-help-window "*Faces*"
+ (with-current-buffer standard-output
+ (setq truncate-lines t)
+ (insert
+ (substitute-command-keys
+ (concat
+ "\\<help-mode-map>Use "
+ (if (display-mouse-p) "\\[help-follow-mouse] or ")
+ "\\[help-follow] on a face name to customize it\n"
+ "or on its sample text for a description of the face.\n\n")))
+ (setq help-xref-stack nil)
+ (dolist (face faces)
+ (setq face-name (symbol-name face))
+ (insert (format line-format face-name))
+ ;; Hyperlink to a customization buffer for the face. Using
+ ;; the help xref mechanism may not be the best way.
+ (save-excursion
+ (save-match-data
+ (search-backward face-name)
+ (setq help-xref-stack-item `(list-faces-display ,regexp))
+ (help-xref-button 0 'help-customize-face face)))
+ (let ((beg (point))
+ (line-beg (line-beginning-position)))
+ (insert list-faces-sample-text)
+ ;; Hyperlink to a help buffer for the face.
+ (save-excursion
+ (save-match-data
+ (search-backward list-faces-sample-text)
+ (help-xref-button 0 'help-face face)))
+ (insert "\n")
+ (put-text-property beg (1- (point)) 'face face)
+ ;; Make all face commands default to the proper face
+ ;; anywhere in the line.
+ (put-text-property line-beg (1- (point)) 'read-face-name face)
+ ;; If the sample text has multiple lines, line up all of them.
+ (goto-char beg)
+ (forward-line 1)
+ (while (not (eobp))
+ (insert-char ?\s max-length)
+ (forward-line 1))))
+ (goto-char (point-min))))
+ ;; If the *Faces* buffer appears in a different frame,
+ ;; copy all the face definitions from FRAME,
+ ;; so that the display will reflect the frame that was selected.
+ (setq window (get-buffer-window (get-buffer "*Faces*") t))
+ (setq disp-frame (if window (window-frame window)
+ (car (frame-list))))
+ (or (eq frame disp-frame)
+ (dolist (face (face-list))
+ (copy-face face face frame disp-frame)))))
+
+
+(defun describe-face (face &optional frame)
+ "Display the properties of face FACE on FRAME.
+Interactively, FACE defaults to the faces of the character after point
+and FRAME defaults to the selected frame.
+
+If the optional argument FRAME is given, report on face FACE in that frame.
+If FRAME is t, report on the defaults for face FACE (for new frames).
+If FRAME is omitted or nil, use the selected frame."
+ (interactive (list (read-face-name "Describe face"
+ (or (face-at-point t) 'default)
+ t)))
+ (let* ((attrs '((:family . "Family")
+ (:foundry . "Foundry")
+ (:width . "Width")
+ (:height . "Height")
+ (:weight . "Weight")
+ (:slant . "Slant")
+ (:foreground . "Foreground")
+ (:distant-foreground . "DistantForeground")
+ (:background . "Background")
+ (:underline . "Underline")
+ (:overline . "Overline")
+ (:strike-through . "Strike-through")
+ (:box . "Box")
+ (:inverse-video . "Inverse")
+ (:stipple . "Stipple")
+ (:font . "Font")
+ (:fontset . "Fontset")
+ (:inherit . "Inherit")))
+ (max-width (apply #'max (mapcar #'(lambda (x) (length (cdr x)))
+ attrs))))
+ (help-setup-xref (list #'describe-face face)
+ (called-interactively-p 'interactive))
+ (unless face
+ (setq face 'default))
+ (if (not (listp face))
+ (setq face (list face)))
+ (with-help-window (help-buffer)
+ (with-current-buffer standard-output
+ (dolist (f face)
+ (if (stringp f) (setq f (intern f)))
+ ;; We may get called for anonymous faces (i.e., faces
+ ;; expressed using prop-value plists). Those can't be
+ ;; usefully customized, so ignore them.
+ (when (symbolp f)
+ (insert "Face: " (symbol-name f))
+ (if (not (facep f))
+ (insert " undefined face.\n")
+ (let ((customize-label "customize this face")
+ file-name)
+ (insert (concat " (" (propertize "sample" 'font-lock-face f) ")"))
+ (princ (concat " (" customize-label ")\n"))
+ ;; FIXME not sure how much of this belongs here, and
+ ;; how much in `face-documentation'. The latter is
+ ;; not used much, but needs to return nil for
+ ;; undocumented faces.
+ (let ((alias (get f 'face-alias))
+ (face f)
+ obsolete)
+ (when alias
+ (setq face alias)
+ (insert
+ (format "\n %s is an alias for the face `%s'.\n%s"
+ f alias
+ (if (setq obsolete (get f 'obsolete-face))
+ (format " This face is obsolete%s; use `%s' instead.\n"
+ (if (stringp obsolete)
+ (format " since %s" obsolete)
+ "")
+ alias)
+ ""))))
+ (insert "\nDocumentation:\n"
+ (or (face-documentation face)
+ "Not documented as a face.")
+ "\n\n"))
+ (with-current-buffer standard-output
+ (save-excursion
+ (re-search-backward
+ (concat "\\(" customize-label "\\)") nil t)
+ (help-xref-button 1 'help-customize-face f)))
+ (setq file-name (find-lisp-object-file-name f 'defface))
+ (when file-name
+ (princ "Defined in `")
+ (princ (file-name-nondirectory file-name))
+ (princ "'")
+ ;; Make a hyperlink to the library.
+ (save-excursion
+ (re-search-backward "`\\([^`']+\\)'" nil t)
+ (help-xref-button 1 'help-face-def f file-name))
+ (princ ".")
+ (terpri)
+ (terpri))
+ (dolist (a attrs)
+ (let ((attr (face-attribute f (car a) frame)))
+ (insert (make-string (- max-width (length (cdr a))) ?\s)
+ (cdr a) ": " (format "%s" attr))
+ (if (and (eq (car a) :inherit)
+ (not (eq attr 'unspecified)))
+ ;; Make a hyperlink to the parent face.
+ (save-excursion
+ (re-search-backward ": \\([^:]+\\)" nil t)
+ (help-xref-button 1 'help-face attr)))
+ (insert "\n")))))
+ (terpri)))))))
'confirm)
(t nil)))
-(defmacro minibuffer-with-setup-hook (fun &rest body)
- "Temporarily add FUN to `minibuffer-setup-hook' while executing BODY.
-BODY should use the minibuffer at most once.
-Recursive uses of the minibuffer are unaffected (FUN is not
-called additional times).
-
-This macro actually adds an auxiliary function that calls FUN,
-rather than FUN itself, to `minibuffer-setup-hook'."
- (declare (indent 1) (debug t))
- (let ((hook (make-symbol "setup-hook"))
- (funsym (make-symbol "fun")))
- `(let ((,funsym ,fun)
- ,hook)
- (setq ,hook
- (lambda ()
- ;; Clear out this hook so it does not interfere
- ;; with any recursive minibuffer usage.
- (remove-hook 'minibuffer-setup-hook ,hook)
- (funcall ,funsym)))
- (unwind-protect
- (progn
- (add-hook 'minibuffer-setup-hook ,hook)
- ,@body)
- (remove-hook 'minibuffer-setup-hook ,hook)))))
-
(defun find-file-read-args (prompt mustmatch)
(list (read-file-name prompt nil default-directory mustmatch)
t))
;;; Commentary:
;;; Code:
-(eval-when-compile (require 'cl-lib))
(defvar frame-creation-function-alist
(list (cons nil
(if (and (eq system-type 'windows-nt)
(null (window-system)))
nil
- (cl-loop for descriptor in display-format-alist
- for pattern = (car descriptor)
- for system = (cdr descriptor)
- when (string-match-p pattern display) return system)))
+ (labels ((loop (list)
+ (let* ((descriptor (car list))
+ (pattern (car descriptor))
+ (system (cdr descriptor)))
+ (if (string-match-p pattern display)
+ system
+ (loop (cdr list))))))
+ (loop display-format-alist))))
(defun make-frame-on-display (display &optional parameters)
"Make a frame on display DISPLAY.
See `display-monitor-attributes-list' for the list of attribute
keys and their meanings."
(or frame (setq frame (selected-frame)))
- (cl-loop for attributes in (display-monitor-attributes-list frame)
- for frames = (cdr (assq 'frames attributes))
- if (memq frame frames) return attributes))
+ (labels ((loop (list)
+ (let* ((attributes (car list))
+ (frames (cdr (assq 'frames attributes))))
+ (if (memq frame frames)
+ attributes
+ (loop (cdr list))))))
+ (loop (display-monitor-attributes-list frame))))
\f
;;;; Frame/display capabilities.
(defvar help-button-cache nil)
\f
+;; `with-help-window' is a wrapper for `with-temp-buffer-window'
+;; providing the following additional twists:
+
+;; (1) It puts the buffer in `help-mode' (via `help-mode-setup') and
+;; adds cross references (via `help-mode-finish').
+
+;; (2) It issues a message telling how to scroll and quit the help
+;; window (via `help-window-setup').
+
+;; (3) An option (customizable via `help-window-select') to select the
+;; help window automatically.
+
+;; (4) A marker (`help-window-point-marker') to move point in the help
+;; window to an arbitrary buffer position.
+(defmacro with-help-window (buffer-name &rest body)
+ "Display buffer named BUFFER-NAME in a help window.
+Evaluate the forms in BODY with standard output bound to a buffer
+called BUFFER-NAME (creating it if it does not exist), put that
+buffer in `help-mode', display the buffer in a window (see
+`with-temp-buffer-window' for details) and issue a message how to
+deal with that \"help\" window when it's no more needed. Select
+the help window if the current value of the user option
+`help-window-select' says so. Return last value in BODY."
+ (declare (indent 1) (debug t))
+ `(progn
+ ;; Make `help-window-point-marker' point nowhere. The only place
+ ;; where this should be set to a buffer position is within BODY.
+ (set-marker help-window-point-marker nil)
+ (let ((temp-buffer-window-setup-hook
+ (cons 'help-mode-setup temp-buffer-window-setup-hook))
+ (temp-buffer-window-show-hook
+ (cons 'help-mode-finish temp-buffer-window-show-hook)))
+ (with-temp-buffer-window
+ ,buffer-name nil 'help-window-setup (progn ,@body)))))
+
(defun help-quit ()
"Just exit from the Help command's command loop."
(interactive)
;; Return VALUE.
value))
-;; `with-help-window' is a wrapper for `with-temp-buffer-window'
-;; providing the following additional twists:
-
-;; (1) It puts the buffer in `help-mode' (via `help-mode-setup') and
-;; adds cross references (via `help-mode-finish').
-
-;; (2) It issues a message telling how to scroll and quit the help
-;; window (via `help-window-setup').
-
-;; (3) An option (customizable via `help-window-select') to select the
-;; help window automatically.
-
-;; (4) A marker (`help-window-point-marker') to move point in the help
-;; window to an arbitrary buffer position.
-(defmacro with-help-window (buffer-name &rest body)
- "Display buffer named BUFFER-NAME in a help window.
-Evaluate the forms in BODY with standard output bound to a buffer
-called BUFFER-NAME (creating it if it does not exist), put that
-buffer in `help-mode', display the buffer in a window (see
-`with-temp-buffer-window' for details) and issue a message how to
-deal with that \"help\" window when it's no more needed. Select
-the help window if the current value of the user option
-`help-window-select' says so. Return last value in BODY."
- (declare (indent 1) (debug t))
- `(progn
- ;; Make `help-window-point-marker' point nowhere. The only place
- ;; where this should be set to a buffer position is within BODY.
- (set-marker help-window-point-marker nil)
- (let ((temp-buffer-window-setup-hook
- (cons 'help-mode-setup temp-buffer-window-setup-hook))
- (temp-buffer-window-show-hook
- (cons 'help-mode-finish temp-buffer-window-show-hook)))
- (with-temp-buffer-window
- ,buffer-name nil 'help-window-setup (progn ,@body)))))
-
;; Called from C, on encountering `help-char' when reading a char.
;; Don't print to *Help*; that would clobber Help history.
(defun help-form-show ()
;;; Code:
-(eval-when-compile (require 'cl-lib))
-
(defvar dos-codepage)
(autoload 'widget-value "wid-edit")
(coding-system-charset-list cs)))
(charsets charsets))
(if (coding-system-get cs :ascii-compatible-p)
- (cl-pushnew 'ascii cs-charsets))
+ (if (not (memql 'ascii cs-charsets))
+ (push 'ascii cs-charsets)))
(if (catch 'ok
(when cs-charsets
(while charsets
(set-keyboard-coding-system-internal coding-system terminal)
(setq keyboard-coding-system coding-system))
+(defmacro defcustom (var val &rest ignore)
+ `(defvar ,var ,val))
+
(defcustom keyboard-coding-system nil
"Specify coding system for keyboard input.
If you set this on a terminal which can't distinguish Meta keys from
file-local-copy load))
;; Turn on the mode.
-(when auto-compression-mode (auto-compression-mode 1))
+;(when auto-compression-mode (auto-compression-mode 1))
(provide 'jka-cmpr-hook)
(load "emacs-lisp/backquote")
(load "subr")
+
+(load "international/mule")
+(load "international/mule-conf")
+
;; Do it after subr, since both after-load-functions and add-hook are
;; implemented in subr.el.
(add-hook 'after-load-functions (lambda (f) (garbage-collect)))
(load "widget")
(load "custom")
(load "emacs-lisp/map-ynp")
-(load "international/mule")
-(load "international/mule-conf")
(load "env")
(load "format")
(load "bindings")
;; Re-load macroexp so as to eagerly macro-expand its uses of pcase.
(load "emacs-lisp/macroexp"))
+(load "emacs-lisp/gv")
+
(load "cus-face")
(load "faces") ; after here, `defface' may be used.
(load "button")
(load "startup")
+(load "subr2")
+
;; We don't want to store loaddefs.el in the repository because it is
;; a generated file; but it is required in order to compile the lisp files.
;; When bootstrapping, we cannot generate loaddefs.el until an
(file-error (load "ldefs-boot.el")))
(load "emacs-lisp/nadvice")
+(load "emacs-lisp/derived")
+(load "emacs-lisp/easy-mmode")
(load "minibuffer")
(load "abbrev") ;lisp-mode.el and simple.el use define-abbrev-table.
(load "simple")
+(load "emacs-lisp/cl-lib")
+(load "emacs-lisp/cl-macs")
+
+(load "help-macro")
(load "help")
+(load "help-fns")
+
+(load "faces2")
(load "jka-cmpr-hook")
(load "epa-hook")
(load "international/characters")
(load "composite")
+(load "international/ccl")
+
;; Load language-specific files.
(load "language/chinese")
(load "language/cyrillic")
(load "replace")
(load "emacs-lisp/tabulated-list")
+(load "kmacro")
(load "buff-menu")
(if (fboundp 'x-create-frame)
;;; Code:
-(eval-when-compile (require 'cl-lib))
+;;(eval-when-compile (require 'cl-lib))
(defun minibuf-conform-representation (string basis)
(cond
(qsuffix (cdr action))
(ufull (if (zerop (length qsuffix)) ustring
(funcall unquote (concat string qsuffix))))
- (_ (cl-assert (string-prefix-p ustring ufull)))
+ ;;(_ (cl-assert (string-prefix-p ustring ufull)))
(usuffix (substring ufull (length ustring)))
(boundaries (completion-boundaries ustring table pred usuffix))
(qlboundary (car (funcall requote (car boundaries) string)))
;; (concat (substring ustring 0 boundary) prefix))
;; t))
(qboundary (car (funcall requote boundary string)))
- (_ (cl-assert (<= qboundary qfullpos)))
+ ;;(_ (cl-assert (<= qboundary qfullpos)))
;; FIXME: this split/quote/concat business messes up the carefully
;; placed completions-common-part and completions-first-difference
;; faces. We could try within the mapcar loop to search for the
;; which only get quoted when needed by choose-completion.
(nconc
(mapcar (lambda (completion)
- (cl-assert (string-prefix-p prefix completion 'ignore-case) t)
+ ;;(cl-assert (string-prefix-p prefix completion 'ignore-case) t)
(let* ((new (substring completion (length prefix)))
(qnew (funcall qfun new))
(qprefix
;; part of the string (e.g. substitute-in-file-name).
(let ((requote
(when (completion-metadata-get metadata 'completion--unquote-requote)
- (cl-assert (functionp table))
+ ;;(cl-assert (functionp table))
(let ((new (funcall table string point 'completion--unquote)))
(setq string (pop new))
(setq table (pop new))
(setq point (pop new))
- (cl-assert (<= point (length string)))
+ ;;(cl-assert (<= point (length string)))
(pop new))))
(result
(completion--some (lambda (style)
(defun completion--done (string &optional finished message)
(let* ((exit-fun (plist-get completion-extra-properties :exit-function))
(pre-msg (and exit-fun (current-message))))
- (cl-assert (memq finished '(exact sole finished unknown)))
+ ;;(cl-assert (memq finished '(exact sole finished unknown)))
(when exit-fun
(when (eq finished 'unknown)
(setq finished
\(passing the same four arguments that it received) to do the work,
and returns whatever it does. The return value should be nil
if there was no valid completion, else t."
- (cl-assert (<= start (point)) (<= (point) end))
+ ;;(cl-assert (<= start (point)) (<= (point) end))
(funcall completion-in-region-function start end collection predicate))
(defcustom read-file-name-completion-ignore-case
(unless (equal "*Completions*" (buffer-name (window-buffer)))
(minibuffer-hide-completions)))
;; (add-hook 'pre-command-hook #'completion-in-region--prech)
- (cl-assert completion-in-region-mode-predicate)
+ ;;(cl-assert completion-in-region-mode-predicate)
(setq completion-in-region-mode--predicate
completion-in-region-mode-predicate)
(add-hook 'post-command-hook #'completion-in-region--postch)
(let ((skip (length prefix)))
(mapcar (lambda (str) (substring str skip))
comps))))))
- (cl-assert (stringp suffix))
+ ;;(cl-assert (stringp suffix))
(unless (equal suffix "")
(push suffix res)))))
(setq fixed "")))))
;;; Code:
+(defun internal-push-keymap (keymap symbol)
+ (let ((map (symbol-value symbol)))
+ (unless (memq keymap map)
+ (unless (memq 'add-keymap-witness (symbol-value symbol))
+ (setq map (make-composed-keymap nil (symbol-value symbol)))
+ (push 'add-keymap-witness (cdr map))
+ (set symbol map))
+ (push keymap (cdr map)))))
+
+(defun internal-pop-keymap (keymap symbol)
+ (let ((map (symbol-value symbol)))
+ (when (memq keymap map)
+ (setf (cdr map) (delq keymap (cdr map))))
+ (let ((tail (cddr map)))
+ (and (or (null tail) (keymapp tail))
+ (eq 'add-keymap-witness (nth 1 map))
+ (set symbol tail)))))
+
+(define-obsolete-function-alias
+ 'set-temporary-overlay-map 'set-transient-map "24.4")
+
+(defun set-transient-map (map &optional keep-pred on-exit)
+ "Set MAP as a temporary keymap taking precedence over other keymaps.
+Normally, MAP is used only once, to look up the very next key.
+However, if the optional argument KEEP-PRED is t, MAP stays
+active if a key from MAP is used. KEEP-PRED can also be a
+function of no arguments: if it returns non-nil, then MAP stays
+active.
+
+Optional arg ON-EXIT, if non-nil, specifies a function that is
+called, with no arguments, after MAP is deactivated.
+
+This uses `overriding-terminal-local-map' which takes precedence over all other
+keymaps. As usual, if no match for a key is found in MAP, the normal key
+lookup sequence then continues."
+ (let ((clearfun (make-symbol "clear-transient-map")))
+ ;; Don't use letrec, because equal (in add/remove-hook) would get trapped
+ ;; in a cycle.
+ (fset clearfun
+ (lambda ()
+ (with-demoted-errors "set-transient-map PCH: %S"
+ (unless (cond
+ ((null keep-pred) nil)
+ ((not (eq map (cadr overriding-terminal-local-map)))
+ ;; There's presumably some other transient-map in
+ ;; effect. Wait for that one to terminate before we
+ ;; remove ourselves.
+ ;; For example, if isearch and C-u both use transient
+ ;; maps, then the lifetime of the C-u should be nested
+ ;; within isearch's, so the pre-command-hook of
+ ;; isearch should be suspended during the C-u one so
+ ;; we don't exit isearch just because we hit 1 after
+ ;; C-u and that 1 exits isearch whereas it doesn't
+ ;; exit C-u.
+ t)
+ ((eq t keep-pred)
+ (eq this-command
+ (lookup-key map (this-command-keys-vector))))
+ (t (funcall keep-pred)))
+ (internal-pop-keymap map 'overriding-terminal-local-map)
+ (remove-hook 'pre-command-hook clearfun)
+ (when on-exit (funcall on-exit))
+ ;; Comment out the fset if you want to debug the GC bug.
+;;; (fset clearfun nil)
+;;; (set clearfun nil)
+ ))))
+ (add-hook 'pre-command-hook clearfun)
+ (internal-push-keymap map 'overriding-terminal-local-map)))
+
(declare-function widget-convert "wid-edit" (type &rest args))
(declare-function shell-mode "shell" ())
(list 'setq place
(list 'cons newelt place))
(require 'macroexp)
- (macroexp-let2 macroexp-copyable-p v newelt
- (gv-letplace (getter setter) place
- (funcall setter `(cons ,v ,getter))))))
+ (eval `(let ((newelt ',newelt)
+ (place ',place))
+ (macroexp-let2 macroexp-copyable-p v newelt
+ (gv-letplace (getter setter) place
+ (funcall setter (list 'cons v getter))))))))
(defmacro pop (place)
"Return the first element of PLACE's value, and remove it from the list.
(declare (indent 1) (debug t))
(cons 'if (cons cond (cons nil body))))
-(defmacro dolist (spec &rest body)
- "Loop over a list.
-Evaluate BODY with VAR bound to each car from LIST, in turn.
-Then evaluate RESULT to get return value, default nil.
-
-\(fn (VAR LIST [RESULT]) BODY...)"
- (declare (indent 1) (debug ((symbolp form &optional form) body)))
- ;; It would be cleaner to create an uninterned symbol,
- ;; but that uses a lot more space when many functions in many files
- ;; use dolist.
- ;; FIXME: This cost disappears in byte-compiled lexical-binding files.
- (let ((temp '--dolist-tail--))
- ;; This is not a reliable test, but it does not matter because both
- ;; semantics are acceptable, tho one is slightly faster with dynamic
- ;; scoping and the other is slightly faster (and has cleaner semantics)
- ;; with lexical scoping.
- (if lexical-binding
- `(let ((,temp ,(nth 1 spec)))
- (while ,temp
- (let ((,(car spec) (car ,temp)))
- ,@body
- (setq ,temp (cdr ,temp))))
- ,@(cdr (cdr spec)))
- `(let ((,temp ,(nth 1 spec))
- ,(car spec))
- (while ,temp
- (setq ,(car spec) (car ,temp))
- ,@body
- (setq ,temp (cdr ,temp)))
- ,@(if (cdr (cdr spec))
- `((setq ,(car spec) nil) ,@(cdr (cdr spec))))))))
-
(defmacro dotimes (spec &rest body)
"Loop a certain number of times.
Evaluate BODY with VAR bound to successive integers running from 0,
(declare-function scroll-bar-scale "scroll-bar" (num-denom whole))
+(defmacro with-current-buffer (buffer-or-name &rest body)
+ "Execute the forms in BODY with BUFFER-OR-NAME temporarily current.
+BUFFER-OR-NAME must be a buffer or the name of an existing buffer.
+The value returned is the value of the last form in BODY. See
+also `with-temp-buffer'."
+ (declare (indent 1) (debug t))
+ `(save-current-buffer
+ (set-buffer ,buffer-or-name)
+ ,@body))
+
(defun posn-col-row (position)
"Return the nominal column and row in POSITION, measured in characters.
The column and row values are approximations calculated from the x
file))
\f
+(defmacro with-temp-buffer (&rest body)
+ "Create a temporary buffer, and evaluate BODY there like `progn'.
+See also `with-temp-file' and `with-output-to-string'."
+ (declare (indent 0) (debug t))
+ (let ((temp-buffer (make-symbol "temp-buffer")))
+ `(let ((,temp-buffer (generate-new-buffer " *temp*")))
+ ;; FIXME: kill-buffer can change current-buffer in some odd cases.
+ (with-current-buffer ,temp-buffer
+ (unwind-protect
+ (progn ,@body)
+ (and (buffer-name ,temp-buffer)
+ (kill-buffer ,temp-buffer)))))))
+
;;;; Process stuff.
(defun process-lines (program &rest args)
(cancel-timer timer)
(use-global-map old-global-map))))
+(defmacro minibuffer-with-setup-hook (fun &rest body)
+ "Temporarily add FUN to `minibuffer-setup-hook' while executing BODY.
+BODY should use the minibuffer at most once.
+Recursive uses of the minibuffer are unaffected (FUN is not
+called additional times).
+
+This macro actually adds an auxiliary function that calls FUN,
+rather than FUN itself, to `minibuffer-setup-hook'."
+ (declare (indent 1) (debug t))
+ (let ((hook (make-symbol "setup-hook"))
+ (funsym (make-symbol "fun")))
+ `(let ((,funsym ,fun)
+ ,hook)
+ (setq ,hook
+ (lambda ()
+ ;; Clear out this hook so it does not interfere
+ ;; with any recursive minibuffer usage.
+ (remove-hook 'minibuffer-setup-hook ,hook)
+ (funcall ,funsym)))
+ (unwind-protect
+ (progn
+ (add-hook 'minibuffer-setup-hook ,hook)
+ ,@body)
+ (remove-hook 'minibuffer-setup-hook ,hook)))))
+
+(defmacro save-window-excursion (&rest body)
+ "Execute BODY, then restore previous window configuration.
+This macro saves the window configuration on the selected frame,
+executes BODY, then calls `set-window-configuration' to restore
+the saved window configuration. The return value is the last
+form in BODY. The window configuration is also restored if BODY
+exits nonlocally.
+
+BEWARE: Most uses of this macro introduce bugs.
+E.g. it should not be used to try and prevent some code from opening
+a new window, since that window may sometimes appear in another frame,
+in which case `save-window-excursion' cannot help."
+ (declare (indent 0) (debug t))
+ (let ((c (make-symbol "wconfig")))
+ `(let ((,c (current-window-configuration)))
+ (unwind-protect (progn ,@body)
+ (set-window-configuration ,c)))))
+
(defvar read-passwd-map
;; BEWARE: `defconst' would purecopy it, breaking the sharing with
;; minibuffer-local-map along the way!
\f
;;;; Lisp macros to do various things temporarily.
-(defmacro with-current-buffer (buffer-or-name &rest body)
- "Execute the forms in BODY with BUFFER-OR-NAME temporarily current.
-BUFFER-OR-NAME must be a buffer or the name of an existing buffer.
-The value returned is the value of the last form in BODY. See
-also `with-temp-buffer'."
- (declare (indent 1) (debug t))
- `(save-current-buffer
- (set-buffer ,buffer-or-name)
- ,@body))
-
(defun internal--before-with-selected-window (window)
(let ((other-frame (window-frame window)))
(list window (selected-window)
(when (buffer-live-p ,old-buffer)
(set-buffer ,old-buffer))))))
-(defmacro save-window-excursion (&rest body)
- "Execute BODY, then restore previous window configuration.
-This macro saves the window configuration on the selected frame,
-executes BODY, then calls `set-window-configuration' to restore
-the saved window configuration. The return value is the last
-form in BODY. The window configuration is also restored if BODY
-exits nonlocally.
-
-BEWARE: Most uses of this macro introduce bugs.
-E.g. it should not be used to try and prevent some code from opening
-a new window, since that window may sometimes appear in another frame,
-in which case `save-window-excursion' cannot help."
- (declare (indent 0) (debug t))
- (let ((c (make-symbol "wconfig")))
- `(let ((,c (current-window-configuration)))
- (unwind-protect (progn ,@body)
- (set-window-configuration ,c)))))
-
(defun internal-temp-output-buffer-show (buffer)
"Internal function for `with-output-to-temp-buffer'."
(with-current-buffer buffer
(message "%s" ,current-message)
(message nil)))))))
-(defmacro with-temp-buffer (&rest body)
- "Create a temporary buffer, and evaluate BODY there like `progn'.
-See also `with-temp-file' and `with-output-to-string'."
- (declare (indent 0) (debug t))
- (let ((temp-buffer (make-symbol "temp-buffer")))
- `(let ((,temp-buffer (generate-new-buffer " *temp*")))
- ;; FIXME: kill-buffer can change current-buffer in some odd cases.
- (with-current-buffer ,temp-buffer
- (unwind-protect
- (progn ,@body)
- (and (buffer-name ,temp-buffer)
- (kill-buffer ,temp-buffer)))))))
-
(defmacro with-silent-modifications (&rest body)
"Execute BODY, pretending it does not modify the buffer.
If BODY performs real modifications to the buffer's text, other
(prog1 "Error: %S"
(if format (push format body))))))
`(condition-case-unless-debug ,err
- ,(macroexp-progn body)
+ (progn ,@body)
(error (message ,format ,err) nil))))
(defmacro combine-after-change-calls (&rest body)
(put symbol 'abortfunc (or abortfunc 'kill-buffer))
(put symbol 'hookvar (or hookvar 'mail-send-hook)))
\f
-(defvar called-interactively-p-functions nil
- "Special hook called to skip special frames in `called-interactively-p'.
-The functions are called with 3 arguments: (I FRAME1 FRAME2),
-where FRAME1 is a \"current frame\", FRAME2 is the next frame,
-I is the index of the frame after FRAME2. It should return nil
-if those frames don't seem special and otherwise, it should return
-the number of frames to skip (minus 1).")
-
-(defconst internal--funcall-interactively
- (symbol-function 'funcall-interactively))
-
-(defun called-interactively-p (&optional kind)
- "Return t if the containing function was called by `call-interactively'.
-If KIND is `interactive', then only return t if the call was made
-interactively by the user, i.e. not in `noninteractive' mode nor
-when `executing-kbd-macro'.
-If KIND is `any', on the other hand, it will return t for any kind of
-interactive call, including being called as the binding of a key or
-from a keyboard macro, even in `noninteractive' mode.
-
-This function is very brittle, it may fail to return the intended result when
-the code is debugged, advised, or instrumented in some form. Some macros and
-special forms (such as `condition-case') may also sometimes wrap their bodies
-in a `lambda', so any call to `called-interactively-p' from those bodies will
-indicate whether that lambda (rather than the surrounding function) was called
-interactively.
-
-Instead of using this function, it is cleaner and more reliable to give your
-function an extra optional argument whose `interactive' spec specifies
-non-nil unconditionally (\"p\" is a good way to do this), or via
-\(not (or executing-kbd-macro noninteractive)).
-
-The only known proper use of `interactive' for KIND is in deciding
-whether to display a helpful message, or how to display it. If you're
-thinking of using it for any other purpose, it is quite likely that
-you're making a mistake. Think: what do you want to do when the
-command is called from a keyboard macro?"
- (declare (advertised-calling-convention (kind) "23.1"))
- (when (not (and (eq kind 'interactive)
- (or executing-kbd-macro noninteractive)))
- (let* ((i 1) ;; 0 is the called-interactively-p frame.
- frame nextframe
- (get-next-frame
- (lambda ()
- (setq frame nextframe)
- (setq nextframe (backtrace-frame i 'called-interactively-p))
- ;; (message "Frame %d = %S" i nextframe)
- (setq i (1+ i)))))
- (funcall get-next-frame) ;; Get the first frame.
- (while
- ;; FIXME: The edebug and advice handling should be made modular and
- ;; provided directly by edebug.el and nadvice.el.
- (progn
- ;; frame =(backtrace-frame i-2)
- ;; nextframe=(backtrace-frame i-1)
- (funcall get-next-frame)
- ;; `pcase' would be a fairly good fit here, but it sometimes moves
- ;; branches within local functions, which then messes up the
- ;; `backtrace-frame' data we get,
- (or
- ;; Skip special forms (from non-compiled code).
- (and frame (null (car frame)))
- ;; Skip also `interactive-p' (because we don't want to know if
- ;; interactive-p was called interactively but if it's caller was)
- ;; and `byte-code' (idem; this appears in subexpressions of things
- ;; like condition-case, which are wrapped in a separate bytecode
- ;; chunk).
- ;; FIXME: For lexical-binding code, this is much worse,
- ;; because the frames look like "byte-code -> funcall -> #[...]",
- ;; which is not a reliable signature.
- (memq (nth 1 frame) '(interactive-p 'byte-code))
- ;; Skip package-specific stack-frames.
- (let ((skip (run-hook-with-args-until-success
- 'called-interactively-p-functions
- i frame nextframe)))
- (pcase skip
- (`nil nil)
- (`0 t)
- (_ (setq i (+ i skip -1)) (funcall get-next-frame)))))))
- ;; Now `frame' should be "the function from which we were called".
- (pcase (cons frame nextframe)
- ;; No subr calls `interactive-p', so we can rule that out.
- (`((,_ ,(pred (lambda (f) (subrp (indirect-function f)))) . ,_) . ,_) nil)
- ;; In case #<subr funcall-interactively> without going through the
- ;; `funcall-interactively' symbol (bug#3984).
- (`(,_ . (t ,(pred (lambda (f)
- (eq internal--funcall-interactively
- (indirect-function f))))
- . ,_))
- t)))))
-
-(defun interactive-p ()
- "Return t if the containing function was run directly by user input.
-This means that the function was called with `call-interactively'
-\(which includes being called as the binding of a key)
-and input is currently coming from the keyboard (not a keyboard macro),
-and Emacs is not running in batch mode (`noninteractive' is nil).
-
-The only known proper use of `interactive-p' is in deciding whether to
-display a helpful message, or how to display it. If you're thinking
-of using it for any other purpose, it is quite likely that you're
-making a mistake. Think: what do you want to do when the command is
-called from a keyboard macro or in batch mode?
-
-To test whether your function was called with `call-interactively',
-either (i) add an extra optional argument and give it an `interactive'
-spec that specifies non-nil unconditionally (such as \"p\"); or (ii)
-use `called-interactively-p'."
- (declare (obsolete called-interactively-p "23.2"))
- (called-interactively-p 'interactive))
-
-(defun internal-push-keymap (keymap symbol)
- (let ((map (symbol-value symbol)))
- (unless (memq keymap map)
- (unless (memq 'add-keymap-witness (symbol-value symbol))
- (setq map (make-composed-keymap nil (symbol-value symbol)))
- (push 'add-keymap-witness (cdr map))
- (set symbol map))
- (push keymap (cdr map)))))
-
-(defun internal-pop-keymap (keymap symbol)
- (let ((map (symbol-value symbol)))
- (when (memq keymap map)
- (setf (cdr map) (delq keymap (cdr map))))
- (let ((tail (cddr map)))
- (and (or (null tail) (keymapp tail))
- (eq 'add-keymap-witness (nth 1 map))
- (set symbol tail)))))
-
-(define-obsolete-function-alias
- 'set-temporary-overlay-map 'set-transient-map "24.4")
-
-(defun set-transient-map (map &optional keep-pred on-exit)
- "Set MAP as a temporary keymap taking precedence over other keymaps.
-Normally, MAP is used only once, to look up the very next key.
-However, if the optional argument KEEP-PRED is t, MAP stays
-active if a key from MAP is used. KEEP-PRED can also be a
-function of no arguments: if it returns non-nil, then MAP stays
-active.
-
-Optional arg ON-EXIT, if non-nil, specifies a function that is
-called, with no arguments, after MAP is deactivated.
-
-This uses `overriding-terminal-local-map' which takes precedence over all other
-keymaps. As usual, if no match for a key is found in MAP, the normal key
-lookup sequence then continues."
- (let ((clearfun (make-symbol "clear-transient-map")))
- ;; Don't use letrec, because equal (in add/remove-hook) would get trapped
- ;; in a cycle.
- (fset clearfun
- (lambda ()
- (with-demoted-errors "set-transient-map PCH: %S"
- (unless (cond
- ((null keep-pred) nil)
- ((not (eq map (cadr overriding-terminal-local-map)))
- ;; There's presumably some other transient-map in
- ;; effect. Wait for that one to terminate before we
- ;; remove ourselves.
- ;; For example, if isearch and C-u both use transient
- ;; maps, then the lifetime of the C-u should be nested
- ;; within isearch's, so the pre-command-hook of
- ;; isearch should be suspended during the C-u one so
- ;; we don't exit isearch just because we hit 1 after
- ;; C-u and that 1 exits isearch whereas it doesn't
- ;; exit C-u.
- t)
- ((eq t keep-pred)
- (eq this-command
- (lookup-key map (this-command-keys-vector))))
- (t (funcall keep-pred)))
- (internal-pop-keymap map 'overriding-terminal-local-map)
- (remove-hook 'pre-command-hook clearfun)
- (when on-exit (funcall on-exit))
- ;; Comment out the fset if you want to debug the GC bug.
-;;; (fset clearfun nil)
-;;; (set clearfun nil)
- ))))
- (add-hook 'pre-command-hook clearfun)
- (internal-push-keymap map 'overriding-terminal-local-map)))
-
;;;; Progress reporters.
;; Progress reporter has the following structure:
--- /dev/null
+(defvar called-interactively-p-functions nil
+ "Special hook called to skip special frames in `called-interactively-p'.
+The functions are called with 3 arguments: (I FRAME1 FRAME2),
+where FRAME1 is a \"current frame\", FRAME2 is the next frame,
+I is the index of the frame after FRAME2. It should return nil
+if those frames don't seem special and otherwise, it should return
+the number of frames to skip (minus 1).")
+
+(defconst internal--funcall-interactively
+ (symbol-function 'funcall-interactively))
+
+(defun called-interactively-p (&optional kind)
+ nil)
+
+;; (defun called-interactively-p (&optional kind)
+;; "Return t if the containing function was called by `call-interactively'.
+;; If KIND is `interactive', then only return t if the call was made
+;; interactively by the user, i.e. not in `noninteractive' mode nor
+;; when `executing-kbd-macro'.
+;; If KIND is `any', on the other hand, it will return t for any kind of
+;; interactive call, including being called as the binding of a key or
+;; from a keyboard macro, even in `noninteractive' mode.
+
+;; This function is very brittle, it may fail to return the intended result when
+;; the code is debugged, advised, or instrumented in some form. Some macros and
+;; special forms (such as `condition-case') may also sometimes wrap their bodies
+;; in a `lambda', so any call to `called-interactively-p' from those bodies will
+;; indicate whether that lambda (rather than the surrounding function) was called
+;; interactively.
+
+;; Instead of using this function, it is cleaner and more reliable to give your
+;; function an extra optional argument whose `interactive' spec specifies
+;; non-nil unconditionally (\"p\" is a good way to do this), or via
+;; \(not (or executing-kbd-macro noninteractive)).
+
+;; The only known proper use of `interactive' for KIND is in deciding
+;; whether to display a helpful message, or how to display it. If you're
+;; thinking of using it for any other purpose, it is quite likely that
+;; you're making a mistake. Think: what do you want to do when the
+;; command is called from a keyboard macro?"
+;; (declare (advertised-calling-convention (kind) "23.1"))
+;; (when (not (and (eq kind 'interactive)
+;; (or executing-kbd-macro noninteractive)))
+;; (let* ((i 1) ;; 0 is the called-interactively-p frame.
+;; frame nextframe
+;; (get-next-frame
+;; (lambda ()
+;; (setq frame nextframe)
+;; (setq nextframe (backtrace-frame i 'called-interactively-p))
+;; ;; (message "Frame %d = %S" i nextframe)
+;; (setq i (1+ i)))))
+;; (funcall get-next-frame) ;; Get the first frame.
+;; (while
+;; ;; FIXME: The edebug and advice handling should be made modular and
+;; ;; provided directly by edebug.el and nadvice.el.
+;; (progn
+;; ;; frame =(backtrace-frame i-2)
+;; ;; nextframe=(backtrace-frame i-1)
+;; (funcall get-next-frame)
+;; ;; `pcase' would be a fairly good fit here, but it sometimes moves
+;; ;; branches within local functions, which then messes up the
+;; ;; `backtrace-frame' data we get,
+;; (or
+;; ;; Skip special forms (from non-compiled code).
+;; (and frame (null (car frame)))
+;; ;; Skip also `interactive-p' (because we don't want to know if
+;; ;; interactive-p was called interactively but if it's caller was)
+;; ;; and `byte-code' (idem; this appears in subexpressions of things
+;; ;; like condition-case, which are wrapped in a separate bytecode
+;; ;; chunk).
+;; ;; FIXME: For lexical-binding code, this is much worse,
+;; ;; because the frames look like "byte-code -> funcall -> #[...]",
+;; ;; which is not a reliable signature.
+;; (memq (nth 1 frame) '(interactive-p 'byte-code))
+;; ;; Skip package-specific stack-frames.
+;; (let ((skip (run-hook-with-args-until-success
+;; 'called-interactively-p-functions
+;; i frame nextframe)))
+;; (pcase skip
+;; (`nil nil)
+;; (`0 t)
+;; (_ (setq i (+ i skip -1)) (funcall get-next-frame)))))))
+;; ;; Now `frame' should be "the function from which we were called".
+;; (pcase (cons frame nextframe)
+;; ;; No subr calls `interactive-p', so we can rule that out.
+;; (`((,_ ,(pred (lambda (f) (subrp (indirect-function f)))) . ,_) . ,_) nil)
+;; ;; In case #<subr funcall-interactively> without going through the
+;; ;; `funcall-interactively' symbol (bug#3984).
+;; (`(,_ . (t ,(pred (lambda (f)
+;; (eq internal--funcall-interactively
+;; (indirect-function f))))
+;; . ,_))
+;; t)))))
+
+(defun interactive-p ()
+ "Return t if the containing function was run directly by user input.
+This means that the function was called with `call-interactively'
+\(which includes being called as the binding of a key)
+and input is currently coming from the keyboard (not a keyboard macro),
+and Emacs is not running in batch mode (`noninteractive' is nil).
+
+The only known proper use of `interactive-p' is in deciding whether to
+display a helpful message, or how to display it. If you're thinking
+of using it for any other purpose, it is quite likely that you're
+making a mistake. Think: what do you want to do when the command is
+called from a keyboard macro or in batch mode?
+
+To test whether your function was called with `call-interactively',
+either (i) add an extra optional argument and give it an `interactive'
+spec that specifies non-nil unconditionally (such as \"p\"); or (ii)
+use `called-interactively-p'."
+ (declare (obsolete called-interactively-p "23.2"))
+ (called-interactively-p 'interactive))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar called-interactively-p-functions nil
+ "Special hook called to skip special frames in `called-interactively-p'.
+The functions are called with 3 arguments: (I FRAME1 FRAME2),
+where FRAME1 is a \"current frame\", FRAME2 is the next frame,
+I is the index of the frame after FRAME2. It should return nil
+if those frames don't seem special and otherwise, it should return
+the number of frames to skip (minus 1).")
+
+(defun interactive-p ()
+ "Return t if the containing function was run directly by user input.
+This means that the function was called with `call-interactively'
+\(which includes being called as the binding of a key)
+and input is currently coming from the keyboard (not a keyboard macro),
+and Emacs is not running in batch mode (`noninteractive' is nil).
+
+The only known proper use of `interactive-p' is in deciding whether to
+display a helpful message, or how to display it. If you're thinking
+of using it for any other purpose, it is quite likely that you're
+making a mistake. Think: what do you want to do when the command is
+called from a keyboard macro or in batch mode?
+
+To test whether your function was called with `call-interactively',
+either (i) add an extra optional argument and give it an `interactive'
+spec that specifies non-nil unconditionally (such as \"p\"); or (ii)
+use `called-interactively-p'."
+ (declare (obsolete called-interactively-p "23.2"))
+ (called-interactively-p 'interactive))
(save-excursion (save-restriction ...))
usage: (save-restriction &rest BODY) */)
- (Lisp_Object body)
+ (Lisp_Object thunk)
{
register Lisp_Object val;
dynwind_begin ();
record_unwind_protect (save_restriction_restore, save_restriction_save ());
- val = Fprogn (body);
+ val = call0 (thunk);
dynwind_end ();
return val;
}
eval_fn = scm_c_public_ref ("language elisp runtime", "eval-elisp");
funcall_fn = scm_c_public_ref ("elisp-functions", "funcall");
- scm_set_smob_apply (lisp_vectorlike_tag, apply_lambda, 0, 0, 1);
+ //scm_set_smob_apply (lisp_vectorlike_tag, apply_lambda, 0, 0, 1);
}
static struct handler *handlerlist_sentinel;
/* This is to make sure that loadup.el gives a clear picture
of what files are preloaded and when. */
- if (! NILP (Vpurify_flag))
+ /*if (! NILP (Vpurify_flag))
error ("Attempt to autoload %s while preparing to dump",
- SDATA (SYMBOL_NAME (funname)));
+ SDATA (SYMBOL_NAME (funname)));*/
CHECK_SYMBOL (funname);
GCPRO3 (funname, fundef, macro_only);
/* Restore saved point and BEGV. */
dynwind_end ();
+ //scm_display (val, SCM_UNDEFINED);
+ //scm_newline (SCM_UNDEFINED);
+
/* Now eval what we just read. */
if (!NILP (macroexpand))
val = readevalloop_eager_expand_eval (val, macroexpand);
specbind (Qinhibit_free_realized_faces, Qnil);
/* Record this function, so it appears on the profiler's backtraces. */
- record_in_backtrace (Qredisplay_internal, &Qnil, 0);
+ /*record_in_backtrace (Qredisplay_internal, &Qnil, 0);*/
FOR_EACH_FRAME (tail, frame)
XFRAME (frame)->already_hscrolled_p = 0;
HCoop / bpt / emacs.git / commitdiff