-;;; cl-extra.el --- Common Lisp features, part 2
+;;; cl-extra.el --- Common Lisp features, part 2 -*- lexical-binding: t -*-
;; Copyright (C) 1993, 2000-2012 Free Software Foundation, Inc.
;;; Control structures.
;;;###autoload
-(defun cl-mapcar-many (cl-func cl-seqs)
+(defun cl--mapcar-many (cl-func cl-seqs)
(if (cdr (cdr cl-seqs))
(let* ((cl-res nil)
(cl-n (apply 'min (mapcar 'length cl-seqs)))
;;;###autoload
(defun cl-maplist (cl-func cl-list &rest cl-rest)
"Map FUNCTION to each sublist of LIST or LISTs.
-Like `mapcar', except applies to lists and their cdr's rather than to
+Like `cl-mapcar', except applies to lists and their cdr's rather than to
the elements themselves.
\n(fn FUNCTION LIST...)"
(if cl-rest
(setq cl-list (cdr cl-list)))
(nreverse cl-res))))
+;;;###autoload
(defun cl-mapc (cl-func cl-seq &rest cl-rest)
- "Like `mapcar', but does not accumulate values returned by the function.
+ "Like `cl-mapcar', but does not accumulate values returned by the function.
\n(fn FUNCTION SEQUENCE...)"
(if cl-rest
(progn (apply 'cl-map nil cl-func cl-seq cl-rest)
;;;###autoload
(defun cl-mapcan (cl-func cl-seq &rest cl-rest)
- "Like `mapcar', but nconc's together the values returned by the function.
+ "Like `cl-mapcar', but nconc's together the values returned by the function.
\n(fn FUNCTION SEQUENCE...)"
(apply 'nconc (apply 'cl-mapcar cl-func cl-seq cl-rest)))
(not (apply 'cl-every cl-pred cl-seq cl-rest)))
;;;###autoload
-(defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base)
+(defun cl--map-keymap-recursively (cl-func-rec cl-map &optional cl-base)
(or cl-base
(setq cl-base (copy-sequence [0])))
(map-keymap
(lambda (cl-key cl-bind)
(aset cl-base (1- (length cl-base)) cl-key)
(if (keymapp cl-bind)
- (cl-map-keymap-recursively
+ (cl--map-keymap-recursively
cl-func-rec cl-bind
(vconcat cl-base (list 0)))
(funcall cl-func-rec cl-base cl-bind))))
cl-map))
;;;###autoload
-(defun cl-map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end)
+(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)
(setq cl-start cl-next)))))
;;;###autoload
-(defun cl-map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg)
+(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)
(setq cl-ovl (cdr cl-ovl))))
(set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil)))))
-;;; Support for `cl-setf'.
+;;; Support for `setf'.
;;;###autoload
-(defun cl-set-frame-visible-p (frame val)
+(defun cl--set-frame-visible-p (frame val)
(cond ((null val) (make-frame-invisible frame))
((eq val 'icon) (iconify-frame frame))
(t (make-frame-visible frame)))
val)
-;;; Support for `cl-progv'.
-(defvar cl-progv-save)
-;;;###autoload
-(defun cl-progv-before (syms values)
- (while syms
- (push (if (boundp (car syms))
- (cons (car syms) (symbol-value (car syms)))
- (car syms)) cl-progv-save)
- (if values
- (set (pop syms) (pop values))
- (makunbound (pop syms)))))
-
-(defun cl-progv-after ()
- (while cl-progv-save
- (if (consp (car cl-progv-save))
- (set (car (car cl-progv-save)) (cdr (car cl-progv-save)))
- (makunbound (car cl-progv-save)))
- (pop cl-progv-save)))
-
;;; Numbers.
;; Implementation limits.
-(defun cl-finite-do (func a b)
- (condition-case err
+(defun cl--finite-do (func a b)
+ (condition-case _
(let ((res (funcall func a b))) ; check for IEEE infinity
(and (numberp res) (/= res (/ res 2)) res))
(arith-error nil)))
(or cl-most-positive-float (not (numberp '2e1))
(let ((x '2e0) y z)
;; Find maximum exponent (first two loops are optimizations)
- (while (cl-finite-do '* x x) (setq x (* x x)))
- (while (cl-finite-do '* x (/ x 2)) (setq x (* x (/ x 2))))
- (while (cl-finite-do '+ x x) (setq x (+ x x)))
+ (while (cl--finite-do '* x x) (setq x (* x x)))
+ (while (cl--finite-do '* x (/ x 2)) (setq x (* x (/ x 2))))
+ (while (cl--finite-do '+ x x) (setq x (+ x x)))
(setq z x y (/ x 2))
;; Now cl-fill in 1's in the mantissa.
- (while (and (cl-finite-do '+ x y) (/= (+ x y) x))
+ (while (and (cl--finite-do '+ x y) (/= (+ x y) x))
(setq x (+ x y) y (/ y 2)))
(setq cl-most-positive-float x
cl-most-negative-float (- x))
;; Divide down until mantissa starts rounding.
(setq x (/ x z) y (/ 16 z) x (* x y))
- (while (condition-case err (and (= x (* (/ x 2) 2)) (> (/ y 2) 0))
+ (while (condition-case _ (and (= x (* (/ x 2) 2)) (> (/ y 2) 0))
(arith-error nil))
(setq x (/ x 2) y (/ y 2)))
(setq cl-least-positive-normalized-float y
cl-least-negative-normalized-float (- y))
;; Divide down until value underflows to zero.
(setq x (/ 1 z) y x)
- (while (condition-case err (> (/ x 2) 0) (arith-error nil))
+ (while (condition-case _ (> (/ x 2) 0) (arith-error nil))
(setq x (/ x 2)))
(setq cl-least-positive-float x
cl-least-negative-float (- x))
"Return the subsequence of SEQ from START to END.
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)))))
(defun cl-get (sym tag &optional def)
"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))
+ (declare (compiler-macro cl--compiler-macro-get)
+ (gv-setter (lambda (store) `(put ,sym ,tag ,store))))
(or (get sym tag)
(and def
+ ;; Make sure `def' is really absent as opposed to set to nil.
(let ((plist (symbol-plist sym)))
(while (and plist (not (eq (car plist) tag)))
(setq plist (cdr (cdr plist))))
"Search PROPLIST for property PROPNAME; return its value or DEFAULT.
PROPLIST is a list of the sort returned by `symbol-plist'.
\n(fn PROPLIST PROPNAME &optional DEFAULT)"
+ (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)
+ (funcall setter
+ `(cl--set-getf ,getter ,k ,v))))))))))
(setplist '--cl-getf-symbol-- plist)
(or (get '--cl-getf-symbol-- tag)
;; Originally we called cl-get here,
;; but that fails, because cl-get has a compiler macro
;; definition that uses getf!
(when def
+ ;; Make sure `def' is really absent as opposed to set to nil.
(while (and plist (not (eq (car plist) tag)))
(setq plist (cdr (cdr plist))))
(if plist (car (cdr plist)) def))))
;;;###autoload
-(defun cl-set-getf (plist tag val)
+(defun cl--set-getf (plist tag val)
(let ((p plist))
(while (and p (not (eq (car p) tag))) (setq p (cdr (cdr p))))
(if p (progn (setcar (cdr p) val) plist) (cl-list* tag val plist))))
;;;###autoload
-(defun cl-do-remf (plist tag)
+(defun cl--do-remf (plist tag)
(let ((p (cdr plist)))
(while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p))))
(and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t))))
(let ((plist (symbol-plist sym)))
(if (and plist (eq tag (car plist)))
(progn (setplist sym (cdr (cdr plist))) t)
- (cl-do-remf plist tag))))
+ (cl--do-remf plist tag))))
;;; Some debugging aids.
(forward-sexp)
(delete-char 1))
(goto-char (1+ pt))
- (cl-do-prettyprint)))
+ (cl--do-prettyprint)))
-(defun cl-do-prettyprint ()
+(defun cl--do-prettyprint ()
(skip-chars-forward " ")
(if (looking-at "(")
(let ((skip (or (looking-at "((") (looking-at "(prog")
(looking-at "(unwind-protect ")
(looking-at "(function (")
- (looking-at "(cl-block-wrapper ")))
+ (looking-at "(cl--block-wrapper ")))
(two (or (looking-at "(defun ") (looking-at "(defmacro ")))
(let (or (looking-at "(let\\*? ") (looking-at "(while ")))
(set (looking-at "(p?set[qf] ")))
(and (>= (current-column) 78) (progn (backward-sexp) t))))
(let ((nl t))
(forward-char 1)
- (cl-do-prettyprint)
- (or skip (looking-at ")") (cl-do-prettyprint))
- (or (not two) (looking-at ")") (cl-do-prettyprint))
+ (cl--do-prettyprint)
+ (or skip (looking-at ")") (cl--do-prettyprint))
+ (or (not two) (looking-at ")") (cl--do-prettyprint))
(while (not (looking-at ")"))
(if set (setq nl (not nl)))
(if nl (insert "\n"))
(lisp-indent-line)
- (cl-do-prettyprint))
+ (cl--do-prettyprint))
(forward-char 1))))
(forward-sexp)))
;;;###autoload
(defun cl-prettyexpand (form &optional full)
+ "Expand macros in FORM and insert the pretty-printed result.
+Optional argument FULL non-nil means to expand all macros,
+including `cl-block' and `cl-eval-when'."
(message "Expanding...")
- (let ((cl-macroexpand-cmacs full) (cl-compiling-file full)
+ (let ((cl--compiling-file full)
(byte-compile-macro-environment nil))
(setq form (macroexpand-all form
(and (not full) '((cl-block) (cl-eval-when)))))
;; Local variables:
;; byte-compile-dynamic: t
-;; byte-compile-warnings: (not cl-functions)
;; generated-autoload-file: "cl-loaddefs.el"
;; End:
HCoop / bpt / emacs.git / blobdiff