diff options
Diffstat (limited to 'lisp/emacs-lisp/cl-extra.el')
| -rw-r--r-- | lisp/emacs-lisp/cl-extra.el | 140 |
1 files changed, 71 insertions, 69 deletions
diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index e5b64a50b5a..afc2adbee6d 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -38,6 +38,7 @@ ;;; Code: (require 'cl-lib) +(require 'seq) ;;; Type coercion. @@ -269,43 +270,20 @@ If so, return the true (non-nil) value returned by PREDICATE. ;;;###autoload (defun cl--map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg) (or cl-buffer (setq cl-buffer (current-buffer))) - (if (fboundp 'overlay-lists) - - ;; This is the preferred algorithm, though overlay-lists is undocumented. - (let (cl-ovl) - (with-current-buffer cl-buffer - (setq cl-ovl (overlay-lists)) - (if cl-start (setq cl-start (copy-marker cl-start))) - (if cl-end (setq cl-end (copy-marker cl-end)))) - (setq cl-ovl (nconc (car cl-ovl) (cdr cl-ovl))) - (while (and cl-ovl - (or (not (overlay-start (car cl-ovl))) - (and cl-end (>= (overlay-start (car cl-ovl)) cl-end)) - (and cl-start (<= (overlay-end (car cl-ovl)) cl-start)) - (not (funcall cl-func (car cl-ovl) cl-arg)))) - (setq cl-ovl (cdr cl-ovl))) - (if cl-start (set-marker cl-start nil)) - (if cl-end (set-marker cl-end nil))) - - ;; This alternate algorithm fails to find zero-length overlays. - (let ((cl-mark (with-current-buffer cl-buffer - (copy-marker (or cl-start (point-min))))) - (cl-mark2 (and cl-end (with-current-buffer cl-buffer - (copy-marker cl-end)))) - cl-pos cl-ovl) - (while (save-excursion - (and (setq cl-pos (marker-position cl-mark)) - (< cl-pos (or cl-mark2 (point-max))) - (progn - (set-buffer cl-buffer) - (setq cl-ovl (overlays-at cl-pos)) - (set-marker cl-mark (next-overlay-change cl-pos))))) - (while (and cl-ovl - (or (/= (overlay-start (car cl-ovl)) cl-pos) - (not (and (funcall cl-func (car cl-ovl) cl-arg) - (set-marker cl-mark nil))))) - (setq cl-ovl (cdr cl-ovl)))) - (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil))))) + (let (cl-ovl) + (with-current-buffer cl-buffer + (setq cl-ovl (overlay-lists)) + (if cl-start (setq cl-start (copy-marker cl-start))) + (if cl-end (setq cl-end (copy-marker cl-end)))) + (setq cl-ovl (nconc (car cl-ovl) (cdr cl-ovl))) + (while (and cl-ovl + (or (not (overlay-start (car cl-ovl))) + (and cl-end (>= (overlay-start (car cl-ovl)) cl-end)) + (and cl-start (<= (overlay-end (car cl-ovl)) cl-start)) + (not (funcall cl-func (car cl-ovl) cl-arg)))) + (setq cl-ovl (cdr cl-ovl))) + (if cl-start (set-marker cl-start nil)) + (if cl-end (set-marker cl-end nil)))) ;;; Support for `setf'. ;;;###autoload @@ -406,6 +384,42 @@ With two arguments, return rounding and remainder of their quotient." "Return 1 if X is positive, -1 if negative, 0 if zero." (cond ((> x 0) 1) ((< x 0) -1) (t 0))) +;;;###autoload +(cl-defun cl-parse-integer (string &key start end radix junk-allowed) + "Parse integer from the substring of STRING from START to END. +STRING may be surrounded by whitespace chars (chars with syntax ` '). +Other non-digit chars are considered junk. +RADIX is an integer between 2 and 36, the default is 10. Signal +an error if the substring between START and END cannot be parsed +as an integer unless JUNK-ALLOWED is non-nil." + (cl-check-type string string) + (let* ((start (or start 0)) + (len (length string)) + (end (or end len)) + (radix (or radix 10))) + (or (<= start end len) + (error "Bad interval: [%d, %d)" start end)) + (cl-flet ((skip-whitespace () + (while (and (< start end) + (= 32 (char-syntax (aref string start)))) + (setq start (1+ start))))) + (skip-whitespace) + (let ((sign (cl-case (and (< start end) (aref string start)) + (?+ (cl-incf start) +1) + (?- (cl-incf start) -1) + (t +1))) + digit sum) + (while (and (< start end) + (setq digit (cl-digit-char-p (aref string start) radix))) + (setq sum (+ (* (or sum 0) radix) digit) + start (1+ start))) + (skip-whitespace) + (cond ((and junk-allowed (null sum)) sum) + (junk-allowed (* sign sum)) + ((or (/= start end) (null sum)) + (error "Not an integer string: `%s'" string)) + (t (* sign sum))))))) + ;; Random numbers. @@ -508,28 +522,10 @@ If END is omitted, it defaults to the length of the sequence. If START or END is negative, it counts from the end." (declare (gv-setter (lambda (new) - `(progn (cl-replace ,seq ,new :start1 ,start :end1 ,end) - ,new)))) - (if (stringp seq) (substring seq start end) - (let (len) - (and end (< end 0) (setq end (+ end (setq len (length seq))))) - (if (< start 0) (setq start (+ start (or len (setq len (length seq)))))) - (cond ((listp seq) - (if (> start 0) (setq seq (nthcdr start seq))) - (if end - (let ((res nil)) - (while (>= (setq end (1- end)) start) - (push (pop seq) res)) - (nreverse res)) - (copy-sequence seq))) - (t - (or end (setq end (or len (length seq)))) - (let ((res (make-vector (max (- end start) 0) nil)) - (i 0)) - (while (< start end) - (aset res i (aref seq start)) - (setq i (1+ i) start (1+ start))) - res)))))) + (macroexp-let2 nil new new + `(progn (cl-replace ,seq ,new :start1 ,start :end1 ,end) + ,new))))) + (seq-subseq seq start end)) ;;;###autoload (defun cl-concatenate (type &rest seqs) @@ -575,7 +571,7 @@ If START or END is negative, it counts from the end." "Return the value of SYMBOL's PROPNAME property, or DEFAULT if none. \n(fn SYMBOL PROPNAME &optional DEFAULT)" (declare (compiler-macro cl--compiler-macro-get) - (gv-setter (lambda (store) `(put ,sym ,tag ,store)))) + (gv-setter (lambda (store) (ignore def) `(put ,sym ,tag ,store)))) (or (get sym tag) (and def ;; Make sure `def' is really absent as opposed to set to nil. @@ -593,15 +589,14 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (declare (gv-expander (lambda (do) (gv-letplace (getter setter) plist - (macroexp-let2 nil k tag - (macroexp-let2 nil d def - (funcall do `(cl-getf ,getter ,k ,d) - (lambda (v) - (macroexp-let2 nil val v - `(progn - ,(funcall setter - `(cl--set-getf ,getter ,k ,val)) - ,val)))))))))) + (macroexp-let2* nil ((k tag) (d def)) + (funcall do `(cl-getf ,getter ,k ,d) + (lambda (v) + (macroexp-let2 nil val v + `(progn + ,(funcall setter + `(cl--set-getf ,getter ,k ,val)) + ,val))))))))) (setplist '--cl-getf-symbol-- plist) (or (get '--cl-getf-symbol-- tag) ;; Originally we called cl-get here, @@ -634,6 +629,13 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (progn (setplist sym (cdr (cdr plist))) t) (cl--do-remf plist tag)))) +;;; Streams. + +;;;###autoload +(defun cl-fresh-line (&optional stream) + "Output a newline unless already at the beginning of a line." + (terpri stream 'ensure)) + ;;; Some debugging aids. (defun cl-prettyprint (form) |