If the value is nil, `pop' returns nil but does not actually
change the list."
(declare (debug (gv-place)))
- (list 'car
- (if (symbolp place)
- ;; So we can use `pop' in the bootstrap before `gv' can be used.
- (list 'prog1 place (list 'setq place (list 'cdr place)))
- (gv-letplace (getter setter) place
- `(prog1 ,getter ,(funcall setter `(cdr ,getter)))))))
+ ;; We use `car-safe' here instead of `car' because the behavior is the same
+ ;; (if it's not a cons cell, the `cdr' would have signaled an error already),
+ ;; but `car-safe' is total, so the byte-compiler can safely remove it if the
+ ;; result is not used.
+ `(car-safe
+ ,(if (symbolp place)
+ ;; So we can use `pop' in the bootstrap before `gv' can be used.
+ (list 'prog1 place (list 'setq place (list 'cdr place)))
+ (gv-letplace (getter setter) place
+ `(prog1 ,getter ,(funcall setter `(cdr ,getter)))))))
(defmacro when (cond &rest body)
"If COND yields non-nil, do BODY, else return nil.
(while t
(signal 'user-error (list (apply #'format format args)))))
+(defun define-error (name message &optional parent)
+ "Define NAME as a new error signal.
+MESSAGE is a string that will be output to the echo area if such an error
+is signaled without being caught by a `condition-case'.
+PARENT is either a signal or a list of signals from which it inherits.
+Defaults to `error'."
+ (unless parent (setq parent 'error))
+ (let ((conditions
+ (if (consp parent)
+ (apply #'nconc
+ (mapcar (lambda (parent)
+ (cons parent
+ (or (get parent 'error-conditions)
+ (error "Unknown signal `%s'" parent))))
+ parent))
+ (cons parent (get parent 'error-conditions)))))
+ (put name 'error-conditions
+ (delete-dups (copy-sequence (cons name conditions))))
+ (when message (put name 'error-message message))))
+
;; We put this here instead of in frame.el so that it's defined even on
;; systems where frame.el isn't loaded.
(defun frame-configuration-p (object)
This hook is normally set up with a function to put the buffer in Help
mode.")
-;; The `assert' macro from the cl package signals
-;; `cl-assertion-failed' at runtime so always define it.
-(put 'cl-assertion-failed 'error-conditions '(error))
-(put 'cl-assertion-failed 'error-message (purecopy "Assertion failed"))
-
(defconst user-emacs-directory
(if (eq system-type 'ms-dos)
;; MS-DOS cannot have initial dot.
(setq object (indirect-function object t)))
(and (subrp object) (eq (cdr (subr-arity object)) 'unevalled)))
+(defun macrop (object)
+ "Non-nil if and only if OBJECT is a macro."
+ (let ((def (indirect-function object t)))
+ (when (consp def)
+ (or (eq 'macro (car def))
+ (and (autoloadp def) (memq (nth 4 def) '(macro t)))))))
+
(defun field-at-pos (pos)
"Return the field at position POS, taking stickiness etc into account."
(let ((raw-field (get-char-property (field-beginning pos) 'field)))
\f
;;;; Text clones
-(defun text-clone-maintain (ol1 after beg end &optional _len)
+(defvar text-clone--maintaining nil)
+
+(defun text-clone--maintain (ol1 after beg end &optional _len)
"Propagate the changes made under the overlay OL1 to the other clones.
This is used on the `modification-hooks' property of text clones."
- (when (and after (not undo-in-progress) (overlay-start ol1))
+ (when (and after (not undo-in-progress)
+ (not text-clone--maintaining)
+ (overlay-start ol1))
(let ((margin (if (overlay-get ol1 'text-clone-spreadp) 1 0)))
(setq beg (max beg (+ (overlay-start ol1) margin)))
(setq end (min end (- (overlay-end ol1) margin)))
(tail (- (overlay-end ol1) end))
(str (buffer-substring beg end))
(nothing-left t)
- (inhibit-modification-hooks t))
+ (text-clone--maintaining t))
(dolist (ol2 (overlay-get ol1 'text-clones))
(let ((oe (overlay-end ol2)))
(unless (or (eq ol1 ol2) (null oe))
(unless (> mod-beg (point))
(save-excursion (insert str))
(delete-region mod-beg (point)))
- ;;(overlay-put ol2 'modification-hooks '(text-clone-maintain))
+ ;;(overlay-put ol2 'modification-hooks '(text-clone--maintain))
))))
(if nothing-left (delete-overlay ol1))))))))
(>= pt-end (point-max))
(>= start (point-max)))
0 1))
+ ;; FIXME: Reuse overlays at point to extend dups!
(ol1 (make-overlay (- start start-margin) (+ end end-margin) nil t))
(ol2 (make-overlay (- (point) start-margin) (+ pt-end end-margin) nil t))
(dups (list ol1 ol2)))
- (overlay-put ol1 'modification-hooks '(text-clone-maintain))
+ (overlay-put ol1 'modification-hooks '(text-clone--maintain))
(when spreadp (overlay-put ol1 'text-clone-spreadp t))
(when syntax (overlay-put ol1 'text-clone-syntax syntax))
;;(overlay-put ol1 'face 'underline)
(overlay-put ol1 'evaporate t)
(overlay-put ol1 'text-clones dups)
;;
- (overlay-put ol2 'modification-hooks '(text-clone-maintain))
+ (overlay-put ol2 'modification-hooks '(text-clone--maintain))
(when spreadp (overlay-put ol2 'text-clone-spreadp t))
(when syntax (overlay-put ol2 'text-clone-syntax syntax))
;;(overlay-put ol2 'face 'underline)
HCoop / bpt / emacs.git / blobdiff