+2001-11-27 Sam Steingold <sds@gnu.org>
+
+ * ansi-color.el, bookmark.el, dired.el, emerge.el, fast-lock.el
+ * lazy-lock.el, mouse-sel.el, mail/feedmail.el
+ * emacs-lisp/advice.el, emacs-lisp/checkdoc.el, emacs-lisp/ewoc.el
+ * obsolete/c-mode.el, obsolete/cplus-md.el
+ * progmodes/dcl-mode.el, progmodes/idlw-shell.el, progmodes/idlwave.el
+ * term/sun-mouse.el, textmodes/artist.el:
+ Converted backquote to the new style.
+
2001-11-27 Richard M. Stallman <rms@gnu.org>
* cus-edit.el (custom-load-symbol): Don't always load locate-library.
(eval-when-compile
- ;; We use this to preserve or protect things when modifying text
- ;; properties. Stolen from lazy-lock and font-lock. Ugly!!!
- ;; Probably most of this is not needed?
- (defmacro save-buffer-state (varlist &rest body)
- "Bind variables according to VARLIST and eval BODY restoring buffer state."
- (` (let* ((,@ (append varlist
- '((modified (buffer-modified-p)) (buffer-undo-list t)
- (inhibit-read-only t) (inhibit-point-motion-hooks t)
- before-change-functions after-change-functions
- deactivate-mark buffer-file-name buffer-file-truename))))
- (,@ body)
- (when (and (not modified) (buffer-modified-p))
- (set-buffer-modified-p nil)))))
- (put 'save-buffer-state 'lisp-indent-function 1))
+ ;; We use this to preserve or protect things when modifying text
+ ;; properties. Stolen from lazy-lock and font-lock. Ugly!!!
+ ;; Probably most of this is not needed?
+ (defmacro save-buffer-state (varlist &rest body)
+ "Bind variables according to VARLIST and eval BODY restoring buffer state."
+ `(let* (,@(append varlist
+ '((modified (buffer-modified-p)) (buffer-undo-list t)
+ (inhibit-read-only t) (inhibit-point-motion-hooks t)
+ before-change-functions after-change-functions
+ deactivate-mark buffer-file-name buffer-file-truename)))
+ ,@body
+ (when (and (not modified) (buffer-modified-p))
+ (set-buffer-modified-p nil))))
+ (put 'save-buffer-state 'lisp-indent-function 1))
(defun ansi-color-unfontify-region (beg end &rest xemacs-stuff)
"Replacement function for `font-lock-default-unfontify-region'.
Optional second arg INFO-NODE means this bookmark is at info node
INFO-NODE, so record this fact in the bookmark's entry."
(let ((the-record
- (` ((filename . (, (bookmark-buffer-file-name)))
- (front-context-string
- . (, (if (>= (- (point-max) (point)) bookmark-search-size)
- (buffer-substring-no-properties
- (point)
- (+ (point) bookmark-search-size))
- nil)))
- (rear-context-string
- . (, (if (>= (- (point) (point-min)) bookmark-search-size)
- (buffer-substring-no-properties
- (point)
- (- (point) bookmark-search-size))
- nil)))
- (position . (, (point)))
- ))))
+ `((filename . ,(bookmark-buffer-file-name))
+ (front-context-string
+ . ,(if (>= (- (point-max) (point)) bookmark-search-size)
+ (buffer-substring-no-properties
+ (point)
+ (+ (point) bookmark-search-size))
+ nil))
+ (rear-context-string
+ . ,(if (>= (- (point) (point-min)) bookmark-search-size)
+ (buffer-substring-no-properties
+ (point)
+ (- (point) bookmark-search-size))
+ nil))
+ (position . ,(point)))))
;; Now fill in the optional parts:
(ann (nth 4 record)))
(list
name
- (` ((filename . (, filename))
- (front-context-string . (, (or front-str "")))
- (rear-context-string . (, (or rear-str "")))
- (position . (, position))
- (annotation . (, ann)))))))
+ `((filename . ,filename)
+ (front-context-string . ,(or front-str ""))
+ (rear-context-string . ,(or rear-str ""))
+ (position . ,position)
+ (annotation . ,ann)))))
old-list))
(set-buffer (let ((enable-local-variables nil))
(find-file-noselect file)))
(goto-char (point-min))
- (let ((print-length nil)
+ (let ((print-length nil)
(print-level nil))
(delete-region (point-min) (point-max))
(bookmark-insert-file-format-version-stamp)
;; It should end with a noun that can be pluralized by adding `s'.
;; Return value is the number of files marked, or nil if none were marked.
(defmacro dired-mark-if (predicate msg)
- (` (let (buffer-read-only count)
- (save-excursion
- (setq count 0)
- (if (, msg) (message "Marking %ss..." (, msg)))
- (goto-char (point-min))
- (while (not (eobp))
- (if (, predicate)
- (progn
- (delete-char 1)
- (insert dired-marker-char)
- (setq count (1+ count))))
- (forward-line 1))
- (if (, msg) (message "%s %s%s %s%s."
- count
- (, msg)
- (dired-plural-s count)
- (if (eq dired-marker-char ?\040) "un" "")
- (if (eq dired-marker-char dired-del-marker)
- "flagged" "marked"))))
- (and (> count 0) count))))
+ `(let (buffer-read-only count)
+ (save-excursion
+ (setq count 0)
+ (if ,msg (message "Marking %ss..." ,msg))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if ,predicate
+ (progn
+ (delete-char 1)
+ (insert dired-marker-char)
+ (setq count (1+ count))))
+ (forward-line 1))
+ (if ,msg (message "%s %s%s %s%s."
+ count
+ ,msg
+ (dired-plural-s count)
+ (if (eq dired-marker-char ?\040) "un" "")
+ (if (eq dired-marker-char dired-del-marker)
+ "flagged" "marked"))))
+ (and (> count 0) count)))
(defmacro dired-map-over-marks (body arg &optional show-progress)
"Eval BODY with point on each marked line. Return a list of BODY's results.
;; generates an advised definition of the `documentation' function, and
;; it will enable automatic advice activation when functions get defined.
;; All of this can be undone at any time with `M-x ad-stop-advice'.
-;;
+;;
;; If you experience any strange behavior/errors etc. that you attribute to
;; Advice or to some ill-advised function do one of the following:
;; If this is a problem one can always specify an interactive form in a
;; before/around/after advice to gain control over argument values that
;; were supplied interactively.
-;;
+;;
;; Then the body forms of the various advices in the various classes of advice
;; are assembled in order. The forms of around advice L are normally part of
;; one of the forms of around advice L-1. An around advice can specify where
;; whose form depends on the type of the original function. The variable
;; `ad-return-value' will be set to its result. This variable is visible to
;; all pieces of advice which can access and modify it before it gets returned.
-;;
+;;
;; The semantic structure of advised functions that contain protected pieces
;; of advice is the same. The only difference is that `unwind-protect' forms
;; make sure that the protected advice gets executed even if some previous
;;
;; We start by defining an innocent looking function `foo' that simply
;; adds 1 to its argument X:
-;;
+;;
;; (defun foo (x)
;; "Add 1 to X."
;; (1+ x))
be returned at the end of the iteration, nil otherwise. The iteration can be
exited prematurely with `(ad-do-return [VALUE])'."
(let ((expansion
- (` (let ((ad-dO-vAr (, (car (cdr varform))))
- (, (car varform)))
- (while ad-dO-vAr
- (setq (, (car varform)) (car ad-dO-vAr))
- (,@ body)
- ;;work around a backquote bug:
- ;;(` ((,@ '(foo)) (bar))) => (append '(foo) '(((bar)))) wrong
- ;;(` ((,@ '(foo)) (, '(bar)))) => (append '(foo) (list '(bar)))
- (, '(setq ad-dO-vAr (cdr ad-dO-vAr))))
- (, (car (cdr (cdr varform))))))))
+ `(let ((ad-dO-vAr ,(car (cdr varform)))
+ ,(car varform))
+ (while ad-dO-vAr
+ (setq ,(car varform) (car ad-dO-vAr))
+ ,@body
+ ;;work around a backquote bug:
+ ;;(` ((,@ '(foo)) (bar))) => (append '(foo) '(((bar)))) wrong
+ ;;(` ((,@ '(foo)) (, '(bar)))) => (append '(foo) (list '(bar)))
+ ,'(setq ad-dO-vAr (cdr ad-dO-vAr)))
+ ,(car (cdr (cdr varform))))))
;;ok, this wastes some cons cells but only during compilation:
(if (catch 'contains-return
(ad-substitute-tree
(function (lambda (subtree)
- (cond ((eq (car-safe subtree) 'ad-dolist))
- ((eq (car-safe subtree) 'ad-do-return)
- (throw 'contains-return t)))))
+ (cond ((eq (car-safe subtree) 'ad-dolist))
+ ((eq (car-safe subtree) 'ad-do-return)
+ (throw 'contains-return t)))))
'identity body)
nil)
- (` (catch 'ad-dO-eXiT (, expansion)))
- expansion)))
+ `(catch 'ad-dO-eXiT ,expansion)
+ expansion)))
(defmacro ad-do-return (value)
- (` (throw 'ad-dO-eXiT (, value))))
+ `(throw 'ad-dO-eXiT ,value))
(if (not (get 'ad-dolist 'lisp-indent-hook))
(put 'ad-dolist 'lisp-indent-hook 1))
(let ((saved-function (intern (format "ad-real-%s" function))))
;; Make sure the compiler is loaded during macro expansion:
(require 'byte-compile "bytecomp")
- (` (if (not (fboundp '(, saved-function)))
- (progn (fset '(, saved-function) (symbol-function '(, function)))
- ;; Copy byte-compiler properties:
- (,@ (if (get function 'byte-compile)
- (` ((put '(, saved-function) 'byte-compile
- '(, (get function 'byte-compile)))))))
- (,@ (if (get function 'byte-opcode)
- (` ((put '(, saved-function) 'byte-opcode
- '(, (get function 'byte-opcode))))))))))))
+ `(if (not (fboundp ',saved-function))
+ (progn (fset ',saved-function (symbol-function ',function))
+ ;; Copy byte-compiler properties:
+ ,@(if (get function 'byte-compile)
+ `((put ',saved-function 'byte-compile
+ ',(get function 'byte-compile))))
+ ,@(if (get function 'byte-opcode)
+ `((put ',saved-function 'byte-opcode
+ ',(get function 'byte-opcode))))))))
(defun ad-save-real-definitions ()
;; Macro expansion will hardcode the values of the various byte-compiler
(defmacro ad-pushnew-advised-function (function)
"Add FUNCTION to `ad-advised-functions' unless its already there."
- (` (if (not (assoc (symbol-name (, function)) ad-advised-functions))
- (setq ad-advised-functions
- (cons (list (symbol-name (, function)))
- ad-advised-functions)))))
+ `(if (not (assoc (symbol-name ,function) ad-advised-functions))
+ (setq ad-advised-functions
+ (cons (list (symbol-name ,function))
+ ad-advised-functions))))
(defmacro ad-pop-advised-function (function)
"Remove FUNCTION from `ad-advised-functions'."
- (` (setq ad-advised-functions
- (delq (assoc (symbol-name (, function)) ad-advised-functions)
- ad-advised-functions))))
+ `(setq ad-advised-functions
+ (delq (assoc (symbol-name ,function) ad-advised-functions)
+ ad-advised-functions)))
(defmacro ad-do-advised-functions (varform &rest body)
"`ad-dolist'-style iterator that maps over `ad-advised-functions'.
BODY-FORM...)
On each iteration VAR will be bound to the name of an advised function
\(a symbol)."
- (` (ad-dolist ((, (car varform))
- ad-advised-functions
- (, (car (cdr varform))))
- (setq (, (car varform)) (intern (car (, (car varform)))))
- (,@ body))))
+ `(ad-dolist (,(car varform)
+ ad-advised-functions
+ ,(car (cdr varform)))
+ (setq ,(car varform) (intern (car ,(car varform))))
+ ,@body))
(if (not (get 'ad-do-advised-functions 'lisp-indent-hook))
(put 'ad-do-advised-functions 'lisp-indent-hook 1))
(defmacro ad-get-advice-info (function)
- (` (get (, function) 'ad-advice-info)))
+ `(get ,function 'ad-advice-info))
(defmacro ad-set-advice-info (function advice-info)
- (` (put (, function) 'ad-advice-info (, advice-info))))
+ `(put ,function 'ad-advice-info ,advice-info))
(defmacro ad-copy-advice-info (function)
- (` (ad-copy-tree (get (, function) 'ad-advice-info))))
+ `(ad-copy-tree (get ,function 'ad-advice-info)))
(defmacro ad-is-advised (function)
"Return non-nil if FUNCTION has any advice info associated with it.
(defmacro ad-get-advice-info-field (function field)
"Retrieve the value of the advice info FIELD of FUNCTION."
- (` (cdr (assq (, field) (ad-get-advice-info (, function))))))
+ `(cdr (assq ,field (ad-get-advice-info ,function))))
(defun ad-set-advice-info-field (function field value)
"Destructively modify VALUE of the advice info FIELD of FUNCTION."
(defvar ad-activate-on-top-level t)
(defmacro ad-with-auto-activation-disabled (&rest body)
- (` (let ((ad-activate-on-top-level nil))
- (,@ body))))
+ `(let ((ad-activate-on-top-level nil))
+ ,@body))
(defun ad-safe-fset (symbol definition)
"A safe `fset' which will never call `ad-activate-internal' recursively."
(intern (format "ad-Orig-%s" function)))
(defmacro ad-get-orig-definition (function)
- (` (let ((origname (ad-get-advice-info-field (, function) 'origname)))
- (if (fboundp origname)
- (symbol-function origname)))))
+ `(let ((origname (ad-get-advice-info-field ,function 'origname)))
+ (if (fboundp origname)
+ (symbol-function origname))))
(defmacro ad-set-orig-definition (function definition)
- (` (ad-safe-fset
- (ad-get-advice-info-field function 'origname) (, definition))))
+ `(ad-safe-fset
+ (ad-get-advice-info-field function 'origname) ,definition))
(defmacro ad-clear-orig-definition (function)
- (` (fmakunbound (ad-get-advice-info-field (, function) 'origname))))
+ `(fmakunbound (ad-get-advice-info-field ,function 'origname)))
;; @@ Interactive input functions:
(defmacro ad-find-advice (function class name)
"Find the first advice of FUNCTION in CLASS with NAME."
- (` (assq (, name) (ad-get-advice-info-field (, function) (, class)))))
+ `(assq ,name (ad-get-advice-info-field ,function ,class)))
(defun ad-advice-position (function class name)
"Return position of first advice of FUNCTION in CLASS with NAME."
(defmacro ad-macrofy (definition)
"Take a lambda function DEFINITION and make a macro out of it."
- (` (cons 'macro (, definition))))
+ `(cons 'macro ,definition))
(defmacro ad-lambdafy (definition)
"Take a macro function DEFINITION and make a lambda out of it."
- (` (cdr (, definition))))
+ `(cdr ,definition))
;; There is no way to determine whether some subr is a special form or not,
;; hence we need this list (which is probably out of date):
(defmacro ad-macro-p (definition)
;;"non-nil if DEFINITION is a macro."
- (` (eq (car-safe (, definition)) 'macro)))
+ `(eq (car-safe ,definition) 'macro))
(defmacro ad-lambda-p (definition)
;;"non-nil if DEFINITION is a lambda expression."
- (` (eq (car-safe (, definition)) 'lambda)))
+ `(eq (car-safe ,definition) 'lambda))
;; see ad-make-advice for the format of advice definitions:
(defmacro ad-advice-p (definition)
;;"non-nil if DEFINITION is a piece of advice."
- (` (eq (car-safe (, definition)) 'advice)))
+ `(eq (car-safe ,definition) 'advice))
;; Emacs/Lemacs cross-compatibility
;; (compiled-function-p is an obsolete function in Emacs):
(defmacro ad-compiled-p (definition)
"Return non-nil if DEFINITION is a compiled byte-code object."
- (` (or (byte-code-function-p (, definition))
- (and (ad-macro-p (, definition))
- (byte-code-function-p (ad-lambdafy (, definition)))))))
+ `(or (byte-code-function-p ,definition)
+ (and (ad-macro-p ,definition)
+ (byte-code-function-p (ad-lambdafy ,definition)))))
(defmacro ad-compiled-code (compiled-definition)
"Return the byte-code object of a COMPILED-DEFINITION."
- (` (if (ad-macro-p (, compiled-definition))
- (ad-lambdafy (, compiled-definition))
- (, compiled-definition))))
+ `(if (ad-macro-p ,compiled-definition)
+ (ad-lambdafy ,compiled-definition)
+ ,compiled-definition))
(defun ad-lambda-expression (definition)
"Return the lambda expression of a function/macro/advice DEFINITION."
;; Store subr-args as `((arg1 arg2 ...))' so I can distinguish
;; a defined empty arglist `(nil)' from an undefined arglist:
(defmacro ad-define-subr-args (subr arglist)
- (` (put (, subr) 'ad-subr-arglist (list (, arglist)))))
+ `(put ,subr 'ad-subr-arglist (list ,arglist)))
(defmacro ad-undefine-subr-args (subr)
- (` (put (, subr) 'ad-subr-arglist nil)))
+ `(put ,subr 'ad-subr-arglist nil))
(defmacro ad-subr-args-defined-p (subr)
- (` (get (, subr) 'ad-subr-arglist)))
+ `(get ,subr 'ad-subr-arglist))
(defmacro ad-get-subr-args (subr)
- (` (car (get (, subr) 'ad-subr-arglist))))
+ `(car (get ,subr 'ad-subr-arglist)))
(defun ad-subr-arglist (subr-name)
"Retrieve arglist of the subr with SUBR-NAME.
`required', `optional' or `rest' depending on the type of the argument."
(let* ((parsed-arglist (ad-parse-arglist arglist))
(rest (nth 2 parsed-arglist)))
- (` (list
- (,@ (mapcar (function
- (lambda (req)
- (` (list '(, req) (, req) 'required))))
- (nth 0 parsed-arglist)))
- (,@ (mapcar (function
- (lambda (opt)
- (` (list '(, opt) (, opt) 'optional))))
- (nth 1 parsed-arglist)))
- (,@ (if rest (list (` (list '(, rest) (, rest) 'rest)))))
- ))))
+ `(list
+ ,@(mapcar (function
+ (lambda (req)
+ `(list ',req ,req 'required)))
+ (nth 0 parsed-arglist))
+ ,@(mapcar (function
+ (lambda (opt)
+ `(list ',opt ,opt 'optional)))
+ (nth 1 parsed-arglist))
+ ,@(if rest (list `(list ',rest ,rest 'rest))))))
(defun ad-arg-binding-field (binding field)
(cond ((eq field 'name) (car binding))
(defun ad-element-access (position list)
(cond ((= position 0) (list 'car list))
- ((= position 1) (` (car (cdr (, list)))))
+ ((= position 1) `(car (cdr ,list)))
(t (list 'nth position list))))
(defun ad-access-argument (arglist index)
(let ((argument-access (ad-access-argument arglist index)))
(cond ((consp argument-access)
;; should this check whether there actually is something to set?
- (` (setcar (, (ad-list-access
- (car argument-access) (car (cdr argument-access))))
- (, value-form))))
+ `(setcar ,(ad-list-access
+ (car argument-access) (car (cdr argument-access)))
+ ,value-form))
(argument-access
- (` (setq (, argument-access) (, value-form))))
+ `(setq ,argument-access ,value-form))
(t (error "ad-set-argument: No argument at position %d of `%s'"
index arglist)))))
(rest-arg (nth 2 parsed-arglist))
args-form)
(if (< index (length reqopt-args))
- (setq args-form (` (list (,@ (nthcdr index reqopt-args))))))
+ (setq args-form `(list ,@(nthcdr index reqopt-args))))
(if rest-arg
(if args-form
- (setq args-form (` (nconc (, args-form) (, rest-arg))))
- (setq args-form (ad-list-access (- index (length reqopt-args))
- rest-arg))))
+ (setq args-form `(nconc ,args-form ,rest-arg))
+ (setq args-form (ad-list-access (- index (length reqopt-args))
+ rest-arg))))
args-form))
(defun ad-set-arguments (arglist index values-form)
arglist index
(ad-element-access values-index 'ad-vAlUeS))
set-forms))
- (setq set-forms
- (cons (if (= (car argument-access) 0)
- (list 'setq
- (car (cdr argument-access))
- (ad-list-access values-index 'ad-vAlUeS))
- (list 'setcdr
- (ad-list-access (1- (car argument-access))
- (car (cdr argument-access)))
- (ad-list-access values-index 'ad-vAlUeS)))
- set-forms))
- ;; terminate loop
- (setq arglist nil))
+ (setq set-forms
+ (cons (if (= (car argument-access) 0)
+ (list 'setq
+ (car (cdr argument-access))
+ (ad-list-access values-index 'ad-vAlUeS))
+ (list 'setcdr
+ (ad-list-access (1- (car argument-access))
+ (car (cdr argument-access)))
+ (ad-list-access values-index 'ad-vAlUeS)))
+ set-forms))
+ ;; terminate loop
+ (setq arglist nil))
(setq index (1+ index))
(setq values-index (1+ values-index)))
(if (null set-forms)
(error "ad-set-arguments: No argument at position %d of `%s'"
index arglist)
- (if (= (length set-forms) 1)
- ;; For exactly one set-form we can use values-form directly,...
- (ad-substitute-tree
- (function (lambda (form) (eq form 'ad-vAlUeS)))
- (function (lambda (form) values-form))
- (car set-forms))
- ;; ...if we have more we have to bind it to a variable:
- (` (let ((ad-vAlUeS (, values-form)))
- (,@ (reverse set-forms))
- ;; work around the old backquote bug:
- (, 'ad-vAlUeS)))))))
+ (if (= (length set-forms) 1)
+ ;; For exactly one set-form we can use values-form directly,...
+ (ad-substitute-tree
+ (function (lambda (form) (eq form 'ad-vAlUeS)))
+ (function (lambda (form) values-form))
+ (car set-forms))
+ ;; ...if we have more we have to bind it to a variable:
+ `(let ((ad-vAlUeS ,values-form))
+ ,@(reverse set-forms)
+ ;; work around the old backquote bug:
+ ,'ad-vAlUeS)))))
(defun ad-insert-argument-access-forms (definition arglist)
"Expands arg-access text macros in DEFINITION according to ARGLIST."
((ad-interactive-form origdef)
(if (and (symbolp function) (get function 'elp-info))
(interactive-form (aref (get function 'elp-info) 2))
- (ad-interactive-form origdef)))
+ (ad-interactive-form origdef)))
;; Otherwise we must have a subr: make it interactive if
;; we have to and initialize required arguments in case
;; it is called interactively:
- (orig-interactive-p
+ (orig-interactive-p
(interactive-form origdef))))
(orig-form
(cond ((or orig-special-form-p orig-macro-p)
;; in order to do proper prompting:
`(if (interactive-p)
(call-interactively ',origname)
- ,(ad-make-mapped-call orig-arglist
+ ,(ad-make-mapped-call orig-arglist
advised-arglist
origname)))
;; And now for normal functions and non-interactive subrs
(ad-get-enabled-advices function 'after)))))
(defun ad-assemble-advised-definition
- (type args docstring interactive orig &optional befores arounds afters)
+ (type args docstring interactive orig &optional befores arounds afters)
"Assembles an original and its advices into an advised function.
It constructs a function or macro definition according to TYPE which has to
(let (before-forms around-form around-form-protected after-forms definition)
(ad-dolist (advice befores)
- (cond ((and (ad-advice-protected advice)
- before-forms)
- (setq before-forms
- (` ((unwind-protect
- (, (ad-prognify before-forms))
- (,@ (ad-body-forms
- (ad-advice-definition advice))))))))
- (t (setq before-forms
- (append before-forms
- (ad-body-forms (ad-advice-definition advice)))))))
-
- (setq around-form (` (setq ad-return-value (, orig))))
+ (cond ((and (ad-advice-protected advice)
+ before-forms)
+ (setq before-forms
+ `((unwind-protect
+ ,(ad-prognify before-forms)
+ ,@(ad-body-forms
+ (ad-advice-definition advice))))))
+ (t (setq before-forms
+ (append before-forms
+ (ad-body-forms (ad-advice-definition advice)))))))
+
+ (setq around-form `(setq ad-return-value ,orig))
(ad-dolist (advice (reverse arounds))
- ;; If any of the around advices is protected then we
- ;; protect the complete around advice onion:
- (if (ad-advice-protected advice)
- (setq around-form-protected t))
- (setq around-form
- (ad-substitute-tree
- (function (lambda (form) (eq form 'ad-do-it)))
- (function (lambda (form) around-form))
- (ad-prognify (ad-body-forms (ad-advice-definition advice))))))
+ ;; If any of the around advices is protected then we
+ ;; protect the complete around advice onion:
+ (if (ad-advice-protected advice)
+ (setq around-form-protected t))
+ (setq around-form
+ (ad-substitute-tree
+ (function (lambda (form) (eq form 'ad-do-it)))
+ (function (lambda (form) around-form))
+ (ad-prognify (ad-body-forms (ad-advice-definition advice))))))
(setq after-forms
(if (and around-form-protected before-forms)
- (` ((unwind-protect
- (, (ad-prognify before-forms))
- (, around-form))))
- (append before-forms (list around-form))))
+ `((unwind-protect
+ ,(ad-prognify before-forms)
+ ,around-form))
+ (append before-forms (list around-form))))
(ad-dolist (advice afters)
- (cond ((and (ad-advice-protected advice)
- after-forms)
- (setq after-forms
- (` ((unwind-protect
- (, (ad-prognify after-forms))
- (,@ (ad-body-forms
- (ad-advice-definition advice))))))))
- (t (setq after-forms
- (append after-forms
- (ad-body-forms (ad-advice-definition advice)))))))
+ (cond ((and (ad-advice-protected advice)
+ after-forms)
+ (setq after-forms
+ `((unwind-protect
+ ,(ad-prognify after-forms)
+ ,@(ad-body-forms
+ (ad-advice-definition advice))))))
+ (t (setq after-forms
+ (append after-forms
+ (ad-body-forms (ad-advice-definition advice)))))))
(setq definition
- (` ((,@ (if (memq type '(macro special-form)) '(macro)))
- lambda
- (, args)
- (,@ (if docstring (list docstring)))
- (,@ (if interactive (list interactive)))
- (let (ad-return-value)
- (,@ after-forms)
- (, (if (eq type 'special-form)
- '(list 'quote ad-return-value)
- 'ad-return-value))))))
+ `(,@(if (memq type '(macro special-form)) '(macro))
+ lambda
+ ,args
+ ,@(if docstring (list docstring))
+ ,@(if interactive (list interactive))
+ (let (ad-return-value)
+ ,@after-forms
+ ,(if (eq type 'special-form)
+ '(list 'quote ad-return-value)
+ 'ad-return-value))))
(ad-insert-argument-access-forms definition args)))
;; a lot cheaper than reconstructing an advised definition.
(defmacro ad-get-cache-definition (function)
- (` (car (ad-get-advice-info-field (, function) 'cache))))
+ `(car (ad-get-advice-info-field ,function 'cache)))
(defmacro ad-get-cache-id (function)
- (` (cdr (ad-get-advice-info-field (, function) 'cache))))
+ `(cdr (ad-get-advice-info-field ,function 'cache)))
(defmacro ad-set-cache (function definition id)
- (` (ad-set-advice-info-field
- (, function) 'cache (cons (, definition) (, id)))))
+ `(ad-set-advice-info-field
+ ,function 'cache (cons ,definition ,id)))
(defun ad-clear-cache (function)
"Clears a previously cached advised definition of FUNCTION.
(symbol-function 'ad-make-origname))
(frozen-definition
(unwind-protect
- (progn
- ;; Make sure we construct a proper docstring:
- (ad-safe-fset 'ad-make-advised-definition-docstring
- 'ad-make-freeze-docstring)
- ;; Make sure `unique-origname' is used as the origname:
- (ad-safe-fset 'ad-make-origname (lambda (x) unique-origname))
- ;; No we reset all current advice information to nil and
- ;; generate an advised definition that's solely determined
- ;; by ADVICE and the current origdef of FUNCTION:
- (ad-set-advice-info function nil)
- (ad-add-advice function advice class position)
- ;; The following will provide proper real docstrings as
- ;; well as a definition that will make the compiler happy:
- (ad-set-orig-definition function orig-definition)
- (ad-make-advised-definition function))
+ (progn
+ ;; Make sure we construct a proper docstring:
+ (ad-safe-fset 'ad-make-advised-definition-docstring
+ 'ad-make-freeze-docstring)
+ ;; Make sure `unique-origname' is used as the origname:
+ (ad-safe-fset 'ad-make-origname (lambda (x) unique-origname))
+ ;; No we reset all current advice information to nil and
+ ;; generate an advised definition that's solely determined
+ ;; by ADVICE and the current origdef of FUNCTION:
+ (ad-set-advice-info function nil)
+ (ad-add-advice function advice class position)
+ ;; The following will provide proper real docstrings as
+ ;; well as a definition that will make the compiler happy:
+ (ad-set-orig-definition function orig-definition)
+ (ad-make-advised-definition function))
;; Restore the old advice state:
(ad-set-advice-info function old-advice-info)
;; Restore functions:
(let* ((macro-p (ad-macro-p frozen-definition))
(body (cdr (if macro-p
(ad-lambdafy frozen-definition)
- frozen-definition))))
- (` (progn
- (if (not (fboundp '(, unique-origname)))
- (fset '(, unique-origname)
- ;; avoid infinite recursion in case the function
- ;; we want to freeze is already advised:
- (or (ad-get-orig-definition '(, function))
- (symbol-function '(, function)))))
- ((, (if macro-p 'defmacro 'defun))
- (, function)
- (,@ body))))))))
+ frozen-definition))))
+ `(progn
+ (if (not (fboundp ',unique-origname))
+ (fset ',unique-origname
+ ;; avoid infinite recursion in case the function
+ ;; we want to freeze is already advised:
+ (or (ad-get-orig-definition ',function)
+ (symbol-function ',function))))
+ (,(if macro-p 'defmacro 'defun)
+ ,function
+ ,@body))))))
;; @@ Activation and definition handling:
(let* ((class (car args))
(name (if (not (ad-class-p class))
(error "defadvice: Invalid advice class: %s" class)
- (nth 1 args)))
+ (nth 1 args)))
(position (if (not (ad-name-p name))
(error "defadvice: Invalid advice name: %s" name)
- (setq args (nthcdr 2 args))
- (if (ad-position-p (car args))
- (prog1 (car args)
- (setq args (cdr args))))))
+ (setq args (nthcdr 2 args))
+ (if (ad-position-p (car args))
+ (prog1 (car args)
+ (setq args (cdr args))))))
(arglist (if (listp (car args))
(prog1 (car args)
(setq args (cdr args)))))
(mapcar
(function
(lambda (flag)
- (let ((completion
- (try-completion (symbol-name flag) ad-defadvice-flags)))
- (cond ((eq completion t) flag)
- ((assoc completion ad-defadvice-flags)
- (intern completion))
- (t (error "defadvice: Invalid or ambiguous flag: %s"
- flag))))))
+ (let ((completion
+ (try-completion (symbol-name flag) ad-defadvice-flags)))
+ (cond ((eq completion t) flag)
+ ((assoc completion ad-defadvice-flags)
+ (intern completion))
+ (t (error "defadvice: Invalid or ambiguous flag: %s"
+ flag))))))
args))
(advice (ad-make-advice
name (memq 'protect flags)
(not (memq 'disable flags))
- (` (advice lambda (, arglist) (,@ body)))))
+ `(advice lambda ,arglist ,@body)))
(preactivation (if (memq 'preactivate flags)
(ad-preactivate-advice
function advice class position))))
;; jwz's idea: Freeze the advised definition into a dumpable
;; defun/defmacro whose docs can be written to the DOC file:
(ad-make-freeze-definition function advice class position)
- ;; the normal case:
- (` (progn
- (ad-add-advice '(, function) '(, advice) '(, class) '(, position))
- (,@ (if preactivation
- (` ((ad-set-cache
- '(, function)
- ;; the function will get compiled:
- (, (cond ((ad-macro-p (car preactivation))
- (` (ad-macrofy
- (function
- (, (ad-lambdafy
- (car preactivation)))))))
- (t (` (function
- (, (car preactivation)))))))
- '(, (car (cdr preactivation))))))))
- (,@ (if (memq 'activate flags)
- (` ((ad-activate '(, function)
- (, (if (memq 'compile flags) t)))))))
- '(, function))))))
+ ;; the normal case:
+ `(progn
+ (ad-add-advice ',function ',advice ',class ',position)
+ ,@(if preactivation
+ `((ad-set-cache
+ ',function
+ ;; the function will get compiled:
+ ,(cond ((ad-macro-p (car preactivation))
+ `(ad-macrofy
+ (function
+ ,(ad-lambdafy
+ (car preactivation)))))
+ (t `(function
+ ,(car preactivation))))
+ ',(car (cdr preactivation)))))
+ ,@(if (memq 'activate flags)
+ `((ad-activate ',function
+ ,(if (memq 'compile flags) t))))
+ ',function))))
;; @@ Tools:
(current-bindings
(mapcar (function
(lambda (function)
- (setq index (1+ index))
- (list (intern (format "ad-oRiGdEf-%d" index))
- (` (symbol-function '(, function))))))
+ (setq index (1+ index))
+ (list (intern (format "ad-oRiGdEf-%d" index))
+ `(symbol-function ',function))))
functions)))
- (` (let (, current-bindings)
- (unwind-protect
- (progn
- (,@ (progn
- ;; Make forms to redefine functions to their
- ;; original definitions if they are advised:
- (setq index -1)
- (mapcar
- (function
- (lambda (function)
- (setq index (1+ index))
- (` (ad-safe-fset
- '(, function)
- (or (ad-get-orig-definition '(, function))
- (, (car (nth index current-bindings))))))))
- functions)))
- (,@ body))
- (,@ (progn
- ;; Make forms to back-define functions to the definitions
- ;; they had outside this macro call:
- (setq index -1)
- (mapcar
- (function
- (lambda (function)
- (setq index (1+ index))
- (` (ad-safe-fset
- '(, function)
- (, (car (nth index current-bindings)))))))
- functions))))))))
+ `(let ,current-bindings
+ (unwind-protect
+ (progn
+ ,@(progn
+ ;; Make forms to redefine functions to their
+ ;; original definitions if they are advised:
+ (setq index -1)
+ (mapcar
+ (function
+ (lambda (function)
+ (setq index (1+ index))
+ `(ad-safe-fset
+ ',function
+ (or (ad-get-orig-definition ',function)
+ ,(car (nth index current-bindings))))))
+ functions))
+ ,@body)
+ ,@(progn
+ ;; Make forms to back-define functions to the definitions
+ ;; they had outside this macro call:
+ (setq index -1)
+ (mapcar
+ (function
+ (lambda (function)
+ (setq index (1+ index))
+ `(ad-safe-fset
+ ',function
+ ,(car (nth index current-bindings)))))
+ functions))))))
(if (not (get 'ad-with-originals 'lisp-indent-hook))
(put 'ad-with-originals 'lisp-indent-hook 1))
;; From custom web page for compatibility between versions of custom:
(eval-and-compile
- (condition-case ()
- (require 'custom)
- (error nil))
- (if (and (featurep 'custom) (fboundp 'custom-declare-variable))
- nil ;; We've got what we needed
- ;; We have the old custom-library, hack around it!
- (defmacro defgroup (&rest args)
- nil)
- (defmacro custom-add-option (&rest args)
- nil)
- (defmacro defcustom (var value doc &rest args)
- (` (defvar (, var) (, value) (, doc))))))
+ (condition-case ()
+ (require 'custom)
+ (error nil))
+ (if (and (featurep 'custom) (fboundp 'custom-declare-variable))
+ nil ;; We've got what we needed
+ ;; We have the old custom-library, hack around it!
+ (defmacro defgroup (&rest args)
+ nil)
+ (defmacro custom-add-option (&rest args)
+ nil)
+ (defmacro defcustom (var value doc &rest args)
+ `(defvar ,var ,value ,doc))))
(defcustom checkdoc-autofix-flag 'semiautomatic
"*Non-nil means attempt auto-fixing of doc strings.
Return value of last form in FORMS."
(let ((old-buffer (make-symbol "old-buffer"))
(hnd (make-symbol "ewoc")))
- (` (let* (((, old-buffer) (current-buffer))
- ((, hnd) (, ewoc))
- (dll (ewoc--dll (, hnd)))
- (,@ varlist))
- (set-buffer (ewoc--buffer (, hnd)))
- (unwind-protect
- (progn (,@ forms))
- (set-buffer (, old-buffer)))))))
+ `(let* ((,old-buffer (current-buffer))
+ (,hnd ,ewoc)
+ (dll (ewoc--dll ,hnd))
+ ,@varlist)
+ (set-buffer (ewoc--buffer ,hnd))
+ (unwind-protect
+ (progn ,@forms)
+ (set-buffer ,old-buffer)))))
(defmacro ewoc--set-buffer-bind-dll (ewoc &rest forms)
`(ewoc--set-buffer-bind-dll-let* ,ewoc nil ,@forms))
(defmacro emerge-eval-in-buffer (buffer &rest forms)
"Macro to switch to BUFFER, evaluate FORMS, returns to original buffer.
Differs from `save-excursion' in that it doesn't save the point and mark."
- (` (let ((StartBuffer (current-buffer)))
+ `(let ((StartBuffer (current-buffer)))
(unwind-protect
- (progn
- (set-buffer (, buffer))
- (,@ forms))
- (set-buffer StartBuffer)))))
+ (progn
+ (set-buffer ,buffer)
+ ,@forms)
+ (set-buffer StartBuffer))))
(defmacro emerge-defvar-local (var value doc)
"Defines SYMBOL as an advertised variable.
the variable. Also sets the `preserved' property, so that
`kill-all-local-variables' (called by major-mode setting commands)
won't destroy Emerge control variables."
- (` (progn
- (defvar (, var) (, value) (, doc))
- (make-variable-buffer-local '(, var))
- (put '(, var) 'preserved t))))
+ `(progn
+ (defvar ,var ,value ,doc)
+ (make-variable-buffer-local ',var)
+ (put ',var 'preserved t)))
;; Add entries to minor-mode-alist so that emerge modes show correctly
(defvar emerge-minor-modes-list
;;; Setup functions for two-file mode.
(defun emerge-files-internal (file-A file-B &optional startup-hooks quit-hooks
- output-file)
+ output-file)
(if (not (file-readable-p file-A))
(error "File `%s' does not exist or is not readable" file-A))
(if (not (file-readable-p file-B))
(if temp
(setq file-A temp
startup-hooks
- (cons (` (lambda () (delete-file (, file-A))))
+ (cons `(lambda () (delete-file ,file-A))
startup-hooks))
- ;; Verify that the file matches the buffer
- (emerge-verify-file-buffer))))
+ ;; Verify that the file matches the buffer
+ (emerge-verify-file-buffer))))
(emerge-eval-in-buffer
buffer-B
(widen)
(if temp
(setq file-B temp
startup-hooks
- (cons (` (lambda () (delete-file (, file-B))))
+ (cons `(lambda () (delete-file ,file-B))
startup-hooks))
- ;; Verify that the file matches the buffer
- (emerge-verify-file-buffer))))
+ ;; Verify that the file matches the buffer
+ (emerge-verify-file-buffer))))
(emerge-setup buffer-A file-A buffer-B file-B startup-hooks quit-hooks
output-file)))
(if temp
(setq file-A temp
startup-hooks
- (cons (` (lambda () (delete-file (, file-A))))
+ (cons `(lambda () (delete-file ,file-A))
startup-hooks))
- ;; Verify that the file matches the buffer
- (emerge-verify-file-buffer))))
+ ;; Verify that the file matches the buffer
+ (emerge-verify-file-buffer))))
(emerge-eval-in-buffer
buffer-B
(widen)
(if temp
(setq file-B temp
startup-hooks
- (cons (` (lambda () (delete-file (, file-B))))
+ (cons `(lambda () (delete-file ,file-B))
startup-hooks))
- ;; Verify that the file matches the buffer
- (emerge-verify-file-buffer))))
+ ;; Verify that the file matches the buffer
+ (emerge-verify-file-buffer))))
(emerge-eval-in-buffer
buffer-ancestor
(widen)
(if temp
(setq file-ancestor temp
startup-hooks
- (cons (` (lambda () (delete-file (, file-ancestor))))
+ (cons `(lambda () (delete-file ,file-ancestor))
startup-hooks))
- ;; Verify that the file matches the buffer
- (emerge-verify-file-buffer))))
+ ;; Verify that the file matches the buffer
+ (emerge-verify-file-buffer))))
(emerge-setup-with-ancestor buffer-A file-A buffer-B file-B
buffer-ancestor file-ancestor
startup-hooks quit-hooks output-file)))
(emerge-read-file-name "Output file" emerge-last-dir-output
f f nil)))))
(if file-out
- (add-hook 'quit-hooks (` (lambda () (emerge-files-exit (, file-out))))))
+ (add-hook 'quit-hooks `(lambda () (emerge-files-exit ,file-out))))
(emerge-files-internal
file-A file-B startup-hooks
quit-hooks
(emerge-read-file-name "Output file" emerge-last-dir-output
f f nil)))))
(if file-out
- (add-hook 'quit-hooks (` (lambda () (emerge-files-exit (, file-out))))))
+ (add-hook 'quit-hooks `(lambda () (emerge-files-exit ,file-out))))
(emerge-files-with-ancestor-internal
file-A file-B file-ancestor startup-hooks
quit-hooks
(write-region (point-min) (point-max) emerge-file-B nil 'no-message))
(emerge-setup (get-buffer buffer-A) emerge-file-A
(get-buffer buffer-B) emerge-file-B
- (cons (` (lambda ()
- (delete-file (, emerge-file-A))
- (delete-file (, emerge-file-B))))
+ (cons `(lambda ()
+ (delete-file ,emerge-file-A)
+ (delete-file ,emerge-file-B))
startup-hooks)
quit-hooks
nil)))
;;;###autoload
(defun emerge-buffers-with-ancestor (buffer-A buffer-B buffer-ancestor
- &optional startup-hooks
- quit-hooks)
+ &optional startup-hooks
+ quit-hooks)
"Run Emerge on two buffers, giving another buffer as the ancestor."
(interactive
"bBuffer A to merge: \nbBuffer B to merge: \nbAncestor buffer: ")
(get-buffer buffer-B) emerge-file-B
(get-buffer buffer-ancestor)
emerge-file-ancestor
- (cons (` (lambda ()
- (delete-file (, emerge-file-A))
- (delete-file (, emerge-file-B))
- (delete-file
- (, emerge-file-ancestor))))
+ (cons `(lambda ()
+ (delete-file ,emerge-file-A)
+ (delete-file ,emerge-file-B)
+ (delete-file
+ ,emerge-file-ancestor))
startup-hooks)
quit-hooks
nil)))
(setq command-line-args-left (nthcdr 3 command-line-args-left))
(emerge-files-internal
file-a file-b nil
- (list (` (lambda () (emerge-command-exit (, file-out))))))))
+ (list `(lambda () (emerge-command-exit ,file-out))))))
;;;###autoload
(defun emerge-files-with-ancestor-command ()
(setq file-anc (nth 1 command-line-args-left))
(setq file-out (nth 4 command-line-args-left))
(setq command-line-args-left (nthcdr 5 command-line-args-left)))
- ;; arguments are "file-a file-b ancestor file-out"
- (setq file-a (nth 0 command-line-args-left))
- (setq file-b (nth 1 command-line-args-left))
- (setq file-anc (nth 2 command-line-args-left))
- (setq file-out (nth 3 command-line-args-left))
- (setq command-line-args-left (nthcdr 4 command-line-args-left)))
+ ;; arguments are "file-a file-b ancestor file-out"
+ (setq file-a (nth 0 command-line-args-left))
+ (setq file-b (nth 1 command-line-args-left))
+ (setq file-anc (nth 2 command-line-args-left))
+ (setq file-out (nth 3 command-line-args-left))
+ (setq command-line-args-left (nthcdr 4 command-line-args-left)))
(emerge-files-with-ancestor-internal
file-a file-b file-anc nil
- (list (` (lambda () (emerge-command-exit (, file-out))))))))
+ (list `(lambda () (emerge-command-exit ,file-out))))))
(defun emerge-command-exit (file-out)
(emerge-write-and-delete file-out)
(setq emerge-file-out file-out)
(emerge-files-internal
file-a file-b nil
- (list (` (lambda () (emerge-remote-exit (, file-out) '(, emerge-exit-func)))))
+ (list `(lambda () (emerge-remote-exit ,file-out ',emerge-exit-func)))
file-out)
(throw 'client-wait nil))
(setq emerge-file-out file-out)
(emerge-files-with-ancestor-internal
file-a file-b file-anc nil
- (list (` (lambda () (emerge-remote-exit (, file-out) '(, emerge-exit-func)))))
+ (list `(lambda () (emerge-remote-exit ,file-out ',emerge-exit-func)))
file-out)
(throw 'client-wait nil))
(emerge-revisions-internal
file revision-A revision-B startup-hooks
(if arg
- (cons (` (lambda ()
- (shell-command
- (, (format "%s %s" emerge-rcs-ci-program file)))))
+ (cons `(lambda ()
+ (shell-command
+ ,(format "%s %s" emerge-rcs-ci-program file)))
quit-hooks)
- quit-hooks)))
+ quit-hooks)))
;;;###autoload
(defun emerge-revisions-with-ancestor (arg file revision-A
- revision-B ancestor
- &optional
- startup-hooks quit-hooks)
+ revision-B ancestor
+ &optional
+ startup-hooks quit-hooks)
"Emerge two RCS revisions of a file, with another revision as ancestor."
(interactive
(list current-prefix-arg
file revision-A revision-B ancestor startup-hooks
(if arg
(let ((cmd ))
- (cons (` (lambda ()
- (shell-command
- (, (format "%s %s" emerge-rcs-ci-program file)))))
+ (cons `(lambda ()
+ (shell-command
+ ,(format "%s %s" emerge-rcs-ci-program file)))
quit-hooks))
- quit-hooks)))
+ quit-hooks)))
(defun emerge-revisions-internal (file revision-A revision-B &optional
- startup-hooks quit-hooks output-file)
+ startup-hooks quit-hooks output-file)
(let ((buffer-A (get-buffer-create (format "%s,%s" file revision-A)))
(buffer-B (get-buffer-create (format "%s,%s" file revision-B)))
(emerge-file-A (emerge-make-temp-file "A"))
;; Do the merge
(emerge-setup buffer-A emerge-file-A
buffer-B emerge-file-B
- (cons (` (lambda ()
- (delete-file (, emerge-file-A))
- (delete-file (, emerge-file-B))))
+ (cons `(lambda ()
+ (delete-file ,emerge-file-A)
+ (delete-file ,emerge-file-B))
startup-hooks)
- (cons (` (lambda () (emerge-files-exit (, file))))
+ (cons `(lambda () (emerge-files-exit ,file))
quit-hooks)
nil)))
(defun emerge-revision-with-ancestor-internal (file revision-A revision-B
- ancestor
- &optional startup-hooks
- quit-hooks output-file)
+ ancestor
+ &optional startup-hooks
+ quit-hooks output-file)
(let ((buffer-A (get-buffer-create (format "%s,%s" file revision-A)))
(buffer-B (get-buffer-create (format "%s,%s" file revision-B)))
(buffer-ancestor (get-buffer-create (format "%s,%s" file ancestor)))
(emerge-setup-with-ancestor
buffer-A emerge-file-A buffer-B emerge-file-B
buffer-ancestor emerge-ancestor
- (cons (` (lambda ()
- (delete-file (, emerge-file-A))
- (delete-file (, emerge-file-B))
- (delete-file (, emerge-ancestor))))
+ (cons `(lambda ()
+ (delete-file ,emerge-file-A)
+ (delete-file ,emerge-file-B)
+ (delete-file ,emerge-ancestor))
startup-hooks)
- (cons (` (lambda () (emerge-files-exit (, file))))
+ (cons `(lambda () (emerge-files-exit ,file))
quit-hooks)
output-file)))
(goto-char (match-end 0))
;; Store the filename in the right variable
(cond
- ((string-equal tag "a")
- (if file-A
- (error "This line has two `A' entries"))
- (setq file-A file))
- ((string-equal tag "b")
- (if file-B
- (error "This line has two `B' entries"))
- (setq file-B file))
- ((or (string-equal tag "anc") (string-equal tag "ancestor"))
- (if file-ancestor
- (error "This line has two `ancestor' entries"))
- (setq file-ancestor file))
- ((or (string-equal tag "out") (string-equal tag "output"))
- (if file-out
- (error "This line has two `output' entries"))
- (setq file-out file))
- (t
- (error "Unrecognized entry"))))
- ;; If the match on the entry pattern failed
- (error "Unparsable entry")))
+ ((string-equal tag "a")
+ (if file-A
+ (error "This line has two `A' entries"))
+ (setq file-A file))
+ ((string-equal tag "b")
+ (if file-B
+ (error "This line has two `B' entries"))
+ (setq file-B file))
+ ((or (string-equal tag "anc") (string-equal tag "ancestor"))
+ (if file-ancestor
+ (error "This line has two `ancestor' entries"))
+ (setq file-ancestor file))
+ ((or (string-equal tag "out") (string-equal tag "output"))
+ (if file-out
+ (error "This line has two `output' entries"))
+ (setq file-out file))
+ (t
+ (error "Unrecognized entry"))))
+ ;; If the match on the entry pattern failed
+ (error "Unparsable entry")))
;; Make sure that file-A and file-B are present
(if (not (or (and file-A file-B) file-out))
(error "Must have both `A' and `B' entries"))
(beginning-of-line 2)
;; Execute the correct command
(cond
- ;; Merge of two files with ancestor
- ((and file-A file-B file-ancestor)
- (message "Merging %s and %s..." file-A file-B)
- (emerge-files-with-ancestor (not (not file-out)) file-A file-B
- file-ancestor file-out
- nil
- ;; When done, return to this buffer.
- (list
- (` (lambda ()
- (switch-to-buffer (, (current-buffer)))
- (message "Merge done."))))))
- ;; Merge of two files without ancestor
- ((and file-A file-B)
- (message "Merging %s and %s..." file-A file-B)
- (emerge-files (not (not file-out)) file-A file-B file-out
- nil
- ;; When done, return to this buffer.
- (list
- (` (lambda ()
- (switch-to-buffer (, (current-buffer)))
- (message "Merge done."))))))
- ;; There is an output file (or there would have been an error above),
- ;; but only one input file.
- ;; The file appears to have been deleted in one version; do nothing.
- ((and file-ancestor emerge-execute-line-deletions)
- (message "No action."))
- ;; The file should be copied from the version that contains it
- (t (let ((input-file (or file-A file-B)))
- (message "Copying...")
- (copy-file input-file file-out)
- (message "%s copied to %s." input-file file-out))))))
+ ;; Merge of two files with ancestor
+ ((and file-A file-B file-ancestor)
+ (message "Merging %s and %s..." file-A file-B)
+ (emerge-files-with-ancestor (not (not file-out)) file-A file-B
+ file-ancestor file-out
+ nil
+ ;; When done, return to this buffer.
+ (list
+ `(lambda ()
+ (switch-to-buffer ,(current-buffer))
+ (message "Merge done.")))))
+ ;; Merge of two files without ancestor
+ ((and file-A file-B)
+ (message "Merging %s and %s..." file-A file-B)
+ (emerge-files (not (not file-out)) file-A file-B file-out
+ nil
+ ;; When done, return to this buffer.
+ (list
+ `(lambda ()
+ (switch-to-buffer ,(current-buffer))
+ (message "Merge done.")))))
+ ;; There is an output file (or there would have been an error above),
+ ;; but only one input file.
+ ;; The file appears to have been deleted in one version; do nothing.
+ ((and file-ancestor emerge-execute-line-deletions)
+ (message "No action."))
+ ;; The file should be copied from the version that contains it
+ (t (let ((input-file (or file-A file-B)))
+ (message "Copying...")
+ (copy-file input-file file-out)
+ (message "%s copied to %s." input-file file-out))))))
;;; Sample function for creating information for emerge-execute-line
(error "`fast-lock' was written for long file name systems"))
(eval-when-compile
- ;;
- ;; We don't do this at the top-level as we only use non-autoloaded macros.
- (require 'cl)
- ;;
- ;; We use this to preserve or protect things when modifying text properties.
- (defmacro save-buffer-state (varlist &rest body)
- "Bind variables according to VARLIST and eval BODY restoring buffer state."
- (` (let* ((,@ (append varlist
- '((modified (buffer-modified-p)) (buffer-undo-list t)
- (inhibit-read-only t) (inhibit-point-motion-hooks t)
- before-change-functions after-change-functions
- deactivate-mark buffer-file-name buffer-file-truename))))
- (,@ body)
- (when (and (not modified) (buffer-modified-p))
- (set-buffer-modified-p nil)))))
- (put 'save-buffer-state 'lisp-indent-function 1)
- ;;
- ;; We use this to verify that a face should be saved.
- (defmacro fast-lock-save-facep (face)
- "Return non-nil if FACE is one of `fast-lock-save-faces'."
- (` (or (null fast-lock-save-faces)
- (if (symbolp (, face))
- (memq (, face) fast-lock-save-faces)
- (let ((faces (, face)))
- (while (unless (memq (car faces) fast-lock-save-faces)
- (setq faces (cdr faces))))
- faces)))))
- ;;
- ;; We use this for compatibility with a future Emacs.
- (or (fboundp 'with-temp-message)
- (defmacro with-temp-message (message &rest body)
- (` (let ((temp-message (, message)) current-message)
- (unwind-protect
- (progn
- (when temp-message
- (setq current-message (current-message))
- (message temp-message))
- (,@ body))
- (when temp-message
- (message current-message)))))))
- ;;
- ;; We use this for compatibility with a future Emacs.
- (or (fboundp 'defcustom)
- (defmacro defcustom (symbol value doc &rest args)
- (` (defvar (, symbol) (, value) (, doc))))))
+ ;;
+ ;; We don't do this at the top-level as we only use non-autoloaded macros.
+ (require 'cl)
+ ;;
+ ;; We use this to preserve or protect things when modifying text properties.
+ (defmacro save-buffer-state (varlist &rest body)
+ "Bind variables according to VARLIST and eval BODY restoring buffer state."
+ `(let* (,@(append varlist
+ '((modified (buffer-modified-p)) (buffer-undo-list t)
+ (inhibit-read-only t) (inhibit-point-motion-hooks t)
+ before-change-functions after-change-functions
+ deactivate-mark buffer-file-name buffer-file-truename)))
+ ,@body
+ (when (and (not modified) (buffer-modified-p))
+ (set-buffer-modified-p nil))))
+ (put 'save-buffer-state 'lisp-indent-function 1)
+ ;;
+ ;; We use this to verify that a face should be saved.
+ (defmacro fast-lock-save-facep (face)
+ "Return non-nil if FACE is one of `fast-lock-save-faces'."
+ `(or (null fast-lock-save-faces)
+ (if (symbolp ,face)
+ (memq ,face fast-lock-save-faces)
+ (let ((faces ,face))
+ (while (unless (memq (car faces) fast-lock-save-faces)
+ (setq faces (cdr faces))))
+ faces))))
+ ;;
+ ;; We use this for compatibility with a future Emacs.
+ (or (fboundp 'with-temp-message)
+ (defmacro with-temp-message (message &rest body)
+ `(let ((temp-message ,message) current-message)
+ (unwind-protect
+ (progn
+ (when temp-message
+ (setq current-message (current-message))
+ (message temp-message))
+ ,@body)
+ (when temp-message
+ (message current-message))))))
+ ;;
+ ;; We use this for compatibility with a future Emacs.
+ (or (fboundp 'defcustom)
+ (defmacro defcustom (symbol value doc &rest args)
+ `(defvar ,symbol ,value ,doc))))
;(defun fast-lock-submit-bug-report ()
; "Submit via mail a bug report on fast-lock.el."
(require 'font-lock)
(eval-when-compile
- ;; We don't do this at the top-level as we only use non-autoloaded macros.
- (require 'cl)
- ;;
- ;; We use this to preserve or protect things when modifying text properties.
- (defmacro save-buffer-state (varlist &rest body)
- "Bind variables according to VARLIST and eval BODY restoring buffer state."
- (` (let* ((,@ (append varlist
- '((modified (buffer-modified-p)) (buffer-undo-list t)
- (inhibit-read-only t) (inhibit-point-motion-hooks t)
- before-change-functions after-change-functions
- deactivate-mark buffer-file-name buffer-file-truename))))
- (,@ body)
- (when (and (not modified) (buffer-modified-p))
- (set-buffer-modified-p nil)))))
- (put 'save-buffer-state 'lisp-indent-function 1)
- ;;
- ;; We use this for clarity and speed. Naughty but nice.
- (defmacro do-while (test &rest body)
- "(do-while TEST BODY...): eval BODY... and repeat if TEST yields non-nil.
+ ;; We don't do this at the top-level as we only use non-autoloaded macros.
+ (require 'cl)
+ ;;
+ ;; We use this to preserve or protect things when modifying text properties.
+ (defmacro save-buffer-state (varlist &rest body)
+ "Bind variables according to VARLIST and eval BODY restoring buffer state."
+ `(let* (,@(append varlist
+ '((modified (buffer-modified-p)) (buffer-undo-list t)
+ (inhibit-read-only t) (inhibit-point-motion-hooks t)
+ before-change-functions after-change-functions
+ deactivate-mark buffer-file-name buffer-file-truename)))
+ ,@body
+ (when (and (not modified) (buffer-modified-p))
+ (set-buffer-modified-p nil))))
+ (put 'save-buffer-state 'lisp-indent-function 1)
+ ;;
+ ;; We use this for clarity and speed. Naughty but nice.
+ (defmacro do-while (test &rest body)
+ "(do-while TEST BODY...): eval BODY... and repeat if TEST yields non-nil.
The order of execution is thus BODY, TEST, BODY, TEST and so on
until TEST returns nil."
- (` (while (progn (,@ body) (, test)))))
- (put 'do-while 'lisp-indent-function (get 'while 'lisp-indent-function)))
+ `(while (progn ,@body ,test)))
+ (put 'do-while 'lisp-indent-function (get 'while 'lisp-indent-function)))
(defvar lazy-lock-mode nil) ; Whether we are turned on.
(defvar lazy-lock-buffers nil) ; For deferral.
;; If you write software that must work without the new custom, you
;; can use this hack stolen from w3-cus.el:
(eval-and-compile
- (condition-case ()
- (require 'custom)
- (error nil))
- (if (and (featurep 'custom) (fboundp 'custom-declare-variable))
- nil ;; We've got what we needed
- ;; We have the old custom-library, hack around it!
- (defmacro defgroup (&rest args)
- nil)
- (defmacro defcustom (var value doc &rest args)
- (` (defvar (, var) (, value) (, doc))))))
+ (condition-case ()
+ (require 'custom)
+ (error nil))
+ (if (and (featurep 'custom) (fboundp 'custom-declare-variable))
+ nil ;; We've got what we needed
+ ;; We have the old custom-library, hack around it!
+ (defmacro defgroup (&rest args)
+ nil)
+ (defmacro defcustom (var value doc &rest args)
+ `(defvar ,var ,value ,doc))))
(eval-when-compile (require 'smtpmail))
(autoload 'mail-do-fcc "sendmail")
;;
;; * Pressing mouse-2 while selecting or extending copies selection
;; to the kill ring. Pressing mouse-1 or mouse-3 kills it.
-;;
+;;
;; * Double-clicking mouse-3 also kills selection.
-;;
+;;
;; * M-mouse-1, M-mouse-2 & M-mouse-3 work similarly to mouse-1, mouse-2
;; & mouse-3, but operate on the X secondary selection rather than the
;; primary selection and region.
;;
;; ;; But only in the selected window
;; (setq highlight-nonselected-windows nil)
-;;
+;;
;; ;; Enable pending-delete
;; (delete-selection-mode 1)
;;
;; of mouse-sel-default-bindings before loading mouse-sel.
;;
;; (a) If mouse-sel-default-bindings = t (the default)
-;;
+;;
;; Mouse sets and insert selection
;; mouse-1 mouse-select
;; mouse-2 mouse-insert-selection
;; interprogram-paste-function = nil
;;
;; (b) If mouse-sel-default-bindings = 'interprogram-cut-paste
-;;
+;;
;; Mouse sets selection, and pastes from kill-ring
;; mouse-1 mouse-select
;; mouse-2 mouse-yank-at-click
;; mouse-3 mouse-extend
-;;
+;;
;; Selection/kill-ring interaction is retained
;; interprogram-cut-function = x-select-text
;; interprogram-paste-function = x-cut-buffer-or-selection-value
-;;
+;;
;; What you lose is the ability to select some text in
;; delete-selection-mode and yank over the top of it.
-;;
+;;
;; (c) If mouse-sel-default-bindings = nil, no bindings are made.
;;
;; * By default, mouse-insert-selection (mouse-2) inserts the selection at
;;=== Internal Variables/Constants ========================================
-(defvar mouse-sel-primary-thing nil
+(defvar mouse-sel-primary-thing nil
"Type of PRIMARY selection in current buffer.")
(make-variable-buffer-local 'mouse-sel-primary-thing)
-(defvar mouse-sel-secondary-thing nil
+(defvar mouse-sel-secondary-thing nil
"Type of SECONDARY selection in current buffer.")
(make-variable-buffer-local 'mouse-sel-secondary-thing)
OVERLAY-SYMBOL = name of variable containing overlay to use
SELECTION-THING-SYMBOL = name of variable where the current selection
type for this selection should be stored.")
-
+
(defvar mouse-sel-set-selection-function
(if (eq mouse-sel-default-bindings 'interprogram-cut-paste)
'x-set-selection
multi-click semantics."
(let* ((next-char (char-after (point)))
(char-syntax (if next-char (char-syntax next-char))))
- (if mouse-sel-cycle-clicks
+ (if mouse-sel-cycle-clicks
(setq nclicks (1+ (% (1- nclicks) 4))))
(cond
((= nclicks 1) nil)
(defun mouse-sel-region-to-primary (orig-window)
"Convert region to PRIMARY overlay and deactivate region.
-Argument ORIG-WINDOW specifies the window the cursor was in when the
-originating command was issued, and is used to determine whether the
+Argument ORIG-WINDOW specifies the window the cursor was in when the
+originating command was issued, and is used to determine whether the
region was visible or not."
(if transient-mark-mode
(let ((overlay (mouse-sel-selection-overlay 'PRIMARY)))
(cond
- ((and mark-active
- (or highlight-nonselected-windows
+ ((and mark-active
+ (or highlight-nonselected-windows
(eq orig-window (selected-window))))
;; Region was visible, so convert region to overlay
- (move-overlay overlay (region-beginning) (region-end)
+ (move-overlay overlay (region-beginning) (region-end)
(current-buffer)))
((eq orig-window (selected-window))
;; Point was visible, so set overlay at point
"Evaluate forms at mouse position.
Move to the end position of EVENT, execute FORMS, and restore original
point and window."
- (`
- (let ((posn (event-end (, event))))
- (if posn (mouse-minibuffer-check (, event)))
- (if (and posn (not (windowp (posn-window posn))))
- (error "Cursor not in text area of window"))
- (let (orig-window orig-point-marker)
- (setq orig-window (selected-window))
- (if posn (select-window (posn-window posn)))
- (setq orig-point-marker (point-marker))
- (if (and posn (numberp (posn-point posn)))
- (goto-char (posn-point posn)))
- (unwind-protect
- (progn
- (,@ forms))
- (goto-char (marker-position orig-point-marker))
- (move-marker orig-point-marker nil)
- (select-window orig-window)
- )))))
+ `(let ((posn (event-end ,event)))
+ (if posn (mouse-minibuffer-check ,event))
+ (if (and posn (not (windowp (posn-window posn))))
+ (error "Cursor not in text area of window"))
+ (let (orig-window orig-point-marker)
+ (setq orig-window (selected-window))
+ (if posn (select-window (posn-window posn)))
+ (setq orig-point-marker (point-marker))
+ (if (and posn (numberp (posn-point posn)))
+ (goto-char (posn-point posn)))
+ (unwind-protect
+ (progn
+ ,@forms)
+ (goto-char (marker-position orig-point-marker))
+ (move-marker orig-point-marker nil)
+ (select-window orig-window)))))
(put 'mouse-sel-eval-at-event-end 'lisp-indent-hook 1)
Click sets point & mark to click position.
Dragging extends region/selection.
-Multi-clicking selects word/lines/paragraphs, as determined by
+Multi-clicking selects word/lines/paragraphs, as determined by
'mouse-sel-determine-selection-thing.
Clicking mouse-2 while selecting copies selected text to the kill-ring.
Click sets the start of the secondary selection to click position.
Dragging extends the secondary selection.
-Multi-clicking selects word/lines/paragraphs, as determined by
+Multi-clicking selects word/lines/paragraphs, as determined by
'mouse-sel-determine-selection-thing.
Clicking mouse-2 while selecting copies selected text to the kill-ring.
(defun mouse-extend-internal (selection &optional initial-event)
"Extend specified SELECTION using the mouse.
Track mouse-motion events, adjusting the SELECTION appropriately.
-Optional argument INITIAL-EVENT specifies an initial down-mouse event to
-process.
+Optional argument INITIAL-EVENT specifies an initial down-mouse event to
+process.
See documentation for mouse-select-internal for more details."
(mouse-sel-eval-at-event-end initial-event
- (let ((orig-cursor-type
+ (let ((orig-cursor-type
(cdr (assoc 'cursor-type (frame-parameters (selected-frame))))))
(unwind-protect
(setq min (point)
max min)
(set thing-symbol nil))
-
+
;; Bar cursor
(if (fboundp 'modify-frame-parameters)
(modify-frame-parameters (selected-frame)
'((cursor-type . bar))))
-
+
;; Handle dragging
(track-mouse
-
+
(while (if initial-event ; Use initial event
(prog1
(setq event initial-event)
(setq event (read-event))
(and (consp event)
(memq (car event) '(mouse-movement switch-frame))))
-
+
(let ((selection-thing (symbol-value thing-symbol))
(end (event-end event)))
-
+
(cond
-
+
;; Ignore any movement outside the frame
((eq (car-safe event) 'switch-frame) nil)
((and (posn-window end)
(window-frame posn-w)
posn-w))
(window-frame orig-window)))) nil)
-
+
;; Different window, same frame
((not (eq (posn-window end) orig-window))
(let ((end-row (cdr (cdr (mouse-position)))))
(mouse-scroll-subr orig-window (1+ (- end-row bottom))
overlay min))
)))
-
+
;; On the mode line
((eq (posn-point end) 'mode-line)
(mouse-scroll-subr orig-window 1 overlay min))
-
+
;; In original window
(t (goto-char (posn-point end)))
-
+
)
-
+
;; Determine direction of drag
(cond
((and (not direction) (not (eq min max)))
(setq direction -1))
((and (not (eq direction 1)) (>= (point) max))
(setq direction 1)))
-
+
(if (not selection-thing) nil
-
+
;; If dragging forward, goal is next character
(if (and (eq direction 1) (not (eobp))) (forward-char 1))
-
+
;; Move to start/end of selected thing
(let ((goal (point)))
(goto-char (if (eq 1 direction) min max))
(if (> (* direction (- goal (point))) 0)
end (point)))))
(error))))
-
+
;; Move overlay
(move-overlay overlay
(if (eq 1 direction) min (point))
(if (eq -1 direction) max (point))
(current-buffer))
-
+
))) ; end track-mouse
;; Finish up after dragging
(let ((overlay-start (overlay-start overlay))
(overlay-end (overlay-end overlay)))
-
+
;; Set selection
(if (not (eq overlay-start overlay-end))
(mouse-sel-set-selection
selection
(buffer-substring overlay-start overlay-end)))
-
+
;; Handle copy/kill
(let (this-command)
(cond
;; Restore cursor
(if (fboundp 'modify-frame-parameters)
- (modify-frame-parameters
+ (modify-frame-parameters
(selected-frame) (list (cons 'cursor-type orig-cursor-type))))
-
+
))))
;;=== Paste ===============================================================
(defun mouse-insert-selection-internal (selection event)
"Insert the contents of the named SELECTION at mouse click.
If `mouse-yank-at-point' is non-nil, insert at point instead."
- (unless mouse-yank-at-point
+ (unless mouse-yank-at-point
(mouse-set-point event))
(when mouse-sel-get-selection-function
(push-mark (point) 'nomsg)
;; This is actually the expression for C++ mode, but it's used for C too.
(defvar c-imenu-generic-expression
- (`
- ((nil
- (,
- (concat
- "^" ; beginning of line is required
+ `((nil
+ ,(concat
+ "^" ; beginning of line is required
"\\(template[ \t]*<[^>]+>[ \t]*\\)?" ; there may be a "template <...>"
- "\\([a-zA-Z0-9_:]+[ \t]+\\)?" ; type specs; there can be no
- "\\([a-zA-Z0-9_:]+[ \t]+\\)?" ; more than 3 tokens, right?
+ "\\([a-zA-Z0-9_:]+[ \t]+\\)?" ; type specs; there can be no
+ "\\([a-zA-Z0-9_:]+[ \t]+\\)?" ; more than 3 tokens, right?
- "\\(" ; last type spec including */&
+ "\\(" ; last type spec including */&
"[a-zA-Z0-9_:]+"
- "\\([ \t]*[*&]+[ \t]*\\|[ \t]+\\)" ; either pointer/ref sign or whitespace
- "\\)?" ; if there is a last type spec
- "\\(" ; name; take that into the imenu entry
- "[a-zA-Z0-9_:~]+" ; member function, ctor or dtor...
- ; (may not contain * because then
- ; "a::operator char*" would become "char*"!)
+ "\\([ \t]*[*&]+[ \t]*\\|[ \t]+\\)" ; either pointer/ref sign or whitespace
+ "\\)?" ; if there is a last type spec
+ "\\(" ; name; take that into the imenu entry
+ "[a-zA-Z0-9_:~]+" ; member function, ctor or dtor...
+ ; (may not contain * because then
+ ; "a::operator char*" would become "char*"!)
"\\|"
"\\([a-zA-Z0-9_:~]*::\\)?operator"
- "[^a-zA-Z1-9_][^(]*" ; ...or operator
+ "[^a-zA-Z1-9_][^(]*" ; ...or operator
" \\)"
"[ \t]*([^)]*)[ \t\n]*[^ ;]" ; require something other than a ; after
- ; the (...) to avoid prototypes. Can't
- ; catch cases with () inside the parentheses
- ; surrounding the parameters
- ; (like "int foo(int a=bar()) {...}"
+ ; the (...) to avoid prototypes. Can't
+ ; catch cases with () inside the parentheses
+ ; surrounding the parameters
+ ; (like "int foo(int a=bar()) {...}"
- )) 6)
+ ) 6)
("Class"
- (, (concat
- "^" ; beginning of line is required
- "\\(template[ \t]*<[^>]+>[ \t]*\\)?" ; there may be a "template <...>"
- "class[ \t]+"
- "\\([a-zA-Z0-9_]+\\)" ; this is the string we want to get
- "[ \t]*[:{]"
- )) 2)
-;; Example of generic expression for finding prototypes, structs, unions, enums.
-;; Uncomment if you want to find these too. It will be a bit slower gathering
-;; the indexes.
-; ("Prototypes"
-; (,
-; (concat
-; "^" ; beginning of line is required
-; "\\(template[ \t]*<[^>]+>[ \t]*\\)?" ; there may be a "template <...>"
-; "\\([a-zA-Z0-9_:]+[ \t]+\\)?" ; type specs; there can be no
-; "\\([a-zA-Z0-9_:]+[ \t]+\\)?" ; more than 3 tokens, right?
-
-; "\\(" ; last type spec including */&
-; "[a-zA-Z0-9_:]+"
-; "\\([ \t]*[*&]+[ \t]*\\|[ \t]+\\)" ; either pointer/ref sign or whitespace
-; "\\)?" ; if there is a last type spec
-; "\\(" ; name; take that into the imenu entry
-; "[a-zA-Z0-9_:~]+" ; member function, ctor or dtor...
-; ; (may not contain * because then
-; ; "a::operator char*" would become "char*"!)
-; "\\|"
-; "\\([a-zA-Z0-9_:~]*::\\)?operator"
-; "[^a-zA-Z1-9_][^(]*" ; ...or operator
-; " \\)"
-; "[ \t]*([^)]*)[ \t\n]*;" ; require ';' after
-; ; the (...) Can't
-; ; catch cases with () inside the parentheses
-; ; surrounding the parameters
-; ; (like "int foo(int a=bar());"
-; )) 6)
-; ("Struct"
-; (, (concat
-; "^" ; beginning of line is required
-; "\\(static[ \t]+\\)?" ; there may be static or const.
-; "\\(const[ \t]+\\)?"
-; "struct[ \t]+"
-; "\\([a-zA-Z0-9_]+\\)" ; this is the string we want to get
-; "[ \t]*[{]"
-; )) 3)
-; ("Enum"
-; (, (concat
-; "^" ; beginning of line is required
-; "\\(static[ \t]+\\)?" ; there may be static or const.
-; "\\(const[ \t]+\\)?"
-; "enum[ \t]+"
-; "\\([a-zA-Z0-9_]+\\)" ; this is the string we want to get
-; "[ \t]*[{]"
-; )) 3)
-; ("Union"
-; (, (concat
-; "^" ; beginning of line is required
-; "\\(static[ \t]+\\)?" ; there may be static or const.
-; "\\(const[ \t]+\\)?"
-; "union[ \t]+"
-; "\\([a-zA-Z0-9_]+\\)" ; this is the string we want to get
-; "[ \t]*[{]"
-; )) 3)
- ))
+ ,(concat
+ "^" ; beginning of line is required
+ "\\(template[ \t]*<[^>]+>[ \t]*\\)?" ; there may be a "template <...>"
+ "class[ \t]+"
+ "\\([a-zA-Z0-9_]+\\)" ; this is the string we want to get
+ "[ \t]*[:{]"
+ ) 2)
+ ;; Example of generic expression for finding prototypes, structs, unions, enums.
+ ;; Uncomment if you want to find these too. It will be a bit slower gathering
+ ;; the indexes.
+ ; ("Prototypes"
+ ; (,
+ ; (concat
+ ; "^" ; beginning of line is required
+ ; "\\(template[ \t]*<[^>]+>[ \t]*\\)?" ; there may be a "template <...>"
+ ; "\\([a-zA-Z0-9_:]+[ \t]+\\)?" ; type specs; there can be no
+ ; "\\([a-zA-Z0-9_:]+[ \t]+\\)?" ; more than 3 tokens, right?
+
+ ; "\\(" ; last type spec including */&
+ ; "[a-zA-Z0-9_:]+"
+ ; "\\([ \t]*[*&]+[ \t]*\\|[ \t]+\\)" ; either pointer/ref sign or whitespace
+ ; "\\)?" ; if there is a last type spec
+ ; "\\(" ; name; take that into the imenu entry
+ ; "[a-zA-Z0-9_:~]+" ; member function, ctor or dtor...
+ ; ; (may not contain * because then
+ ; ; "a::operator char*" would become "char*"!)
+ ; "\\|"
+ ; "\\([a-zA-Z0-9_:~]*::\\)?operator"
+ ; "[^a-zA-Z1-9_][^(]*" ; ...or operator
+ ; " \\)"
+ ; "[ \t]*([^)]*)[ \t\n]*;" ; require ';' after
+ ; ; the (...) Can't
+ ; ; catch cases with () inside the parentheses
+ ; ; surrounding the parameters
+ ; ; (like "int foo(int a=bar());"
+ ; )) 6)
+ ; ("Struct"
+ ; (, (concat
+ ; "^" ; beginning of line is required
+ ; "\\(static[ \t]+\\)?" ; there may be static or const.
+ ; "\\(const[ \t]+\\)?"
+ ; "struct[ \t]+"
+ ; "\\([a-zA-Z0-9_]+\\)" ; this is the string we want to get
+ ; "[ \t]*[{]"
+ ; )) 3)
+ ; ("Enum"
+ ; (, (concat
+ ; "^" ; beginning of line is required
+ ; "\\(static[ \t]+\\)?" ; there may be static or const.
+ ; "\\(const[ \t]+\\)?"
+ ; "enum[ \t]+"
+ ; "\\([a-zA-Z0-9_]+\\)" ; this is the string we want to get
+ ; "[ \t]*[{]"
+ ; )) 3)
+ ; ("Union"
+ ; (, (concat
+ ; "^" ; beginning of line is required
+ ; "\\(static[ \t]+\\)?" ; there may be static or const.
+ ; "\\(const[ \t]+\\)?"
+ ; "union[ \t]+"
+ ; "\\([a-zA-Z0-9_]+\\)" ; this is the string we want to get
+ ; "[ \t]*[{]"
+ ; )) 3)
+ )
"Imenu generic expression for C mode. See `imenu-generic-expression'.")
\f
(defun c-mode ()
(parse-partial-sexp beg (point)
nil nil state)))
(and (not (nth 3 new-state)) (not (nth 5 new-state))))
- (indent-for-comment)))))))))))
+ (indent-for-comment)))))))))))))
;; Look at all comment-start strings in the current line after point.
;; Return t if one of them starts a real comment.
:group 'old-c++)
(defvar c++-imenu-generic-expression
- (`
- ((nil
- (,
- (concat
- "^" ; beginning of line is required
+ `((nil
+ ,(concat
+ "^" ; beginning of line is required
"\\(template[ \t]*<[^>]+>[ \t]*\\)?" ; there may be a "template <...>"
- "\\([a-zA-Z0-9_:]+[ \t]+\\)?" ; type specs; there can be no
- "\\([a-zA-Z0-9_:]+[ \t]+\\)?" ; more than 3 tokens, right?
+ "\\([a-zA-Z0-9_:]+[ \t]+\\)?" ; type specs; there can be no
+ "\\([a-zA-Z0-9_:]+[ \t]+\\)?" ; more than 3 tokens, right?
- "\\(" ; last type spec including */&
+ "\\(" ; last type spec including */&
"[a-zA-Z0-9_:]+"
- "\\([ \t]*[*&]+[ \t]*\\|[ \t]+\\)" ; either pointer/ref sign or whitespace
- "\\)?" ; if there is a last type spec
- "\\(" ; name; take that into the imenu entry
- "[a-zA-Z0-9_:~]+" ; member function, ctor or dtor...
- ; (may not contain * because then
- ; "a::operator char*" would become "char*"!)
+ "\\([ \t]*[*&]+[ \t]*\\|[ \t]+\\)" ; either pointer/ref sign or whitespace
+ "\\)?" ; if there is a last type spec
+ "\\(" ; name; take that into the imenu entry
+ "[a-zA-Z0-9_:~]+" ; member function, ctor or dtor...
+ ; (may not contain * because then
+ ; "a::operator char*" would become "char*"!)
"\\|"
"\\([a-zA-Z0-9_:~]*::\\)?operator"
- "[^a-zA-Z1-9_][^(]*" ; ...or operator
+ "[^a-zA-Z1-9_][^(]*" ; ...or operator
" \\)"
"[ \t]*([^)]*)[ \t\n]*[^ ;]" ; require something other than a ; after
- ; the (...) to avoid prototypes. Can't
- ; catch cases with () inside the parentheses
- ; surrounding the parameters
- ; (like "int foo(int a=bar()) {...}"
+ ; the (...) to avoid prototypes. Can't
+ ; catch cases with () inside the parentheses
+ ; surrounding the parameters
+ ; (like "int foo(int a=bar()) {...}"
- )) 6)
+ ) 6)
("Class"
- (, (concat
- "^" ; beginning of line is required
- "\\(template[ \t]*<[^>]+>[ \t]*\\)?" ; there may be a "template <...>"
- "class[ \t]+"
- "\\([a-zA-Z0-9_]+\\)" ; this is the string we want to get
- "[ \t]*[:{]"
- )) 2)
-;; Example of generic expression for finding prototypes, structs, unions, enums.
-;; Uncomment if you want to find these too. It will be a bit slower gathering
-;; the indexes.
-; ("Prototypes"
-; (,
-; (concat
-; "^" ; beginning of line is required
-; "\\(template[ \t]*<[^>]+>[ \t]*\\)?" ; there may be a "template <...>"
-; "\\([a-zA-Z0-9_:]+[ \t]+\\)?" ; type specs; there can be no
-; "\\([a-zA-Z0-9_:]+[ \t]+\\)?" ; more than 3 tokens, right?
+ ,(concat
+ "^" ; beginning of line is required
+ "\\(template[ \t]*<[^>]+>[ \t]*\\)?" ; there may be a "template <...>"
+ "class[ \t]+"
+ "\\([a-zA-Z0-9_]+\\)" ; this is the string we want to get
+ "[ \t]*[:{]"
+ ) 2)
+ ;; Example of generic expression for finding prototypes, structs, unions, enums.
+ ;; Uncomment if you want to find these too. It will be a bit slower gathering
+ ;; the indexes.
+ ; ("Prototypes"
+ ; (,
+ ; (concat
+ ; "^" ; beginning of line is required
+ ; "\\(template[ \t]*<[^>]+>[ \t]*\\)?" ; there may be a "template <...>"
+ ; "\\([a-zA-Z0-9_:]+[ \t]+\\)?" ; type specs; there can be no
+ ; "\\([a-zA-Z0-9_:]+[ \t]+\\)?" ; more than 3 tokens, right?
-; "\\(" ; last type spec including */&
-; "[a-zA-Z0-9_:]+"
-; "\\([ \t]*[*&]+[ \t]*\\|[ \t]+\\)" ; either pointer/ref sign or whitespace
-; "\\)?" ; if there is a last type spec
-; "\\(" ; name; take that into the imenu entry
-; "[a-zA-Z0-9_:~]+" ; member function, ctor or dtor...
-; ; (may not contain * because then
-; ; "a::operator char*" would become "char*"!)
-; "\\|"
-; "\\([a-zA-Z0-9_:~]*::\\)?operator"
-; "[^a-zA-Z1-9_][^(]*" ; ...or operator
-; " \\)"
-; "[ \t]*([^)]*)[ \t\n]*;" ; require ';' after
-; ; the (...) Can't
-; ; catch cases with () inside the parentheses
-; ; surrounding the parameters
-; ; (like "int foo(int a=bar());"
-; )) 6)
-; ("Struct"
-; (, (concat
-; "^" ; beginning of line is required
-; "\\(static[ \t]+\\)?" ; there may be static or const.
-; "\\(const[ \t]+\\)?"
-; "struct[ \t]+"
-; "\\([a-zA-Z0-9_]+\\)" ; this is the string we want to get
-; "[ \t]*[{]"
-; )) 3)
-; ("Enum"
-; (, (concat
-; "^" ; beginning of line is required
-; "\\(static[ \t]+\\)?" ; there may be static or const.
-; "\\(const[ \t]+\\)?"
-; "enum[ \t]+"
-; "\\([a-zA-Z0-9_]+\\)" ; this is the string we want to get
-; "[ \t]*[{]"
-; )) 3)
-; ("Union"
-; (, (concat
-; "^" ; beginning of line is required
-; "\\(static[ \t]+\\)?" ; there may be static or const.
-; "\\(const[ \t]+\\)?"
-; "union[ \t]+"
-; "\\([a-zA-Z0-9_]+\\)" ; this is the string we want to get
-; "[ \t]*[{]"
-; )) 3)
- ))
+ ; "\\(" ; last type spec including */&
+ ; "[a-zA-Z0-9_:]+"
+ ; "\\([ \t]*[*&]+[ \t]*\\|[ \t]+\\)" ; either pointer/ref sign or whitespace
+ ; "\\)?" ; if there is a last type spec
+ ; "\\(" ; name; take that into the imenu entry
+ ; "[a-zA-Z0-9_:~]+" ; member function, ctor or dtor...
+ ; ; (may not contain * because then
+ ; ; "a::operator char*" would become "char*"!)
+ ; "\\|"
+ ; "\\([a-zA-Z0-9_:~]*::\\)?operator"
+ ; "[^a-zA-Z1-9_][^(]*" ; ...or operator
+ ; " \\)"
+ ; "[ \t]*([^)]*)[ \t\n]*;" ; require ';' after
+ ; ; the (...) Can't
+ ; ; catch cases with () inside the parentheses
+ ; ; surrounding the parameters
+ ; ; (like "int foo(int a=bar());"
+ ; )) 6)
+ ; ("Struct"
+ ; (, (concat
+ ; "^" ; beginning of line is required
+ ; "\\(static[ \t]+\\)?" ; there may be static or const.
+ ; "\\(const[ \t]+\\)?"
+ ; "struct[ \t]+"
+ ; "\\([a-zA-Z0-9_]+\\)" ; this is the string we want to get
+ ; "[ \t]*[{]"
+ ; )) 3)
+ ; ("Enum"
+ ; (, (concat
+ ; "^" ; beginning of line is required
+ ; "\\(static[ \t]+\\)?" ; there may be static or const.
+ ; "\\(const[ \t]+\\)?"
+ ; "enum[ \t]+"
+ ; "\\([a-zA-Z0-9_]+\\)" ; this is the string we want to get
+ ; "[ \t]*[{]"
+ ; )) 3)
+ ; ("Union"
+ ; (, (concat
+ ; "^" ; beginning of line is required
+ ; "\\(static[ \t]+\\)?" ; there may be static or const.
+ ; "\\(const[ \t]+\\)?"
+ ; "union[ \t]+"
+ ; "\\([a-zA-Z0-9_]+\\)" ; this is the string we want to get
+ ; "[ \t]*[{]"
+ ; )) 3)
+ )
"Imenu generic expression for C++ mode. See `imenu-generic-expression'.")
(defun c++-mode ()
(if (eq (preceding-char) ?\))
(forward-sexp -1))
;; Get initial indentation of the line we are on.
- (current-indentation))))))))))
+ (current-indentation)))))))))))
(defun c++-backward-to-noncomment (lim)
(let (opoint stop)
(point)) t)
(progn
(indent-for-comment)
- (beginning-of-line))))))))))
+ (beginning-of-line)))))))))))
\f
(defun fill-c++-comment ()
"Fill a comment contained in consecutive lines containing point.
:group 'dcl)
(defcustom dcl-imenu-generic-expression
- (`
- ((nil "^\\$[ \t]*\\([A-Za-z0-9_\$]+\\):[ \t]+SUBROUTINE\\b" 1)
- ((, dcl-imenu-label-labels)
+ `((nil "^\\$[ \t]*\\([A-Za-z0-9_\$]+\\):[ \t]+SUBROUTINE\\b" 1)
+ (,dcl-imenu-label-labels
"^\\$[ \t]*\\([A-Za-z0-9_\$]+\\):\\([ \t]\\|$\\)" 1)
- ((, dcl-imenu-label-goto) "\\s-GOTO[ \t]+\\([A-Za-z0-9_\$]+\\)" 1)
- ((, dcl-imenu-label-gosub) "\\s-GOSUB[ \t]+\\([A-Za-z0-9_\$]+\\)" 1)
- ((, dcl-imenu-label-call) "\\s-CALL[ \t]+\\([A-Za-z0-9_\$]+\\)" 1)))
+ (,dcl-imenu-label-goto "\\s-GOTO[ \t]+\\([A-Za-z0-9_\$]+\\)" 1)
+ (,dcl-imenu-label-gosub "\\s-GOSUB[ \t]+\\([A-Za-z0-9_\$]+\\)" 1)
+ (,dcl-imenu-label-call "\\s-CALL[ \t]+\\([A-Za-z0-9_\$]+\\)" 1))
"*Default imenu generic expression for DCL.
The default includes SUBROUTINE labels in the main listing and
;; Author: Chris Chase <chase@att.com>
;; Maintainer: Carsten Dominik <dominik@strw.leidenuniv.nl>
;; Version: 4.7
-;; Date: $Date: 2000/12/19 11:13:34 $
+;; Date: $Date: 2001/07/16 12:22:59 $
;; Keywords: processes
;; This file is part of GNU Emacs.
(defvar idlwave-shell-have-new-custom nil)
(eval-and-compile
- ;; Kludge to allow `defcustom' for Emacs 19.
- (condition-case () (require 'custom) (error nil))
- (if (and (featurep 'custom)
- (fboundp 'custom-declare-variable)
- (fboundp 'defface))
- ;; We've got what we needed
- (setq idlwave-shell-have-new-custom t)
- ;; We have the old or no custom-library, hack around it!
- (defmacro defgroup (&rest args) nil)
- (defmacro defcustom (var value doc &rest args)
- (` (defvar (, var) (, value) (, doc))))))
+ ;; Kludge to allow `defcustom' for Emacs 19.
+ (condition-case () (require 'custom) (error nil))
+ (if (and (featurep 'custom)
+ (fboundp 'custom-declare-variable)
+ (fboundp 'defface))
+ ;; We've got what we needed
+ (setq idlwave-shell-have-new-custom t)
+ ;; We have the old or no custom-library, hack around it!
+ (defmacro defgroup (&rest args) nil)
+ (defmacro defcustom (var value doc &rest args)
+ `(defvar ,var ,value ,doc))))
;;; Customizations: idlwave-shell group
(idlwave-shell-send-command
idlwave-shell-bp-query
'(progn
- (idlwave-shell-filter-bp)
- (setq idlwave-shell-old-bp idlwave-shell-bp-alist))
+ (idlwave-shell-filter-bp)
+ (setq idlwave-shell-old-bp idlwave-shell-bp-alist))
'hide)
;; Get sources for IDL compiled procedures followed by setting
;; breakpoint.
(idlwave-shell-send-command
idlwave-shell-sources-query
- (` (progn
- (idlwave-shell-sources-filter)
- (idlwave-shell-set-bp2 (quote (, bp)))))
+ `(progn
+ (idlwave-shell-sources-filter)
+ (idlwave-shell-set-bp2 (quote ,bp)))
'hide))
(defun idlwave-shell-set-bp2 (bp)
(let*
((arg (idlwave-shell-bp-get bp 'count))
(key (cond
- ((not (and arg (numberp arg))) "")
- ((= arg 1)
- ",/once")
- ((> arg 1)
- (format ",after=%d" arg))))
+ ((not (and arg (numberp arg))) "")
+ ((= arg 1)
+ ",/once")
+ ((> arg 1)
+ (format ",after=%d" arg))))
(line (idlwave-shell-bp-get bp 'line)))
(idlwave-shell-send-command
(concat "breakpoint,'"
(if (integerp line) (setq line (int-to-string line)))
key)
;; Check for failure and look for breakpoint in IDL's list
- (` (progn
- (if (idlwave-shell-set-bp-check (quote (, bp)))
- (idlwave-shell-set-bp3 (quote (, bp)))))
- )
+ `(progn
+ (if (idlwave-shell-set-bp-check (quote ,bp))
+ (idlwave-shell-set-bp3 (quote ,bp))))
;; do not hide output
nil
'preempt)))
(defun idlwave-shell-set-bp3 (bp)
"Find the breakpoint in IDL's internal list of breakpoints."
(idlwave-shell-send-command idlwave-shell-bp-query
- (` (progn
- (idlwave-shell-filter-bp)
- (idlwave-shell-new-bp (quote (, bp)))))
+ `(progn
+ (idlwave-shell-filter-bp)
+ (idlwave-shell-new-bp (quote ,bp)))
'hide
'preempt))
;; Author: Chris Chase <chase@att.com>
;; Maintainer: Carsten Dominik <dominik@strw.leidenuniv.nl>
;; Version: 4.7
-;; Date: $Date: 2000/12/19 11:12:40 $
+;; Date: $Date: 2001/07/16 12:22:59 $
;; Keywords: languages
;; This file is part of GNU Emacs.
(eval-when-compile (require 'cl))
(eval-and-compile
- ;; Kludge to allow `defcustom' for Emacs 19.
- (condition-case () (require 'custom) (error nil))
- (if (and (featurep 'custom) (fboundp 'custom-declare-variable))
- nil ;; We've got what we needed
- ;; We have the old or no custom-library, hack around it!
- (defmacro defgroup (&rest args) nil)
- (defmacro defcustom (var value doc &rest args)
- (` (defvar (, var) (, value) (, doc))))))
+ ;; Kludge to allow `defcustom' for Emacs 19.
+ (condition-case () (require 'custom) (error nil))
+ (if (and (featurep 'custom) (fboundp 'custom-declare-variable))
+ nil ;; We've got what we needed
+ ;; We have the old or no custom-library, hack around it!
+ (defmacro defgroup (&rest args) nil)
+ (defmacro defcustom (var value doc &rest args)
+ `(defvar ,var ,value ,doc))))
(defgroup idlwave nil
"Major mode for editing IDL/WAVE CL .pro files"
(defmacro idlwave-keyword-abbrev (&rest args)
"Creates a function for abbrev hooks to call `idlwave-check-abbrev' with args."
- (` (quote (lambda ()
- (, (append '(idlwave-check-abbrev) args))))))
+ `(quote (lambda ()
+ ,(append '(idlwave-check-abbrev) args))))
;; If I take the time I can replace idlwave-keyword-abbrev with
;; idlwave-code-abbrev and remove the quoted abbrev check from
"Creates a function for abbrev hooks that ensures abbrevs are not quoted.
Specifically, if the abbrev is in a comment or string it is unexpanded.
Otherwise ARGS forms a list that is evaluated."
- (` (quote (lambda ()
- (, (prin1-to-string args)) ;; Puts the code in the doc string
- (if (idlwave-quoted)
- (progn (unexpand-abbrev) nil)
- (, (append args)))))))
+ `(quote (lambda ()
+ ,(prin1-to-string args) ;; Puts the code in the doc string
+ (if (idlwave-quoted)
+ (progn (unexpand-abbrev) nil)
+ ,(append args)))))
(defvar idlwave-mode-map (make-sparse-keymap)
"Keymap used in IDL mode.")
;;; All the useful code bits
(defmacro sm::hit-code (hit)
- (` (nth 0 (, hit))))
+ `(nth 0 ,hit))
;;; The button, or buttons if a chord.
(defmacro sm::hit-button (hit)
- (` (logand sm::ButtonBits (nth 0 (, hit)))))
+ `(logand sm::ButtonBits (nth 0 ,hit)))
;;; The shift, control, and meta flags.
(defmacro sm::hit-shiftmask (hit)
- (` (logand sm::ShiftmaskBits (nth 0 (, hit)))))
+ `(logand sm::ShiftmaskBits (nth 0 ,hit)))
;;; Set if a double click (but not a chord).
(defmacro sm::hit-double (hit)
- (` (logand sm::DoubleBits (nth 0 (, hit)))))
+ `(logand sm::DoubleBits (nth 0 ,hit)))
;;; Set on button release (as opposed to button press).
(defmacro sm::hit-up (hit)
- (` (logand sm::UpBits (nth 0 (, hit)))))
+ `(logand sm::UpBits (nth 0 ,hit)))
;;; Screen x position.
(defmacro sm::hit-x (hit) (list 'nth 1 hit))
;;; Screen y position.
;;; Milliseconds since last hit.
(defmacro sm::hit-delta (hit) (list 'nth 3 hit))
-(defmacro sm::hit-up-p (hit) ; A predicate.
- (` (not (zerop (sm::hit-up (, hit))))))
+(defmacro sm::hit-up-p (hit) ; A predicate.
+ `(not (zerop (sm::hit-up ,hit))))
;;;
;;; Loc accessors. for sm::window-xy
(defmacro eval-in-buffer (buffer &rest forms)
"Macro to switches to BUFFER, evaluates FORMS, returns to original buffer."
;; When you don't need the complete window context of eval-in-window
- (` (let ((StartBuffer (current-buffer)))
+ `(let ((StartBuffer (current-buffer)))
(unwind-protect
- (progn
- (set-buffer (, buffer))
- (,@ forms))
- (set-buffer StartBuffer)))))
+ (progn
+ (set-buffer ,buffer)
+ ,@forms)
+ (set-buffer StartBuffer))))
(put 'eval-in-buffer 'lisp-indent-function 1)
;;;
(defmacro eval-in-window (window &rest forms)
"Switch to WINDOW, evaluate FORMS, return to original window."
- (` (let ((OriginallySelectedWindow (selected-window)))
- (unwind-protect
- (progn
- (select-window (, window))
- (,@ forms))
- (select-window OriginallySelectedWindow)))))
+ `(let ((OriginallySelectedWindow (selected-window)))
+ (unwind-protect
+ (progn
+ (select-window ,window)
+ ,@forms)
+ (select-window OriginallySelectedWindow))))
(put 'eval-in-window 'lisp-indent-function 1)
;;;
"Switches to each window and evaluates FORM. Optional argument
YESMINI says to include the minibuffer as a window.
This is a macro, and does not evaluate its arguments."
- (` (let ((OriginallySelectedWindow (selected-window)))
- (unwind-protect
- (while (progn
- (, form)
- (not (eq OriginallySelectedWindow
- (select-window
- (next-window nil (, yesmini)))))))
- (select-window OriginallySelectedWindow)))))
+ `(let ((OriginallySelectedWindow (selected-window)))
+ (unwind-protect
+ (while (progn
+ ,form
+ (not (eq OriginallySelectedWindow
+ (select-window
+ (next-window nil ,yesmini))))))
+ (select-window OriginallySelectedWindow))))
(put 'eval-in-window 'lisp-indent-function 0)
(defun move-to-loc (x y)
(eval-and-compile
- (condition-case ()
- (require 'custom)
- (error nil))
- (if (and (featurep 'custom) (fboundp 'custom-declare-variable))
- nil ;; We've got what we needed
- ;; We have the old custom-library, hack around it!
- (defmacro defgroup (&rest args)
- nil)
- (defmacro defface (var values doc &rest args)
- (` (make-face (, var))))
- (defmacro defcustom (var value doc &rest args)
- (` (defvar (, var) (, value) (, doc))))))
+ (condition-case ()
+ (require 'custom)
+ (error nil))
+ (if (and (featurep 'custom) (fboundp 'custom-declare-variable))
+ nil ;; We've got what we needed
+ ;; We have the old custom-library, hack around it!
+ (defmacro defgroup (&rest args)
+ nil)
+ (defmacro defface (var values doc &rest args)
+ `(make-face ,var))
+ (defmacro defcustom (var value doc &rest args)
+ `(defvar ,var ,value ,doc))))
;; User options
;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
projects / emacs.git / commitdiff