comparison lisp/emacs-lisp/cl-extra.el @ 28565:69dea80bbb87

Don't quote keywords. (cl-old-mapc): New variable. (mapc): Use it. (cl-map-intervals): Use with-current-buffer. Don't check for next-property-change. (cl-map-overlays): Use with-current-buffer. (cl-expt): Remove. (copy-tree, remprop): Define unconditionally.

28564:e79438733ef2

      (while cl-list
	(cl-push (funcall cl-func cl-list) cl-res)
	(setq cl-list (cdr cl-list)))
      (nreverse cl-res))))

(defun mapc (cl-func cl-seq &rest cl-rest)
  "Like `mapcar', but does not accumulate values returned by the function."
  (if cl-rest
      (apply 'map nil cl-func cl-seq cl-rest)
    (mapcar cl-func cl-seq))
  cl-seq)

(defun mapl (cl-func cl-list &rest cl-rest)
  "Like `maplist', but does not accumulate values returned by the function."
  (if cl-rest
      (apply 'maplist cl-func cl-list cl-rest)

(defun cl-map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end)
  (or cl-what (setq cl-what (current-buffer)))
  (if (bufferp cl-what)
      (let (cl-mark cl-mark2 (cl-next t) cl-next2)
	(save-excursion
	  (set-buffer cl-what)
	  (setq cl-mark (copy-marker (or cl-start (point-min))))
	  (setq cl-mark2 (and cl-end (copy-marker cl-end))))
	(while (and cl-next (or (not cl-mark2) (< cl-mark cl-mark2)))
	  (setq cl-next (and (fboundp 'next-property-change)
			     (if cl-prop (next-single-property-change
					  cl-mark cl-prop cl-what)
			       (next-property-change cl-mark cl-what)))
		cl-next2 (or cl-next (save-excursion
				       (set-buffer cl-what) (point-max))))
	  (funcall cl-func (prog1 (marker-position cl-mark)
			     (set-marker cl-mark cl-next2))
		   (if cl-mark2 (min cl-next2 cl-mark2) cl-next2)))
	(set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil)))
    (or cl-start (setq cl-start 0))
    (or cl-end (setq cl-end (length cl-what)))
    (while (< cl-start cl-end)
      (let ((cl-next (or (and (fboundp 'next-property-change)
			      (if cl-prop (next-single-property-change
					   cl-start cl-prop cl-what)
				(next-property-change cl-start cl-what)))
			 cl-end)))
	(funcall cl-func cl-start (min cl-next cl-end))
	(setq cl-start cl-next)))))

(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)
	(save-excursion
	  (set-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

	  (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 (save-excursion (set-buffer cl-buffer)
				   (copy-marker (or cl-start (point-min)))))
	  (cl-mark2 (and cl-end (save-excursion (set-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

	    g2)
	(while (< (setq g2 (/ (+ g (/ a g)) 2)) g)
	  (setq g g2))
	g)
    (if (eq a 0) 0 (signal 'arith-error nil))))

(defun cl-expt (x y)
  "Return X raised to the power of Y.  Works only for integer arguments."
  (if (<= y 0) (if (= y 0) 1 (if (memq x '(-1 1)) (cl-expt x (- y)) 0))
    (* (if (= (% y 2) 0) 1 x) (cl-expt (* x x) (/ y 2)))))
(or (and (fboundp 'expt) (subrp (symbol-function 'expt)))
    (defalias 'expt 'cl-expt))

(defun floor* (x &optional y)
  "Return a list of the floor of X and the fractional part of X.
With two arguments, return floor and remainder of their quotient."
  (let ((q (floor x y)))

    (if (and vecp (vectorp tree))
	(let ((i (length (setq tree (copy-sequence tree)))))
	  (while (>= (setq i (1- i)) 0)
	    (aset tree i (cl-copy-tree (aref tree i) vecp))))))
  tree)
(or (and (fboundp 'copy-tree) (subrp (symbol-function 'copy-tree)))
    (defalias 'copy-tree 'cl-copy-tree))


;;; Property lists.

(defun get* (sym tag &optional def)    ; See compiler macro in cl-macs.el

  "Remove from SYMBOL's plist the property PROP and its value."
  (let ((plist (symbol-plist sym)))
    (if (and plist (eq tag (car plist)))
	(progn (setplist sym (cdr (cdr plist))) t)
      (cl-do-remf plist tag))))
(or (and (fboundp 'remprop) (subrp (symbol-function 'remprop)))
    (defalias 'remprop 'cl-remprop))



;;; Hash tables.

(defun cl-make-hash-table (&rest cl-keys)
  "Make an empty Common Lisp-style hash-table.
Keywords supported:  :test :size
The Common Lisp keywords :rehash-size and :rehash-threshold are ignored."
  (let ((cl-test (or (car (cdr (memq ':test cl-keys))) 'eql))
	(cl-size (or (car (cdr (memq ':size cl-keys))) 20)))
    (make-hash-table :size cl-size :test cl-size)))

(defun cl-hash-table-p (x)
  "Return t if OBJECT is a hash table."
  (or (hash-table-p x)

      (setq sym (symbol-value (intern-soft str array))))
    (list (and sym (cond ((or (eq test 'eq)
			      (and (eq test 'eql) (not (numberp key))))
			  (assq key sym))
			 ((memq test '(eql equal)) (assoc key sym))
			 (t (assoc* key sym ':test test))))
	  sym str)))

(defun cl-gethash (key table &optional def)
  "Look up KEY in HASH-TABLE; return corresponding value, or DEFAULT."
  (if (consp table)

28565:69dea80bbb87

      (while cl-list
	(cl-push (funcall cl-func cl-list) cl-res)
	(setq cl-list (cdr cl-list)))
      (nreverse cl-res))))

(defvar cl-old-mapc (symbol-function 'mapc))

(defun mapc (cl-func cl-seq &rest cl-rest)
  "Like `mapcar', but does not accumulate values returned by the function."
  (if cl-rest
      (progn (apply 'map nil cl-func cl-seq cl-rest)
	     cl-seq)
    (funcall #'cl-old-mapc cl-func cl-seq)))

(defun mapl (cl-func cl-list &rest cl-rest)
  "Like `maplist', but does not accumulate values returned by the function."
  (if cl-rest
      (apply 'maplist cl-func cl-list cl-rest)

(defun cl-map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end)
  (or cl-what (setq cl-what (current-buffer)))
  (if (bufferp cl-what)
      (let (cl-mark cl-mark2 (cl-next t) cl-next2)
	(with-current-buffer cl-what
	  (setq cl-mark (copy-marker (or cl-start (point-min))))
	  (setq cl-mark2 (and cl-end (copy-marker cl-end))))
	(while (and cl-next (or (not cl-mark2) (< cl-mark cl-mark2)))
	  (setq cl-next (if cl-prop (next-single-property-change
				     cl-mark cl-prop cl-what)
			  (next-property-change cl-mark cl-what))
		cl-next2 (or cl-next (with-current-buffer cl-what
				       (point-max))))
	  (funcall cl-func (prog1 (marker-position cl-mark)
			     (set-marker cl-mark cl-next2))
		   (if cl-mark2 (min cl-next2 cl-mark2) cl-next2)))
	(set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil)))
    (or cl-start (setq cl-start 0))
    (or cl-end (setq cl-end (length cl-what)))
    (while (< cl-start cl-end)
      (let ((cl-next (or (if cl-prop (next-single-property-change
				      cl-start cl-prop cl-what)
			   (next-property-change cl-start cl-what))
			 cl-end)))
	(funcall cl-func cl-start (min cl-next cl-end))
	(setq cl-start cl-next)))))

(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

	  (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

	    g2)
	(while (< (setq g2 (/ (+ g (/ a g)) 2)) g)
	  (setq g g2))
	g)
    (if (eq a 0) 0 (signal 'arith-error nil))))

(defun floor* (x &optional y)
  "Return a list of the floor of X and the fractional part of X.
With two arguments, return floor and remainder of their quotient."
  (let ((q (floor x y)))

    (if (and vecp (vectorp tree))
	(let ((i (length (setq tree (copy-sequence tree)))))
	  (while (>= (setq i (1- i)) 0)
	    (aset tree i (cl-copy-tree (aref tree i) vecp))))))
  tree)
(defalias 'copy-tree 'cl-copy-tree)


;;; Property lists.

(defun get* (sym tag &optional def)    ; See compiler macro in cl-macs.el

  "Remove from SYMBOL's plist the property PROP and its value."
  (let ((plist (symbol-plist sym)))
    (if (and plist (eq tag (car plist)))
	(progn (setplist sym (cdr (cdr plist))) t)
      (cl-do-remf plist tag))))
(defalias 'remprop 'cl-remprop)



;;; Hash tables.

(defun cl-make-hash-table (&rest cl-keys)
  "Make an empty Common Lisp-style hash-table.
Keywords supported:  :test :size
The Common Lisp keywords :rehash-size and :rehash-threshold are ignored."
  (let ((cl-test (or (car (cdr (memq :test cl-keys))) 'eql))
	(cl-size (or (car (cdr (memq :size cl-keys))) 20)))
    (make-hash-table :size cl-size :test cl-size)))

(defun cl-hash-table-p (x)
  "Return t if OBJECT is a hash table."
  (or (hash-table-p x)

      (setq sym (symbol-value (intern-soft str array))))
    (list (and sym (cond ((or (eq test 'eq)
			      (and (eq test 'eql) (not (numberp key))))
			  (assq key sym))
			 ((memq test '(eql equal)) (assoc key sym))
			 (t (assoc* key sym :test test))))
	  sym str)))

(defun cl-gethash (key table &optional def)
  "Look up KEY in HASH-TABLE; return corresponding value, or DEFAULT."
  (if (consp table)