;;; Code:
-(require 'cl)
+(require 'cl-lib)
(defmacro cl-pop2 (place)
+ (declare (debug edebug-sexps))
`(prog1 (car (cdr ,place))
(setq ,place (cdr (cdr ,place)))))
-(put 'cl-pop2 'edebug-form-spec 'edebug-sexps)
(defvar cl-optimize-safety)
(defvar cl-optimize-speed)
;;; Check if no side effects, and executes quickly.
(defun cl-simple-expr-p (x &optional size)
(or size (setq size 10))
- (if (and (consp x) (not (memq (car x) '(quote function function*))))
+ (if (and (consp x) (not (memq (car x) '(quote function cl-function))))
(and (symbolp (car x))
(or (memq (car x) cl-simple-funcs)
(get (car x) 'side-effect-free))
;;; Check if no side effects.
(defun cl-safe-expr-p (x)
- (or (not (and (consp x) (not (memq (car x) '(quote function function*)))))
+ (or (not (and (consp x) (not (memq (car x) '(quote function cl-function)))))
(and (symbolp (car x))
(or (memq (car x) cl-simple-funcs)
(memq (car x) cl-safe-funcs)
(defun cl-const-expr-p (x)
(cond ((consp x)
(or (eq (car x) 'quote)
- (and (memq (car x) '(function function*))
+ (and (memq (car x) '(function cl-function))
(or (symbolp (nth 1 x))
(and (eq (car-safe (nth 1 x)) 'lambda) 'func)))))
((symbolp x) (and (memq x '(nil t)) t))
;;; Count number of times X refers to Y. Return nil for 0 times.
(defun cl-expr-contains (x y)
- ;; FIXME: This is naive, and it will count Y as referred twice in
+ ;; FIXME: This is naive, and it will cl-count Y as referred twice in
;; (let ((Y 1)) Y) even though it should be 0. Also it is often called on
;; non-macroexpanded code, so it may also miss some occurrences that would
;; only appear in the expanded code.
(cond ((equal y x) 1)
- ((and (consp x) (not (memq (car x) '(quote function function*))))
+ ((and (consp x) (not (memq (car x) '(quote function cl-function))))
(let ((sum 0))
(while (consp x)
(setq sum (+ sum (or (cl-expr-contains (pop x) y) 0))))
(defvar cl--gensym-counter)
;;;###autoload
-(defun gensym (&optional prefix)
+(defun cl-gensym (&optional prefix)
"Generate a new uninterned symbol.
The name is made by appending a number to PREFIX, default \"G\"."
(let ((pfix (if (stringp prefix) prefix "G"))
(make-symbol (format "%s%d" pfix num))))
;;;###autoload
-(defun gentemp (&optional prefix)
+(defun cl-gentemp (&optional prefix)
"Generate a new interned symbol with a unique name.
The name is made by appending a number to PREFIX, default \"G\"."
(let ((pfix (if (stringp prefix) prefix "G"))
;;; Program structure.
(def-edebug-spec cl-declarations
- (&rest ("declare" &rest sexp)))
+ (&rest ("cl-declare" &rest sexp)))
(def-edebug-spec cl-declarations-or-string
(&or stringp cl-declarations))
(&or ([&or (symbolp arg) arg] &optional def-form arg) arg))
;;;###autoload
-(defmacro defun* (name args &rest body)
+(defmacro cl-defun (name args &rest body)
"Define NAME as a function.
Like normal `defun', except ARGLIST allows full Common Lisp conventions,
-and BODY is implicitly surrounded by (block NAME ...).
+and BODY is implicitly surrounded by (cl-block NAME ...).
\(fn NAME ARGLIST [DOCSTRING] BODY...)"
(declare (debug
;; Same as defun but use cl-lambda-list.
- (&define [&or name ("setf" :name setf name)]
+ (&define [&or name ("cl-setf" :name cl-setf name)]
cl-lambda-list
cl-declarations-or-string
[&optional ("interactive" interactive)]
. [&or arg nil])))
;;;###autoload
-(defmacro defmacro* (name args &rest body)
+(defmacro cl-defmacro (name args &rest body)
"Define NAME as a macro.
Like normal `defmacro', except ARGLIST allows full Common Lisp conventions,
-and BODY is implicitly surrounded by (block NAME ...).
+and BODY is implicitly surrounded by (cl-block NAME ...).
\(fn NAME ARGLIST [DOCSTRING] BODY...)"
(declare (debug
;;[&optional ("interactive" interactive)]
def-body)))
-;; Redefine function-form to also match function*
+;; Redefine function-form to also match cl-function
(def-edebug-spec function-form
;; form at the end could also handle "function",
;; but recognize it specially to avoid wrapping function forms.
(&or ([&or "quote" "function"] &or symbolp lambda-expr)
- ("function*" function*)
+ ("cl-function" cl-function)
form))
;;;###autoload
-(defmacro function* (func)
+(defmacro cl-function (func)
"Introduce a function.
Like normal `function', except that if argument is a lambda form,
its argument list allows full Common Lisp conventions."
`(progn ,@(cdr (cdr (car res)))
(put ',func ',prop #'(lambda . ,(cdr res))))))
-(defconst lambda-list-keywords
+(defconst cl-lambda-list-keywords
'(&optional &rest &key &allow-other-keys &aux &whole &body &environment))
(defvar cl-macro-environment nil
It is a list of elements of the form either:
- (SYMBOL . FUNCTION) where FUNCTION is the macro expansion function.
- (SYMBOL-NAME . EXPANSION) where SYMBOL-NAME is the name of a symbol macro.")
-(defvar bind-block) (defvar bind-defs) (defvar bind-enquote)
-(defvar bind-inits) (defvar bind-lets) (defvar bind-forms)
+(defvar cl-bind-block) (defvar cl-bind-defs) (defvar cl-bind-enquote)
+(defvar cl-bind-inits) (defvar cl-bind-lets) (defvar cl-bind-forms)
(declare-function help-add-fundoc-usage "help-fns" (docstring arglist))
((not (consp x)) x)
((memq state '(nil &rest)) (cl--make-usage-args x))
(t ;(VAR INITFORM SVAR) or ((KEYWORD VAR) INITFORM SVAR).
- (list*
+ (cl-list*
(if (and (consp (car x)) (eq state '&key))
(list (caar x) (cl--make-usage-var (nth 1 (car x))))
(cl--make-usage-var (car x)))
))))
arglist)))
-(defun cl-transform-lambda (form bind-block)
+(defun cl-transform-lambda (form cl-bind-block)
(let* ((args (car form)) (body (cdr form)) (orig-args args)
- (bind-defs nil) (bind-enquote nil)
- (bind-inits nil) (bind-lets nil) (bind-forms nil)
+ (cl-bind-defs nil) (cl-bind-enquote nil)
+ (cl-bind-inits nil) (cl-bind-lets nil) (cl-bind-forms nil)
(header nil) (simple-args nil))
(while (or (stringp (car body))
- (memq (car-safe (car body)) '(interactive declare)))
+ (memq (car-safe (car body)) '(interactive cl-declare)))
(push (pop body) header))
- (setq args (if (listp args) (copy-list args) (list '&rest args)))
+ (setq args (if (listp args) (cl-copy-list args) (list '&rest args)))
(let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
- (if (setq bind-defs (cadr (memq '&cl-defs args)))
- (setq args (delq '&cl-defs (delq bind-defs args))
- bind-defs (cadr bind-defs)))
- (if (setq bind-enquote (memq '&cl-quote args))
+ (if (setq cl-bind-defs (cadr (memq '&cl-defs args)))
+ (setq args (delq '&cl-defs (delq cl-bind-defs args))
+ cl-bind-defs (cadr cl-bind-defs)))
+ (if (setq cl-bind-enquote (memq '&cl-quote args))
(setq args (delq '&cl-quote args)))
(if (memq '&whole args) (error "&whole not currently implemented"))
(let* ((p (memq '&environment args)) (v (cadr p)))
(while (and args (symbolp (car args))
(not (memq (car args) '(nil &rest &body &key &aux)))
(not (and (eq (car args) '&optional)
- (or bind-defs (consp (cadr args))))))
+ (or cl-bind-defs (consp (cadr args))))))
(push (pop args) simple-args))
- (or (eq bind-block 'cl-none)
- (setq body (list `(block ,bind-block ,@body))))
+ (or (eq cl-bind-block 'cl-none)
+ (setq body (list `(cl-block ,cl-bind-block ,@body))))
(if (null args)
- (list* nil (nreverse simple-args) (nconc (nreverse header) body))
+ (cl-list* nil (nreverse simple-args) (nconc (nreverse header) body))
(if (memq '&optional simple-args) (push '&optional args))
(cl-do-arglist args nil (- (length simple-args)
(if (memq '&optional simple-args) 1 0)))
- (setq bind-lets (nreverse bind-lets))
- (list* (and bind-inits `(eval-when (compile load eval)
- ,@(nreverse bind-inits)))
+ (setq cl-bind-lets (nreverse cl-bind-lets))
+ (cl-list* (and cl-bind-inits `(cl-eval-when (compile load eval)
+ ,@(nreverse cl-bind-inits)))
(nconc (nreverse simple-args)
- (list '&rest (car (pop bind-lets))))
+ (list '&rest (car (pop cl-bind-lets))))
(nconc (let ((hdr (nreverse header)))
;; Macro expansion can take place in the middle of
;; apparently harmless computation, so it should not
(cons 'fn
(cl--make-usage-args orig-args))))
hdr)))
- (list `(let* ,bind-lets
- ,@(nreverse bind-forms)
+ (list `(let* ,cl-bind-lets
+ ,@(nreverse cl-bind-forms)
,@body)))))))
(defun cl-do-arglist (args expr &optional num) ; uses bind-*
(if (nlistp args)
- (if (or (memq args lambda-list-keywords) (not (symbolp args)))
+ (if (or (memq args cl-lambda-list-keywords) (not (symbolp args)))
(error "Invalid argument name: %s" args)
- (push (list args expr) bind-lets))
- (setq args (copy-list args))
+ (push (list args expr) cl-bind-lets))
+ (setq args (cl-copy-list args))
(let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
(let ((p (memq '&body args))) (if p (setcar p '&rest)))
(if (memq '&environment args) (error "&environment used incorrectly"))
(if (listp (cadr restarg))
(setq restarg (make-symbol "--cl-rest--"))
(setq restarg (cadr restarg)))
- (push (list restarg expr) bind-lets)
+ (push (list restarg expr) cl-bind-lets)
(if (eq (car args) '&whole)
- (push (list (cl-pop2 args) restarg) bind-lets))
+ (push (list (cl-pop2 args) restarg) cl-bind-lets))
(let ((p args))
(setq minarg restarg)
- (while (and p (not (memq (car p) lambda-list-keywords)))
+ (while (and p (not (memq (car p) cl-lambda-list-keywords)))
(or (eq p args) (setq minarg (list 'cdr minarg)))
(setq p (cdr p)))
(if (memq (car p) '(nil &aux))
(setq minarg `(= (length ,restarg)
- ,(length (ldiff args p)))
+ ,(length (cl-ldiff args p)))
exactarg (not (eq args p)))))
- (while (and args (not (memq (car args) lambda-list-keywords)))
+ (while (and args (not (memq (car args) cl-lambda-list-keywords)))
(let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car)
restarg)))
(cl-do-arglist
(if (or laterarg (= safety 0)) poparg
`(if ,minarg ,poparg
(signal 'wrong-number-of-arguments
- (list ,(and (not (eq bind-block 'cl-none))
- `',bind-block)
+ (list ,(and (not (eq cl-bind-block 'cl-none))
+ `',cl-bind-block)
(length ,restarg)))))))
(setq num (1+ num) laterarg t))
(while (and (eq (car args) '&optional) (pop args))
- (while (and args (not (memq (car args) lambda-list-keywords)))
+ (while (and args (not (memq (car args) cl-lambda-list-keywords)))
(let ((arg (pop args)))
(or (consp arg) (setq arg (list arg)))
(if (cddr arg) (cl-do-arglist (nth 2 arg) `(and ,restarg t)))
(let ((def (if (cdr arg) (nth 1 arg)
- (or (car bind-defs)
- (nth 1 (assq (car arg) bind-defs)))))
+ (or (car cl-bind-defs)
+ (nth 1 (assq (car arg) cl-bind-defs)))))
(poparg `(pop ,restarg)))
- (and def bind-enquote (setq def `',def))
+ (and def cl-bind-enquote (setq def `',def))
(cl-do-arglist (car arg)
(if def `(if ,restarg ,poparg ,def) poparg))
(setq num (1+ num))))))
(push `(if ,restarg
(signal 'wrong-number-of-arguments
(list
- ,(and (not (eq bind-block 'cl-none))
- `',bind-block)
+ ,(and (not (eq cl-bind-block 'cl-none))
+ `',cl-bind-block)
(+ ,num (length ,restarg)))))
- bind-forms)))
+ cl-bind-forms)))
(while (and (eq (car args) '&key) (pop args))
- (while (and args (not (memq (car args) lambda-list-keywords)))
+ (while (and args (not (memq (car args) cl-lambda-list-keywords)))
(let ((arg (pop args)))
(or (consp arg) (setq arg (list arg)))
(let* ((karg (if (consp (car arg)) (caar arg)
(intern (format ":%s" (car arg)))))
- (varg (if (consp (car arg)) (cadar arg) (car arg)))
+ (varg (if (consp (car arg)) (cl-cadar arg) (car arg)))
(def (if (cdr arg) (cadr arg)
- (or (car bind-defs) (cadr (assq varg bind-defs)))))
+ (or (car cl-bind-defs) (cadr (assq varg cl-bind-defs)))))
(look `(memq ',karg ,restarg)))
- (and def bind-enquote (setq def `',def))
+ (and def cl-bind-enquote (setq def `',def))
(if (cddr arg)
(let* ((temp (or (nth 2 arg) (make-symbol "--cl-var--")))
(val `(car (cdr ,temp))))
,(format "Keyword argument %%s not one of %s"
keys)
(car ,var)))))))
- (push `(let ((,var ,restarg)) ,check) bind-forms)))
+ (push `(let ((,var ,restarg)) ,check) cl-bind-forms)))
(while (and (eq (car args) '&aux) (pop args))
- (while (and args (not (memq (car args) lambda-list-keywords)))
+ (while (and args (not (memq (car args) cl-lambda-list-keywords)))
(if (consp (car args))
- (if (and bind-enquote (cadar args))
+ (if (and cl-bind-enquote (cl-cadar args))
(cl-do-arglist (caar args)
`',(cadr (pop args)))
(cl-do-arglist (caar args) (cadr (pop args))))
(let ((res nil) (kind nil) arg)
(while (consp args)
(setq arg (pop args))
- (if (memq arg lambda-list-keywords) (setq kind arg)
+ (if (memq arg cl-lambda-list-keywords) (setq kind arg)
(if (eq arg '&cl-defs) (pop args)
(and (consp arg) kind (setq arg (car arg)))
(and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg)))
(nconc res (and args (list args))))))
;;;###autoload
-(defmacro destructuring-bind (args expr &rest body)
+(defmacro cl-destructuring-bind (args expr &rest body)
(declare (indent 2)
(debug (&define cl-macro-list def-form cl-declarations def-body)))
- (let* ((bind-lets nil) (bind-forms nil) (bind-inits nil)
- (bind-defs nil) (bind-block 'cl-none) (bind-enquote nil))
+ (let* ((cl-bind-lets nil) (cl-bind-forms nil) (cl-bind-inits nil)
+ (cl-bind-defs nil) (cl-bind-block 'cl-none) (cl-bind-enquote nil))
(cl-do-arglist (or args '(&aux)) expr)
- (append '(progn) bind-inits
- (list `(let* ,(nreverse bind-lets)
- ,@(nreverse bind-forms) ,@body)))))
+ (append '(progn) cl-bind-inits
+ (list `(let* ,(nreverse cl-bind-lets)
+ ,@(nreverse cl-bind-forms) ,@body)))))
-;;; The `eval-when' form.
+;;; The `cl-eval-when' form.
(defvar cl-not-toplevel nil)
;;;###autoload
-(defmacro eval-when (when &rest body)
+(defmacro cl-eval-when (when &rest body)
"Control when BODY is evaluated.
If `compile' is in WHEN, BODY is evaluated when compiled at top-level.
If `load' is in WHEN, BODY is evaluated when loaded after top-level compile.
(defun cl-compile-time-too (form)
(or (and (symbolp (car-safe form)) (get (car-safe form) 'byte-hunk-handler))
(setq form (macroexpand
- form (cons '(eval-when) byte-compile-macro-environment))))
+ form (cons '(cl-eval-when) byte-compile-macro-environment))))
(cond ((eq (car-safe form) 'progn)
(cons 'progn (mapcar 'cl-compile-time-too (cdr form))))
- ((eq (car-safe form) 'eval-when)
+ ((eq (car-safe form) 'cl-eval-when)
(let ((when (nth 1 form)))
(if (or (memq 'eval when) (memq :execute when))
- `(eval-when (compile ,@when) ,@(cddr form))
+ `(cl-eval-when (compile ,@when) ,@(cddr form))
form)))
(t (eval form) form)))
;;;###autoload
-(defmacro load-time-value (form &optional read-only)
+(defmacro cl-load-time-value (form &optional read-only)
"Like `progn', but evaluates the body at load time.
The result of the body appears to the compiler as a quoted constant."
(declare (debug (form &optional sexp)))
(if (cl-compiling-file)
- (let* ((temp (gentemp "--cl-load-time--"))
+ (let* ((temp (cl-gentemp "--cl-load-time--"))
(set `(set ',temp ,form)))
(if (and (fboundp 'byte-compile-file-form-defmumble)
(boundp 'this-kind) (boundp 'that-one))
;;; Conditional control structures.
;;;###autoload
-(defmacro case (expr &rest clauses)
+(defmacro cl-case (expr &rest clauses)
"Eval EXPR and choose among clauses on that value.
Each clause looks like (KEYLIST BODY...). EXPR is evaluated and compared
against each key in each KEYLIST; the corresponding BODY is evaluated.
-If no clause succeeds, case returns nil. A single atom may be used in
+If no clause succeeds, cl-case returns nil. A single atom may be used in
place of a KEYLIST of one atom. A KEYLIST of t or `otherwise' is
allowed only in the final clause, and matches if no other keys match.
Key values are compared by `eql'.
(function
(lambda (c)
(cons (cond ((memq (car c) '(t otherwise)) t)
- ((eq (car c) 'ecase-error-flag)
- `(error "ecase failed: %s, %s"
+ ((eq (car c) 'cl--ecase-error-flag)
+ `(error "cl-ecase failed: %s, %s"
,temp ',(reverse head-list)))
((listp (car c))
(setq head-list (append (car c) head-list))
- `(member* ,temp ',(car c)))
+ `(cl-member ,temp ',(car c)))
(t
(if (memq (car c) head-list)
(error "Duplicate key in case: %s"
`(let ((,temp ,expr)) ,body))))
;;;###autoload
-(defmacro ecase (expr &rest clauses)
- "Like `case', but error if no case fits.
+(defmacro cl-ecase (expr &rest clauses)
+ "Like `cl-case', but error if no cl-case fits.
`otherwise'-clauses are not allowed.
\n(fn EXPR (KEYLIST BODY...)...)"
- (declare (indent 1) (debug case))
- `(case ,expr ,@clauses (ecase-error-flag)))
+ (declare (indent 1) (debug cl-case))
+ `(cl-case ,expr ,@clauses (cl--ecase-error-flag)))
;;;###autoload
-(defmacro typecase (expr &rest clauses)
+(defmacro cl-typecase (expr &rest clauses)
"Evals EXPR, chooses among clauses on that value.
Each clause looks like (TYPE BODY...). EXPR is evaluated and, if it
satisfies TYPE, the corresponding BODY is evaluated. If no clause succeeds,
-typecase returns nil. A TYPE of t or `otherwise' is allowed only in the
+cl-typecase returns nil. A TYPE of t or `otherwise' is allowed only in the
final clause, and matches if no other keys match.
\n(fn EXPR (TYPE BODY...)...)"
(declare (indent 1)
(function
(lambda (c)
(cons (cond ((eq (car c) 'otherwise) t)
- ((eq (car c) 'ecase-error-flag)
- `(error "etypecase failed: %s, %s"
+ ((eq (car c) 'cl--ecase-error-flag)
+ `(error "cl-etypecase failed: %s, %s"
,temp ',(reverse type-list)))
(t
(push (car c) type-list)
`(let ((,temp ,expr)) ,body))))
;;;###autoload
-(defmacro etypecase (expr &rest clauses)
- "Like `typecase', but error if no case fits.
+(defmacro cl-etypecase (expr &rest clauses)
+ "Like `cl-typecase', but error if no case fits.
`otherwise'-clauses are not allowed.
\n(fn EXPR (TYPE BODY...)...)"
- (declare (indent 1) (debug typecase))
- `(typecase ,expr ,@clauses (ecase-error-flag)))
+ (declare (indent 1) (debug cl-typecase))
+ `(cl-typecase ,expr ,@clauses (cl--ecase-error-flag)))
;;; Blocks and exits.
;;;###autoload
-(defmacro block (name &rest body)
+(defmacro cl-block (name &rest body)
"Define a lexically-scoped block named NAME.
-NAME may be any symbol. Code inside the BODY forms can call `return-from'
+NAME may be any symbol. Code inside the BODY forms can call `cl-return-from'
to jump prematurely out of the block. This differs from `catch' and `throw'
in two respects: First, the NAME is an unevaluated symbol rather than a
quoted symbol or other form; and second, NAME is lexically rather than
,@body))))
;;;###autoload
-(defmacro return (&optional result)
+(defmacro cl-return (&optional result)
"Return from the block named nil.
-This is equivalent to `(return-from nil RESULT)'."
+This is equivalent to `(cl-return-from nil RESULT)'."
(declare (debug (&optional form)))
- `(return-from nil ,result))
+ `(cl-return-from nil ,result))
;;;###autoload
-(defmacro return-from (name &optional result)
+(defmacro cl-return-from (name &optional result)
"Return from the block named NAME.
-This jumps out to the innermost enclosing `(block NAME ...)' form,
+This jumps out to the innermost enclosing `(cl-block NAME ...)' form,
returning RESULT from that form (or nil if RESULT is omitted).
This is compatible with Common Lisp, but note that `defun' and
`defmacro' do not create implicit blocks as they do in Common Lisp."
`(cl-block-throw ',name2 ,result)))
-;;; The "loop" macro.
+;;; The "cl-loop" macro.
-(defvar loop-args) (defvar loop-accum-var) (defvar loop-accum-vars)
-(defvar loop-bindings) (defvar loop-body) (defvar loop-destr-temps)
-(defvar loop-finally) (defvar loop-finish-flag) (defvar loop-first-flag)
-(defvar loop-initially) (defvar loop-map-form) (defvar loop-name)
-(defvar loop-result) (defvar loop-result-explicit)
-(defvar loop-result-var) (defvar loop-steps) (defvar loop-symbol-macs)
+(defvar cl-loop-args) (defvar cl-loop-accum-var) (defvar cl-loop-accum-vars)
+(defvar cl-loop-bindings) (defvar cl-loop-body) (defvar cl-loop-destr-temps)
+(defvar cl-loop-finally) (defvar cl-loop-finish-flag)
+(defvar cl-loop-first-flag)
+(defvar cl-loop-initially) (defvar cl-loop-map-form) (defvar cl-loop-name)
+(defvar cl-loop-result) (defvar cl-loop-result-explicit)
+(defvar cl-loop-result-var) (defvar cl-loop-steps) (defvar cl-loop-symbol-macs)
;;;###autoload
-(defmacro loop (&rest loop-args)
- "The Common Lisp `loop' macro.
+(defmacro cl-loop (&rest cl-loop-args)
+ "The Common Lisp `cl-loop' macro.
Valid clauses are:
for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM,
for VAR in LIST by FUNC, for VAR on LIST by FUNC, for VAR = INIT then EXPR,
\(fn CLAUSE...)"
(declare (debug (&rest &or symbolp form)))
- (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list loop-args))))))
- `(block nil (while t ,@loop-args))
- (let ((loop-name nil) (loop-bindings nil)
- (loop-body nil) (loop-steps nil)
- (loop-result nil) (loop-result-explicit nil)
- (loop-result-var nil) (loop-finish-flag nil)
- (loop-accum-var nil) (loop-accum-vars nil)
- (loop-initially nil) (loop-finally nil)
- (loop-map-form nil) (loop-first-flag nil)
- (loop-destr-temps nil) (loop-symbol-macs nil))
- (setq loop-args (append loop-args '(cl-end-loop)))
- (while (not (eq (car loop-args) 'cl-end-loop)) (cl-parse-loop-clause))
- (if loop-finish-flag
- (push `((,loop-finish-flag t)) loop-bindings))
- (if loop-first-flag
- (progn (push `((,loop-first-flag t)) loop-bindings)
- (push `(setq ,loop-first-flag nil) loop-steps)))
- (let* ((epilogue (nconc (nreverse loop-finally)
- (list (or loop-result-explicit loop-result))))
- (ands (cl-loop-build-ands (nreverse loop-body)))
- (while-body (nconc (cadr ands) (nreverse loop-steps)))
+ (if (not (memq t (mapcar 'symbolp (delq nil (delq t (cl-copy-list cl-loop-args))))))
+ `(cl-block nil (while t ,@cl-loop-args))
+ (let ((cl-loop-name nil) (cl-loop-bindings nil)
+ (cl-loop-body nil) (cl-loop-steps nil)
+ (cl-loop-result nil) (cl-loop-result-explicit nil)
+ (cl-loop-result-var nil) (cl-loop-finish-flag nil)
+ (cl-loop-accum-var nil) (cl-loop-accum-vars nil)
+ (cl-loop-initially nil) (cl-loop-finally nil)
+ (cl-loop-map-form nil) (cl-loop-first-flag nil)
+ (cl-loop-destr-temps nil) (cl-loop-symbol-macs nil))
+ (setq cl-loop-args (append cl-loop-args '(cl-end-loop)))
+ (while (not (eq (car cl-loop-args) 'cl-end-loop)) (cl-parse-loop-clause))
+ (if cl-loop-finish-flag
+ (push `((,cl-loop-finish-flag t)) cl-loop-bindings))
+ (if cl-loop-first-flag
+ (progn (push `((,cl-loop-first-flag t)) cl-loop-bindings)
+ (push `(setq ,cl-loop-first-flag nil) cl-loop-steps)))
+ (let* ((epilogue (nconc (nreverse cl-loop-finally)
+ (list (or cl-loop-result-explicit cl-loop-result))))
+ (ands (cl-loop-build-ands (nreverse cl-loop-body)))
+ (while-body (nconc (cadr ands) (nreverse cl-loop-steps)))
(body (append
- (nreverse loop-initially)
- (list (if loop-map-form
- `(block --cl-finish--
- ,(subst
+ (nreverse cl-loop-initially)
+ (list (if cl-loop-map-form
+ `(cl-block --cl-finish--
+ ,(cl-subst
(if (eq (car ands) t) while-body
(cons `(or ,(car ands)
- (return-from --cl-finish--
+ (cl-return-from --cl-finish--
nil))
while-body))
- '--cl-map loop-map-form))
+ '--cl-map cl-loop-map-form))
`(while ,(car ands) ,@while-body)))
- (if loop-finish-flag
- (if (equal epilogue '(nil)) (list loop-result-var)
- `((if ,loop-finish-flag
- (progn ,@epilogue) ,loop-result-var)))
+ (if cl-loop-finish-flag
+ (if (equal epilogue '(nil)) (list cl-loop-result-var)
+ `((if ,cl-loop-finish-flag
+ (progn ,@epilogue) ,cl-loop-result-var)))
epilogue))))
- (if loop-result-var (push (list loop-result-var) loop-bindings))
- (while loop-bindings
- (if (cdar loop-bindings)
- (setq body (list (cl-loop-let (pop loop-bindings) body t)))
+ (if cl-loop-result-var (push (list cl-loop-result-var) cl-loop-bindings))
+ (while cl-loop-bindings
+ (if (cdar cl-loop-bindings)
+ (setq body (list (cl-loop-let (pop cl-loop-bindings) body t)))
(let ((lets nil))
- (while (and loop-bindings
- (not (cdar loop-bindings)))
- (push (car (pop loop-bindings)) lets))
+ (while (and cl-loop-bindings
+ (not (cdar cl-loop-bindings)))
+ (push (car (pop cl-loop-bindings)) lets))
(setq body (list (cl-loop-let lets body nil))))))
- (if loop-symbol-macs
- (setq body (list `(symbol-macrolet ,loop-symbol-macs ,@body))))
- `(block ,loop-name ,@body)))))
+ (if cl-loop-symbol-macs
+ (setq body (list `(cl-symbol-macrolet ,cl-loop-symbol-macs ,@body))))
+ `(cl-block ,cl-loop-name ,@body)))))
-;; Below is a complete spec for loop, in several parts that correspond
+;; Below is a complete spec for cl-loop, in several parts that correspond
;; to the syntax given in CLtL2. The specs do more than specify where
;; the forms are; it also specifies, as much as Edebug allows, all the
-;; syntactically valid loop clauses. The disadvantage of this
+;; syntactically valid cl-loop clauses. The disadvantage of this
;; completeness is rigidity, but the "for ... being" clause allows
;; arbitrary extensions of the form: [symbolp &rest &or symbolp form].
-;; (def-edebug-spec loop
+;; (def-edebug-spec cl-loop
;; ([&optional ["named" symbolp]]
;; [&rest
;; &or
(defun cl-parse-loop-clause () ; uses loop-*
- (let ((word (pop loop-args))
+ (let ((word (pop cl-loop-args))
(hash-types '(hash-key hash-keys hash-value hash-values))
(key-types '(key-code key-codes key-seq key-seqs
key-binding key-bindings)))
(cond
- ((null loop-args)
- (error "Malformed `loop' macro"))
+ ((null cl-loop-args)
+ (error "Malformed `cl-loop' macro"))
((eq word 'named)
- (setq loop-name (pop loop-args)))
+ (setq cl-loop-name (pop cl-loop-args)))
((eq word 'initially)
- (if (memq (car loop-args) '(do doing)) (pop loop-args))
- (or (consp (car loop-args)) (error "Syntax error on `initially' clause"))
- (while (consp (car loop-args))
- (push (pop loop-args) loop-initially)))
+ (if (memq (car cl-loop-args) '(do doing)) (pop cl-loop-args))
+ (or (consp (car cl-loop-args)) (error "Syntax error on `initially' clause"))
+ (while (consp (car cl-loop-args))
+ (push (pop cl-loop-args) cl-loop-initially)))
((eq word 'finally)
- (if (eq (car loop-args) 'return)
- (setq loop-result-explicit (or (cl-pop2 loop-args) '(quote nil)))
- (if (memq (car loop-args) '(do doing)) (pop loop-args))
- (or (consp (car loop-args)) (error "Syntax error on `finally' clause"))
- (if (and (eq (caar loop-args) 'return) (null loop-name))
- (setq loop-result-explicit (or (nth 1 (pop loop-args)) '(quote nil)))
- (while (consp (car loop-args))
- (push (pop loop-args) loop-finally)))))
+ (if (eq (car cl-loop-args) 'return)
+ (setq cl-loop-result-explicit (or (cl-pop2 cl-loop-args) '(quote nil)))
+ (if (memq (car cl-loop-args) '(do doing)) (pop cl-loop-args))
+ (or (consp (car cl-loop-args)) (error "Syntax error on `finally' clause"))
+ (if (and (eq (caar cl-loop-args) 'return) (null cl-loop-name))
+ (setq cl-loop-result-explicit (or (nth 1 (pop cl-loop-args)) '(quote nil)))
+ (while (consp (car cl-loop-args))
+ (push (pop cl-loop-args) cl-loop-finally)))))
((memq word '(for as))
(let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil)
(ands nil))
(while
- ;; Use `gensym' rather than `make-symbol'. It's important that
+ ;; Use `cl-gensym' rather than `make-symbol'. It's important that
;; (not (eq (symbol-name var1) (symbol-name var2))) because
;; these vars get added to the cl-macro-environment.
- (let ((var (or (pop loop-args) (gensym "--cl-var--"))))
- (setq word (pop loop-args))
- (if (eq word 'being) (setq word (pop loop-args)))
- (if (memq word '(the each)) (setq word (pop loop-args)))
+ (let ((var (or (pop cl-loop-args) (cl-gensym "--cl-var--"))))
+ (setq word (pop cl-loop-args))
+ (if (eq word 'being) (setq word (pop cl-loop-args)))
+ (if (memq word '(the each)) (setq word (pop cl-loop-args)))
(if (memq word '(buffer buffers))
- (setq word 'in loop-args (cons '(buffer-list) loop-args)))
+ (setq word 'in cl-loop-args (cons '(buffer-list) cl-loop-args)))
(cond
((memq word '(from downfrom upfrom to downto upto
above below by))
- (push word loop-args)
- (if (memq (car loop-args) '(downto above))
- (error "Must specify `from' value for downward loop"))
- (let* ((down (or (eq (car loop-args) 'downfrom)
- (memq (caddr loop-args) '(downto above))))
- (excl (or (memq (car loop-args) '(above below))
- (memq (caddr loop-args) '(above below))))
- (start (and (memq (car loop-args) '(from upfrom downfrom))
- (cl-pop2 loop-args)))
- (end (and (memq (car loop-args)
+ (push word cl-loop-args)
+ (if (memq (car cl-loop-args) '(downto above))
+ (error "Must specify `from' value for downward cl-loop"))
+ (let* ((down (or (eq (car cl-loop-args) 'downfrom)
+ (memq (cl-caddr cl-loop-args) '(downto above))))
+ (excl (or (memq (car cl-loop-args) '(above below))
+ (memq (cl-caddr cl-loop-args) '(above below))))
+ (start (and (memq (car cl-loop-args) '(from upfrom downfrom))
+ (cl-pop2 cl-loop-args)))
+ (end (and (memq (car cl-loop-args)
'(to upto downto above below))
- (cl-pop2 loop-args)))
- (step (and (eq (car loop-args) 'by) (cl-pop2 loop-args)))
+ (cl-pop2 cl-loop-args)))
+ (step (and (eq (car cl-loop-args) 'by) (cl-pop2 cl-loop-args)))
(end-var (and (not (cl-const-expr-p end))
(make-symbol "--cl-var--")))
(step-var (and (not (cl-const-expr-p step))
(if end
(push (list
(if down (if excl '> '>=) (if excl '< '<=))
- var (or end-var end)) loop-body))
+ var (or end-var end)) cl-loop-body))
(push (list var (list (if down '- '+) var
(or step-var step 1)))
loop-for-steps)))
(let* ((on (eq word 'on))
(temp (if (and on (symbolp var))
var (make-symbol "--cl-var--"))))
- (push (list temp (pop loop-args)) loop-for-bindings)
- (push `(consp ,temp) loop-body)
+ (push (list temp (pop cl-loop-args)) loop-for-bindings)
+ (push `(consp ,temp) cl-loop-body)
(if (eq word 'in-ref)
- (push (list var `(car ,temp)) loop-symbol-macs)
+ (push (list var `(car ,temp)) cl-loop-symbol-macs)
(or (eq temp var)
(progn
(push (list var nil) loop-for-bindings)
(push (list var (if on temp `(car ,temp)))
loop-for-sets))))
(push (list temp
- (if (eq (car loop-args) 'by)
- (let ((step (cl-pop2 loop-args)))
+ (if (eq (car cl-loop-args) 'by)
+ (let ((step (cl-pop2 cl-loop-args)))
(if (and (memq (car-safe step)
'(quote function
- function*))
+ cl-function))
(symbolp (nth 1 step)))
(list (nth 1 step) temp)
`(funcall ,step ,temp)))
loop-for-steps)))
((eq word '=)
- (let* ((start (pop loop-args))
- (then (if (eq (car loop-args) 'then) (cl-pop2 loop-args) start)))
+ (let* ((start (pop cl-loop-args))
+ (then (if (eq (car cl-loop-args) 'then) (cl-pop2 cl-loop-args) start)))
(push (list var nil) loop-for-bindings)
- (if (or ands (eq (car loop-args) 'and))
+ (if (or ands (eq (car cl-loop-args) 'and))
(progn
(push `(,var
- (if ,(or loop-first-flag
- (setq loop-first-flag
+ (if ,(or cl-loop-first-flag
+ (setq cl-loop-first-flag
(make-symbol "--cl-var--")))
,start ,var))
loop-for-sets)
(push (list var then) loop-for-steps))
(push (list var
(if (eq start then) start
- `(if ,(or loop-first-flag
- (setq loop-first-flag
+ `(if ,(or cl-loop-first-flag
+ (setq cl-loop-first-flag
(make-symbol "--cl-var--")))
,start ,then)))
loop-for-sets))))
((memq word '(across across-ref))
(let ((temp-vec (make-symbol "--cl-vec--"))
(temp-idx (make-symbol "--cl-idx--")))
- (push (list temp-vec (pop loop-args)) loop-for-bindings)
+ (push (list temp-vec (pop cl-loop-args)) loop-for-bindings)
(push (list temp-idx -1) loop-for-bindings)
(push `(< (setq ,temp-idx (1+ ,temp-idx))
- (length ,temp-vec)) loop-body)
+ (length ,temp-vec)) cl-loop-body)
(if (eq word 'across-ref)
(push (list var `(aref ,temp-vec ,temp-idx))
- loop-symbol-macs)
+ cl-loop-symbol-macs)
(push (list var nil) loop-for-bindings)
(push (list var `(aref ,temp-vec ,temp-idx))
loop-for-sets))))
((memq word '(element elements))
- (let ((ref (or (memq (car loop-args) '(in-ref of-ref))
- (and (not (memq (car loop-args) '(in of)))
+ (let ((ref (or (memq (car cl-loop-args) '(in-ref of-ref))
+ (and (not (memq (car cl-loop-args) '(in of)))
(error "Expected `of'"))))
- (seq (cl-pop2 loop-args))
+ (seq (cl-pop2 cl-loop-args))
(temp-seq (make-symbol "--cl-seq--"))
- (temp-idx (if (eq (car loop-args) 'using)
- (if (and (= (length (cadr loop-args)) 2)
- (eq (caadr loop-args) 'index))
- (cadr (cl-pop2 loop-args))
+ (temp-idx (if (eq (car cl-loop-args) 'using)
+ (if (and (= (length (cadr cl-loop-args)) 2)
+ (eq (cl-caadr cl-loop-args) 'index))
+ (cadr (cl-pop2 cl-loop-args))
(error "Bad `using' clause"))
(make-symbol "--cl-idx--"))))
(push (list temp-seq seq) loop-for-bindings)
(push (list temp-len `(length ,temp-seq))
loop-for-bindings)
(push (list var `(elt ,temp-seq temp-idx))
- loop-symbol-macs)
- (push `(< ,temp-idx ,temp-len) loop-body))
+ cl-loop-symbol-macs)
+ (push `(< ,temp-idx ,temp-len) cl-loop-body))
(push (list var nil) loop-for-bindings)
(push `(and ,temp-seq
(or (consp ,temp-seq)
(< ,temp-idx (length ,temp-seq))))
- loop-body)
+ cl-loop-body)
(push (list var `(if (consp ,temp-seq)
(pop ,temp-seq)
(aref ,temp-seq ,temp-idx)))
loop-for-steps)))
((memq word hash-types)
- (or (memq (car loop-args) '(in of)) (error "Expected `of'"))
- (let* ((table (cl-pop2 loop-args))
- (other (if (eq (car loop-args) 'using)
- (if (and (= (length (cadr loop-args)) 2)
- (memq (caadr loop-args) hash-types)
- (not (eq (caadr loop-args) word)))
- (cadr (cl-pop2 loop-args))
+ (or (memq (car cl-loop-args) '(in of)) (error "Expected `of'"))
+ (let* ((table (cl-pop2 cl-loop-args))
+ (other (if (eq (car cl-loop-args) 'using)
+ (if (and (= (length (cadr cl-loop-args)) 2)
+ (memq (cl-caadr cl-loop-args) hash-types)
+ (not (eq (cl-caadr cl-loop-args) word)))
+ (cadr (cl-pop2 cl-loop-args))
(error "Bad `using' clause"))
(make-symbol "--cl-var--"))))
(if (memq word '(hash-value hash-values))
(setq var (prog1 other (setq other var))))
- (setq loop-map-form
+ (setq cl-loop-map-form
`(maphash (lambda (,var ,other) . --cl-map) ,table))))
((memq word '(symbol present-symbol external-symbol
symbols present-symbols external-symbols))
- (let ((ob (and (memq (car loop-args) '(in of)) (cl-pop2 loop-args))))
- (setq loop-map-form
+ (let ((ob (and (memq (car cl-loop-args) '(in of)) (cl-pop2 cl-loop-args))))
+ (setq cl-loop-map-form
`(mapatoms (lambda (,var) . --cl-map) ,ob))))
((memq word '(overlay overlays extent extents))
(let ((buf nil) (from nil) (to nil))
- (while (memq (car loop-args) '(in of from to))
- (cond ((eq (car loop-args) 'from) (setq from (cl-pop2 loop-args)))
- ((eq (car loop-args) 'to) (setq to (cl-pop2 loop-args)))
- (t (setq buf (cl-pop2 loop-args)))))
- (setq loop-map-form
+ (while (memq (car cl-loop-args) '(in of from to))
+ (cond ((eq (car cl-loop-args) 'from) (setq from (cl-pop2 cl-loop-args)))
+ ((eq (car cl-loop-args) 'to) (setq to (cl-pop2 cl-loop-args)))
+ (t (setq buf (cl-pop2 cl-loop-args)))))
+ (setq cl-loop-map-form
`(cl-map-extents
(lambda (,var ,(make-symbol "--cl-var--"))
(progn . --cl-map) nil)
(let ((buf nil) (prop nil) (from nil) (to nil)
(var1 (make-symbol "--cl-var1--"))
(var2 (make-symbol "--cl-var2--")))
- (while (memq (car loop-args) '(in of property from to))
- (cond ((eq (car loop-args) 'from) (setq from (cl-pop2 loop-args)))
- ((eq (car loop-args) 'to) (setq to (cl-pop2 loop-args)))
- ((eq (car loop-args) 'property)
- (setq prop (cl-pop2 loop-args)))
- (t (setq buf (cl-pop2 loop-args)))))
+ (while (memq (car cl-loop-args) '(in of property from to))
+ (cond ((eq (car cl-loop-args) 'from) (setq from (cl-pop2 cl-loop-args)))
+ ((eq (car cl-loop-args) 'to) (setq to (cl-pop2 cl-loop-args)))
+ ((eq (car cl-loop-args) 'property)
+ (setq prop (cl-pop2 cl-loop-args)))
+ (t (setq buf (cl-pop2 cl-loop-args)))))
(if (and (consp var) (symbolp (car var)) (symbolp (cdr var)))
(setq var1 (car var) var2 (cdr var))
(push (list var `(cons ,var1 ,var2)) loop-for-sets))
- (setq loop-map-form
+ (setq cl-loop-map-form
`(cl-map-intervals
(lambda (,var1 ,var2) . --cl-map)
,buf ,prop ,from ,to))))
((memq word key-types)
- (or (memq (car loop-args) '(in of)) (error "Expected `of'"))
- (let ((map (cl-pop2 loop-args))
- (other (if (eq (car loop-args) 'using)
- (if (and (= (length (cadr loop-args)) 2)
- (memq (caadr loop-args) key-types)
- (not (eq (caadr loop-args) word)))
- (cadr (cl-pop2 loop-args))
+ (or (memq (car cl-loop-args) '(in of)) (error "Expected `of'"))
+ (let ((cl-map (cl-pop2 cl-loop-args))
+ (other (if (eq (car cl-loop-args) 'using)
+ (if (and (= (length (cadr cl-loop-args)) 2)
+ (memq (cl-caadr cl-loop-args) key-types)
+ (not (eq (cl-caadr cl-loop-args) word)))
+ (cadr (cl-pop2 cl-loop-args))
(error "Bad `using' clause"))
(make-symbol "--cl-var--"))))
(if (memq word '(key-binding key-bindings))
(setq var (prog1 other (setq other var))))
- (setq loop-map-form
+ (setq cl-loop-map-form
`(,(if (memq word '(key-seq key-seqs))
'cl-map-keymap-recursively 'map-keymap)
- (lambda (,var ,other) . --cl-map) ,map))))
+ (lambda (,var ,other) . --cl-map) ,cl-map))))
((memq word '(frame frames screen screens))
(let ((temp (make-symbol "--cl-var--")))
(push (list temp nil) loop-for-bindings)
(push `(prog1 (not (eq ,var ,temp))
(or ,temp (setq ,temp ,var)))
- loop-body)
+ cl-loop-body)
(push (list var `(next-frame ,var))
loop-for-steps)))
((memq word '(window windows))
- (let ((scr (and (memq (car loop-args) '(in of)) (cl-pop2 loop-args)))
+ (let ((scr (and (memq (car cl-loop-args) '(in of)) (cl-pop2 cl-loop-args)))
(temp (make-symbol "--cl-var--"))
(minip (make-symbol "--cl-minip--")))
(push (list var (if scr
;; If we started in the minibuffer, we need to
;; ensure that next-window will bring us back there
;; at some point. (Bug#7492).
- ;; (Consider using walk-windows instead of loop if
+ ;; (Consider using walk-windows instead of cl-loop if
;; you care about such things.)
(push (list minip `(minibufferp (window-buffer ,var)))
loop-for-bindings)
(push (list temp nil) loop-for-bindings)
(push `(prog1 (not (eq ,var ,temp))
(or ,temp (setq ,temp ,var)))
- loop-body)
+ cl-loop-body)
(push (list var `(next-window ,var ,minip))
loop-for-steps)))
(if handler
(funcall handler var)
(error "Expected a `for' preposition, found %s" word)))))
- (eq (car loop-args) 'and))
+ (eq (car cl-loop-args) 'and))
(setq ands t)
- (pop loop-args))
+ (pop cl-loop-args))
(if (and ands loop-for-bindings)
- (push (nreverse loop-for-bindings) loop-bindings)
- (setq loop-bindings (nconc (mapcar 'list loop-for-bindings)
- loop-bindings)))
+ (push (nreverse loop-for-bindings) cl-loop-bindings)
+ (setq cl-loop-bindings (nconc (mapcar 'list loop-for-bindings)
+ cl-loop-bindings)))
(if loop-for-sets
(push `(progn
,(cl-loop-let (nreverse loop-for-sets) 'setq ands)
- t) loop-body))
+ t) cl-loop-body))
(if loop-for-steps
- (push (cons (if ands 'psetq 'setq)
+ (push (cons (if ands 'cl-psetq 'setq)
(apply 'append (nreverse loop-for-steps)))
- loop-steps))))
+ cl-loop-steps))))
((eq word 'repeat)
(let ((temp (make-symbol "--cl-var--")))
- (push (list (list temp (pop loop-args))) loop-bindings)
- (push `(>= (setq ,temp (1- ,temp)) 0) loop-body)))
+ (push (list (list temp (pop cl-loop-args))) cl-loop-bindings)
+ (push `(>= (setq ,temp (1- ,temp)) 0) cl-loop-body)))
((memq word '(collect collecting))
- (let ((what (pop loop-args))
+ (let ((what (pop cl-loop-args))
(var (cl-loop-handle-accum nil 'nreverse)))
- (if (eq var loop-accum-var)
- (push `(progn (push ,what ,var) t) loop-body)
+ (if (eq var cl-loop-accum-var)
+ (push `(progn (push ,what ,var) t) cl-loop-body)
(push `(progn
(setq ,var (nconc ,var (list ,what)))
- t) loop-body))))
+ t) cl-loop-body))))
((memq word '(nconc nconcing append appending))
- (let ((what (pop loop-args))
+ (let ((what (pop cl-loop-args))
(var (cl-loop-handle-accum nil 'nreverse)))
(push `(progn
(setq ,var
- ,(if (eq var loop-accum-var)
+ ,(if (eq var cl-loop-accum-var)
`(nconc
(,(if (memq word '(nconc nconcing))
#'nreverse #'reverse)
,var)
`(,(if (memq word '(nconc nconcing))
#'nconc #'append)
- ,var ,what))) t) loop-body)))
+ ,var ,what))) t) cl-loop-body)))
((memq word '(concat concating))
- (let ((what (pop loop-args))
+ (let ((what (pop cl-loop-args))
(var (cl-loop-handle-accum "")))
- (push `(progn (callf concat ,var ,what) t) loop-body)))
+ (push `(progn (cl-callf concat ,var ,what) t) cl-loop-body)))
((memq word '(vconcat vconcating))
- (let ((what (pop loop-args))
+ (let ((what (pop cl-loop-args))
(var (cl-loop-handle-accum [])))
- (push `(progn (callf vconcat ,var ,what) t) loop-body)))
+ (push `(progn (cl-callf vconcat ,var ,what) t) cl-loop-body)))
((memq word '(sum summing))
- (let ((what (pop loop-args))
+ (let ((what (pop cl-loop-args))
(var (cl-loop-handle-accum 0)))
- (push `(progn (incf ,var ,what) t) loop-body)))
+ (push `(progn (cl-incf ,var ,what) t) cl-loop-body)))
((memq word '(count counting))
- (let ((what (pop loop-args))
+ (let ((what (pop cl-loop-args))
(var (cl-loop-handle-accum 0)))
- (push `(progn (if ,what (incf ,var)) t) loop-body)))
+ (push `(progn (if ,what (cl-incf ,var)) t) cl-loop-body)))
((memq word '(minimize minimizing maximize maximizing))
- (let* ((what (pop loop-args))
+ (let* ((what (pop cl-loop-args))
(temp (if (cl-simple-expr-p what) what (make-symbol "--cl-var--")))
(var (cl-loop-handle-accum nil))
(func (intern (substring (symbol-name word) 0 3)))
(set `(setq ,var (if ,var (,func ,var ,temp) ,temp))))
(push `(progn ,(if (eq temp what) set
`(let ((,temp ,what)) ,set))
- t) loop-body)))
+ t) cl-loop-body)))
((eq word 'with)
(let ((bindings nil))
- (while (progn (push (list (pop loop-args)
- (and (eq (car loop-args) '=) (cl-pop2 loop-args)))
+ (while (progn (push (list (pop cl-loop-args)
+ (and (eq (car cl-loop-args) '=) (cl-pop2 cl-loop-args)))
bindings)
- (eq (car loop-args) 'and))
- (pop loop-args))
- (push (nreverse bindings) loop-bindings)))
+ (eq (car cl-loop-args) 'and))
+ (pop cl-loop-args))
+ (push (nreverse bindings) cl-loop-bindings)))
((eq word 'while)
- (push (pop loop-args) loop-body))
+ (push (pop cl-loop-args) cl-loop-body))
((eq word 'until)
- (push `(not ,(pop loop-args)) loop-body))
+ (push `(not ,(pop cl-loop-args)) cl-loop-body))
((eq word 'always)
- (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--")))
- (push `(setq ,loop-finish-flag ,(pop loop-args)) loop-body)
- (setq loop-result t))
+ (or cl-loop-finish-flag (setq cl-loop-finish-flag (make-symbol "--cl-flag--")))
+ (push `(setq ,cl-loop-finish-flag ,(pop cl-loop-args)) cl-loop-body)
+ (setq cl-loop-result t))
((eq word 'never)
- (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--")))
- (push `(setq ,loop-finish-flag (not ,(pop loop-args)))
- loop-body)
- (setq loop-result t))
+ (or cl-loop-finish-flag (setq cl-loop-finish-flag (make-symbol "--cl-flag--")))
+ (push `(setq ,cl-loop-finish-flag (not ,(pop cl-loop-args)))
+ cl-loop-body)
+ (setq cl-loop-result t))
((eq word 'thereis)
- (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--")))
- (or loop-result-var (setq loop-result-var (make-symbol "--cl-var--")))
- (push `(setq ,loop-finish-flag
- (not (setq ,loop-result-var ,(pop loop-args))))
- loop-body))
+ (or cl-loop-finish-flag (setq cl-loop-finish-flag (make-symbol "--cl-flag--")))
+ (or cl-loop-result-var (setq cl-loop-result-var (make-symbol "--cl-var--")))
+ (push `(setq ,cl-loop-finish-flag
+ (not (setq ,cl-loop-result-var ,(pop cl-loop-args))))
+ cl-loop-body))
((memq word '(if when unless))
- (let* ((cond (pop loop-args))
- (then (let ((loop-body nil))
+ (let* ((cond (pop cl-loop-args))
+ (then (let ((cl-loop-body nil))
(cl-parse-loop-clause)
- (cl-loop-build-ands (nreverse loop-body))))
- (else (let ((loop-body nil))
- (if (eq (car loop-args) 'else)
- (progn (pop loop-args) (cl-parse-loop-clause)))
- (cl-loop-build-ands (nreverse loop-body))))
+ (cl-loop-build-ands (nreverse cl-loop-body))))
+ (else (let ((cl-loop-body nil))
+ (if (eq (car cl-loop-args) 'else)
+ (progn (pop cl-loop-args) (cl-parse-loop-clause)))
+ (cl-loop-build-ands (nreverse cl-loop-body))))
(simple (and (eq (car then) t) (eq (car else) t))))
- (if (eq (car loop-args) 'end) (pop loop-args))
+ (if (eq (car cl-loop-args) 'end) (pop cl-loop-args))
(if (eq word 'unless) (setq then (prog1 else (setq else then))))
(let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then))
(if simple (nth 1 else) (list (nth 2 else))))))
(if (cl-expr-contains form 'it)
(let ((temp (make-symbol "--cl-var--")))
- (push (list temp) loop-bindings)
+ (push (list temp) cl-loop-bindings)
(setq form `(if (setq ,temp ,cond)
- ,@(subst temp 'it form))))
+ ,@(cl-subst temp 'it form))))
(setq form `(if ,cond ,@form)))
- (push (if simple `(progn ,form t) form) loop-body))))
+ (push (if simple `(progn ,form t) form) cl-loop-body))))
((memq word '(do doing))
(let ((body nil))
- (or (consp (car loop-args)) (error "Syntax error on `do' clause"))
- (while (consp (car loop-args)) (push (pop loop-args) body))
- (push (cons 'progn (nreverse (cons t body))) loop-body)))
+ (or (consp (car cl-loop-args)) (error "Syntax error on `do' clause"))
+ (while (consp (car cl-loop-args)) (push (pop cl-loop-args) body))
+ (push (cons 'progn (nreverse (cons t body))) cl-loop-body)))
((eq word 'return)
- (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-var--")))
- (or loop-result-var (setq loop-result-var (make-symbol "--cl-var--")))
- (push `(setq ,loop-result-var ,(pop loop-args)
- ,loop-finish-flag nil) loop-body))
+ (or cl-loop-finish-flag (setq cl-loop-finish-flag (make-symbol "--cl-var--")))
+ (or cl-loop-result-var (setq cl-loop-result-var (make-symbol "--cl-var--")))
+ (push `(setq ,cl-loop-result-var ,(pop cl-loop-args)
+ ,cl-loop-finish-flag nil) cl-loop-body))
(t
(let ((handler (and (symbolp word) (get word 'cl-loop-handler))))
- (or handler (error "Expected a loop keyword, found %s" word))
+ (or handler (error "Expected a cl-loop keyword, found %s" word))
(funcall handler))))
- (if (eq (car loop-args) 'and)
- (progn (pop loop-args) (cl-parse-loop-clause)))))
+ (if (eq (car cl-loop-args) 'and)
+ (progn (pop cl-loop-args) (cl-parse-loop-clause)))))
(defun cl-loop-let (specs body par) ; uses loop-*
(let ((p specs) (temps nil) (new nil))
- (while (and p (or (symbolp (car-safe (car p))) (null (cadar p))))
+ (while (and p (or (symbolp (car-safe (car p))) (null (cl-cadar p))))
(setq p (cdr p)))
(and par p
(progn
(setq par nil p specs)
(while p
- (or (cl-const-expr-p (cadar p))
+ (or (cl-const-expr-p (cl-cadar p))
(let ((temp (make-symbol "--cl-var--")))
- (push (list temp (cadar p)) temps)
+ (push (list temp (cl-cadar p)) temps)
(setcar (cdar p) temp)))
(setq p (cdr p)))))
(while specs
(if (and (consp (car specs)) (listp (caar specs)))
(let* ((spec (caar specs)) (nspecs nil)
(expr (cadr (pop specs)))
- (temp (cdr (or (assq spec loop-destr-temps)
+ (temp (cdr (or (assq spec cl-loop-destr-temps)
(car (push (cons spec (or (last spec 0)
(make-symbol "--cl-var--")))
- loop-destr-temps))))))
+ cl-loop-destr-temps))))))
(push (list temp expr) new)
(while (consp spec)
(push (list (pop spec)
(setq specs (nconc (nreverse nspecs) specs)))
(push (pop specs) new)))
(if (eq body 'setq)
- (let ((set (cons (if par 'psetq 'setq) (apply 'nconc (nreverse new)))))
+ (let ((set (cons (if par 'cl-psetq 'setq) (apply 'nconc (nreverse new)))))
(if temps `(let* ,(nreverse temps) ,set) set))
`(,(if par 'let 'let*)
,(nconc (nreverse temps) (nreverse new)) ,@body))))
(defun cl-loop-handle-accum (def &optional func) ; uses loop-*
- (if (eq (car loop-args) 'into)
- (let ((var (cl-pop2 loop-args)))
- (or (memq var loop-accum-vars)
- (progn (push (list (list var def)) loop-bindings)
- (push var loop-accum-vars)))
+ (if (eq (car cl-loop-args) 'into)
+ (let ((var (cl-pop2 cl-loop-args)))
+ (or (memq var cl-loop-accum-vars)
+ (progn (push (list (list var def)) cl-loop-bindings)
+ (push var cl-loop-accum-vars)))
var)
- (or loop-accum-var
+ (or cl-loop-accum-var
(progn
- (push (list (list (setq loop-accum-var (make-symbol "--cl-var--")) def))
- loop-bindings)
- (setq loop-result (if func (list func loop-accum-var)
- loop-accum-var))
- loop-accum-var))))
+ (push (list (list (setq cl-loop-accum-var (make-symbol "--cl-var--")) def))
+ cl-loop-bindings)
+ (setq cl-loop-result (if func (list func cl-loop-accum-var)
+ cl-loop-accum-var))
+ cl-loop-accum-var))))
(defun cl-loop-build-ands (clauses)
(let ((ands nil)
(setq clauses (cons (nconc (butlast (car clauses))
(if (eq (car-safe (cadr clauses))
'progn)
- (cdadr clauses)
+ (cl-cdadr clauses)
(list (cadr clauses))))
(cddr clauses)))
(setq body (cdr (butlast (pop clauses)))))
;;; Other iteration control structures.
;;;###autoload
-(defmacro do (steps endtest &rest body)
- "The Common Lisp `do' loop.
+(defmacro cl-do (steps endtest &rest body)
+ "The Common Lisp `cl-do' loop.
\(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)"
(declare (indent 2)
(cl-expand-do-loop steps endtest body nil))
;;;###autoload
-(defmacro do* (steps endtest &rest body)
- "The Common Lisp `do*' loop.
+(defmacro cl-do* (steps endtest &rest body)
+ "The Common Lisp `cl-do*' loop.
\(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)"
- (declare (indent 2) (debug do))
+ (declare (indent 2) (debug cl-do))
(cl-expand-do-loop steps endtest body t))
(defun cl-expand-do-loop (steps endtest body star)
- `(block nil
+ `(cl-block nil
(,(if star 'let* 'let)
,(mapcar (lambda (c) (if (consp c) (list (car c) (nth 1 c)) c))
steps)
(setq sets (delq nil sets))
(and sets
(list (cons (if (or star (not (cdr sets)))
- 'setq 'psetq)
+ 'setq 'cl-psetq)
(apply 'append sets))))))
,@(or (cdr endtest) '(nil)))))
;;;###autoload
-(defmacro dolist (spec &rest body)
+(defmacro cl-dolist (spec &rest body)
"Loop over a list.
Evaluate BODY with VAR bound to each `car' from LIST, in turn.
Then evaluate RESULT to get return value, default nil.
(declare (debug ((symbolp form &optional form) cl-declarations body)))
(let ((temp (make-symbol "--cl-dolist-temp--")))
;; FIXME: Copy&pasted from subr.el.
- `(block nil
+ `(cl-block nil
;; This is not a reliable test, but it does not matter because both
;; semantics are acceptable, tho one is slightly faster with dynamic
;; scoping and the other is slightly faster (and has cleaner semantics)
`((setq ,(car spec) nil) ,@(cddr spec))))))))
;;;###autoload
-(defmacro dotimes (spec &rest body)
+(defmacro cl-dotimes (spec &rest body)
"Loop a certain number of times.
Evaluate BODY with VAR bound to successive integers from 0, inclusive,
to COUNT, exclusive. Then evaluate RESULT to get return value, default
nil.
\(fn (VAR COUNT [RESULT]) BODY...)"
- (declare (debug dolist))
+ (declare (debug cl-dolist))
(let ((temp (make-symbol "--cl-dotimes-temp--"))
(end (nth 1 spec)))
;; FIXME: Copy&pasted from subr.el.
- `(block nil
+ `(cl-block nil
;; This is not a reliable test, but it does not matter because both
;; semantics are acceptable, tho one is slightly faster with dynamic
;; scoping and the other has cleaner semantics.
(,(car spec) 0))
(while (< ,(car spec) ,temp)
,@body
- (incf ,(car spec)))
+ (cl-incf ,(car spec)))
,@(cdr (cdr spec)))))))
;;;###autoload
-(defmacro do-symbols (spec &rest body)
+(defmacro cl-do-symbols (spec &rest body)
"Loop over all symbols.
Evaluate BODY with VAR bound to each interned symbol, or to each symbol
from OBARRAY.
(declare (indent 1)
(debug ((symbolp &optional form form) cl-declarations body)))
;; Apparently this doesn't have an implicit block.
- `(block nil
+ `(cl-block nil
(let (,(car spec))
(mapatoms #'(lambda (,(car spec)) ,@body)
,@(and (cadr spec) (list (cadr spec))))
- ,(caddr spec))))
+ ,(cl-caddr spec))))
;;;###autoload
-(defmacro do-all-symbols (spec &rest body)
+(defmacro cl-do-all-symbols (spec &rest body)
(declare (indent 1) (debug ((symbolp &optional form) cl-declarations body)))
- `(do-symbols (,(car spec) nil ,(cadr spec)) ,@body))
+ `(cl-do-symbols (,(car spec) nil ,(cadr spec)) ,@body))
;;; Assignments.
;;;###autoload
-(defmacro psetq (&rest args)
+(defmacro cl-psetq (&rest args)
"Set SYMs to the values VALs in parallel.
This is like `setq', except that all VAL forms are evaluated (in order)
before assigning any symbols SYM to the corresponding values.
\(fn SYM VAL SYM VAL ...)"
(declare (debug setq))
- (cons 'psetf args))
+ (cons 'cl-psetf args))
;;; Binding control structures.
;;;###autoload
-(defmacro progv (symbols values &rest body)
+(defmacro cl-progv (symbols values &rest body)
"Bind SYMBOLS to VALUES dynamically in BODY.
The forms SYMBOLS and VALUES are evaluated, and must evaluate to lists.
Each symbol in the first list is bound to the corresponding value in the
;;; This should really have some way to shadow 'byte-compile properties, etc.
;;;###autoload
-(defmacro flet (bindings &rest body)
+(defmacro cl-flet (bindings &rest body)
"Make temporary function definitions.
This is an analogue of `let' that operates on the function cell of FUNC
rather than its value cell. The FORMs are evaluated with the specified
go back to their previous definitions, or lack thereof).
\(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
- (declare (indent 1) (debug ((&rest (defun*)) cl-declarations body)))
- `(letf* ,(mapcar
+ (declare (indent 1) (debug ((&rest (cl-defun)) cl-declarations body)))
+ `(cl-letf* ,(mapcar
(lambda (x)
(if (or (and (fboundp (car x))
(eq (car-safe (symbol-function (car x))) 'macro))
(cdr (assq (car x) cl-macro-environment)))
- (error "Use `labels', not `flet', to rebind macro names"))
- (let ((func `(function*
+ (error "Use `cl-labels', not `cl-flet', to rebind macro names"))
+ (let ((func `(cl-function
(lambda ,(cadr x)
- (block ,(car x) ,@(cddr x))))))
+ (cl-block ,(car x) ,@(cddr x))))))
(when (cl-compiling-file)
;; Bug#411. It would be nice to fix this.
(and (get (car x) 'byte-compile)
(error "Byte-compiling a redefinition of `%s' \
-will not work - use `labels' instead" (symbol-name (car x))))
+will not work - use `cl-labels' instead" (symbol-name (car x))))
;; FIXME This affects the rest of the file, when it
- ;; should be restricted to the flet body.
+ ;; should be restricted to the cl-flet body.
(and (boundp 'byte-compile-function-environment)
(push (cons (car x) (eval func))
byte-compile-function-environment)))
,@body))
;;;###autoload
-(defmacro labels (bindings &rest body)
+(defmacro cl-labels (bindings &rest body)
"Make temporary function bindings.
-This is like `flet', except the bindings are lexical instead of dynamic.
-Unlike `flet', this macro is fully compliant with the Common Lisp standard.
+This is like `cl-flet', except the bindings are lexical instead of dynamic.
+Unlike `cl-flet', this macro is fully compliant with the Common Lisp standard.
\(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
- (declare (indent 1) (debug flet))
+ (declare (indent 1) (debug cl-flet))
(let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment))
(while bindings
- ;; Use `gensym' rather than `make-symbol'. It's important that
+ ;; Use `cl-gensym' rather than `make-symbol'. It's important that
;; (not (eq (symbol-name var1) (symbol-name var2))) because these
;; vars get added to the cl-macro-environment.
- (let ((var (gensym "--cl-var--")))
+ (let ((var (cl-gensym "--cl-var--")))
(push var vars)
- (push `(function* (lambda . ,(cdar bindings))) sets)
+ (push `(cl-function (lambda . ,(cdar bindings))) sets)
(push var sets)
(push (list (car (pop bindings)) 'lambda '(&rest cl-labels-args)
- `(list* 'funcall ',var
+ `(cl-list* 'funcall ',var
cl-labels-args))
cl-macro-environment)))
- (cl-macroexpand-all `(lexical-let ,vars (setq ,@sets) ,@body)
+ (cl-macroexpand-all `(cl-lexical-let ,vars (setq ,@sets) ,@body)
cl-macro-environment)))
;; The following ought to have a better definition for use with newer
;; byte compilers.
;;;###autoload
-(defmacro macrolet (bindings &rest body)
+(defmacro cl-macrolet (bindings &rest body)
"Make temporary macro definitions.
-This is like `flet', but for macros instead of functions.
+This is like `cl-flet', but for macros instead of functions.
\(fn ((NAME ARGLIST BODY...) ...) FORM...)"
(declare (indent 1)
def-body))
cl-declarations body)))
(if (cdr bindings)
- `(macrolet (,(car bindings)) (macrolet ,(cdr bindings) ,@body))
+ `(cl-macrolet (,(car bindings)) (cl-macrolet ,(cdr bindings) ,@body))
(if (null bindings) (cons 'progn body)
(let* ((name (caar bindings))
(res (cl-transform-lambda (cdar bindings) name)))
(eval (car res))
(cl-macroexpand-all (cons 'progn body)
- (cons (list* name 'lambda (cdr res))
+ (cons (cl-list* name 'lambda (cdr res))
cl-macro-environment))))))
;;;###autoload
-(defmacro symbol-macrolet (bindings &rest body)
+(defmacro cl-symbol-macrolet (bindings &rest body)
"Make symbol macro definitions.
Within the body FORMs, references to the variable NAME will be replaced
-by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
+by EXPANSION, and (setq NAME ...) will act like (cl-setf EXPANSION ...).
\(fn ((NAME EXPANSION) ...) FORM...)"
(declare (indent 1) (debug ((&rest (symbol sexp)) cl-declarations body)))
(if (cdr bindings)
- `(symbol-macrolet (,(car bindings))
- (symbol-macrolet ,(cdr bindings) ,@body))
+ `(cl-symbol-macrolet (,(car bindings))
+ (cl-symbol-macrolet ,(cdr bindings) ,@body))
(if (null bindings) (cons 'progn body)
(cl-macroexpand-all (cons 'progn body)
(cons (list (symbol-name (caar bindings))
- (cadar bindings))
+ (cl-cadar bindings))
cl-macro-environment)))))
(defvar cl-closure-vars nil)
;;;###autoload
-(defmacro lexical-let (bindings &rest body)
+(defmacro cl-lexical-let (bindings &rest body)
"Like `let', but lexically scoped.
The main visible difference is that lambdas inside BODY will create
lexical closures as in Common Lisp.
(cons 'progn body)
(nconc (mapcar (function (lambda (x)
(list (symbol-name (car x))
- `(symbol-value ,(caddr x))
+ `(symbol-value ,(cl-caddr x))
t))) vars)
(list '(defun . cl-defun-expander))
cl-macro-environment))))
(if (not (get (car (last cl-closure-vars)) 'used))
- ;; Turn (let ((foo (gensym))) (set foo <val>) ...(symbol-value foo)...)
+ ;; Turn (let ((foo (cl-gensym)))
+ ;; (set foo <val>) ...(symbol-value foo)...)
;; into (let ((foo <val>)) ...(symbol-value 'foo)...).
;; This is good because it's more efficient but it only works with
;; dynamic scoping, since with lexical scoping we'd need
;; (let ((foo <val>)) ...foo...).
`(progn
- ,@(mapcar (lambda (x) `(defvar ,(caddr x))) vars)
- (let ,(mapcar (lambda (x) (list (caddr x) (cadr x))) vars)
- ,(sublis (mapcar (lambda (x)
- (cons (caddr x)
- `',(caddr x)))
+ ,@(mapcar (lambda (x) `(defvar ,(cl-caddr x))) vars)
+ (let ,(mapcar (lambda (x) (list (cl-caddr x) (cadr x))) vars)
+ ,(cl-sublis (mapcar (lambda (x)
+ (cons (cl-caddr x)
+ `',(cl-caddr x)))
vars)
ebody)))
`(let ,(mapcar (lambda (x)
- (list (caddr x)
+ (list (cl-caddr x)
`(make-symbol ,(format "--%s--" (car x)))))
vars)
- (setf ,@(apply #'append
+ (cl-setf ,@(apply #'append
(mapcar (lambda (x)
- (list `(symbol-value ,(caddr x)) (cadr x)))
+ (list `(symbol-value ,(cl-caddr x)) (cadr x)))
vars)))
,ebody))))
;;;###autoload
-(defmacro lexical-let* (bindings &rest body)
+(defmacro cl-lexical-let* (bindings &rest body)
"Like `let*', but lexically scoped.
The main visible difference is that lambdas inside BODY, and in
successive bindings within BINDINGS, will create lexical closures
(if (null bindings) (cons 'progn body)
(setq bindings (reverse bindings))
(while bindings
- (setq body (list `(lexical-let (,(pop bindings)) ,@body))))
+ (setq body (list `(cl-lexical-let (,(pop bindings)) ,@body))))
(car body)))
(defun cl-defun-expander (func &rest rest)
;;; Multiple values.
;;;###autoload
-(defmacro multiple-value-bind (vars form &rest body)
+(defmacro cl-multiple-value-bind (vars form &rest body)
"Collect multiple return values.
FORM must return a list; the BODY is then executed with the first N elements
of this list bound (`let'-style) to each of the symbols SYM in turn. This
-is analogous to the Common Lisp `multiple-value-bind' macro, using lists to
-simulate true multiple return values. For compatibility, (values A B C) is
+is analogous to the Common Lisp `cl-multiple-value-bind' macro, using lists to
+simulate true multiple return values. For compatibility, (cl-values A B C) is
a synonym for (list A B C).
\(fn (SYM...) FORM BODY)"
,@body)))
;;;###autoload
-(defmacro multiple-value-setq (vars form)
+(defmacro cl-multiple-value-setq (vars form)
"Collect multiple return values.
FORM must return a list; the first N elements of this list are stored in
each of the symbols SYM in turn. This is analogous to the Common Lisp
-`multiple-value-setq' macro, using lists to simulate true multiple return
-values. For compatibility, (values A B C) is a synonym for (list A B C).
+`cl-multiple-value-setq' macro, using lists to simulate true multiple return
+values. For compatibility, (cl-values A B C) is a synonym for (list A B C).
\(fn (SYM...) FORM)"
(declare (indent 1) (debug ((&rest symbolp) form)))
;;; Declarations.
;;;###autoload
-(defmacro locally (&rest body)
+(defmacro cl-locally (&rest body)
(declare (debug t))
(cons 'progn body))
;;;###autoload
-(defmacro the (type form)
+(defmacro cl-the (type form)
(declare (indent 1) (debug (cl-type-spec form)))
form)
((and (eq (car-safe spec) 'warn) (boundp 'byte-compile-warnings))
(while (setq spec (cdr spec))
(if (consp (car spec))
- (if (eq (cadar spec) 0)
+ (if (eq (cl-cadar spec) 0)
(byte-compile-disable-warning (caar spec))
(byte-compile-enable-warning (caar spec)))))))
nil)
(setq cl-proclaims-deferred nil))
;;;###autoload
-(defmacro declare (&rest specs)
+(defmacro cl-declare (&rest specs)
"Declare SPECS about the current function while compiling.
For instance
- \(declare (warn 0))
+ \(cl-declare (warn 0))
will turn off byte-compile warnings in the function.
See Info node `(cl)Declarations' for details."
;;; Generalized variables.
;;;###autoload
-(defmacro define-setf-method (func args &rest body)
- "Define a `setf' method.
-This method shows how to handle `setf's to places of the form (NAME ARGS...).
+(defmacro cl-define-setf-method (func args &rest body)
+ "Define a `cl-setf' method.
+This method shows how to handle `cl-setf's to places of the form (NAME ARGS...).
The argument forms ARGS are bound according to ARGLIST, as if NAME were
going to be expanded as a macro, then the BODY forms are executed and must
return a list of five elements: a temporary-variables list, a value-forms
list, a store-variables list (of length one), a store-form, and an access-
-form. See `defsetf' for a simpler way to define most setf-methods.
+form. See `cl-defsetf' for a simpler way to define most setf-methods.
\(fn NAME ARGLIST BODY...)"
(declare (debug
(&define name cl-lambda-list cl-declarations-or-string def-body)))
- `(eval-when (compile load eval)
+ `(cl-eval-when (compile load eval)
,@(if (stringp (car body))
(list `(put ',func 'setf-documentation ,(pop body))))
,(cl-transform-function-property
func 'setf-method (cons args body))))
-(defalias 'define-setf-expander 'define-setf-method)
+(defalias 'cl-define-setf-expander 'cl-define-setf-method)
;;;###autoload
-(defmacro defsetf (func arg1 &rest args)
- "Define a `setf' method.
-This macro is an easy-to-use substitute for `define-setf-method' that works
-well for simple place forms. In the simple `defsetf' form, `setf's of
-the form (setf (NAME ARGS...) VAL) are transformed to function or macro
+(defmacro cl-defsetf (func arg1 &rest args)
+ "Define a `cl-setf' method.
+This macro is an easy-to-use substitute for `cl-define-setf-method' that works
+well for simple place forms. In the simple `cl-defsetf' form, `cl-setf's of
+the form (cl-setf (NAME ARGS...) VAL) are transformed to function or macro
calls of the form (FUNC ARGS... VAL). Example:
- (defsetf aref aset)
+ (cl-defsetf aref aset)
-Alternate form: (defsetf NAME ARGLIST (STORE) BODY...).
-Here, the above `setf' call is expanded by binding the argument forms ARGS
+Alternate form: (cl-defsetf NAME ARGLIST (STORE) BODY...).
+Here, the above `cl-setf' call is expanded by binding the argument forms ARGS
according to ARGLIST, binding the value form VAL to STORE, then executing
-BODY, which must return a Lisp form that does the necessary `setf' operation.
+BODY, which must return a Lisp form that does the necessary `cl-setf' operation.
Actually, ARGLIST and STORE may be bound to temporary variables which are
introduced automatically to preserve proper execution order of the arguments.
Example:
- (defsetf nth (n x) (v) `(setcar (nthcdr ,n ,x) ,v))
+ (cl-defsetf nth (n x) (v) `(setcar (nthcdr ,n ,x) ,v))
\(fn NAME [FUNC | ARGLIST (STORE) BODY...])"
(declare (debug
lets2 (cons (list (car p1) (car p2)) lets2)
p1 (cdr p1) p2 (cdr p2))))
(if restarg (setq lets2 (cons (list restarg rest-temps) lets2)))
- `(define-setf-method ,func ,arg1
+ `(cl-define-setf-method ,func ,arg1
,@(and docstr (list docstr))
(let*
,(nreverse
,@lets1)
lets1)))
(list ; 'values
- (,(if restarg 'list* 'list) ,@tempsr)
- (,(if restarg 'list* 'list) ,@largsr)
+ (,(if restarg 'cl-list* 'list) ,@tempsr)
+ (,(if restarg 'cl-list* 'list) ,@largsr)
(list ,store-temp)
(let*
,(nreverse
(cons (list store-var store-temp)
lets2))
,@args)
- (,(if restarg 'list* 'list)
+ (,(if restarg 'cl-list* 'list)
,@(cons `',func tempsr))))))
- `(defsetf ,func (&rest args) (store)
+ `(cl-defsetf ,func (&rest args) (store)
,(let ((call `(cons ',arg1
(append args (list store)))))
(if (car args)
call)))))
;;; Some standard place types from Common Lisp.
-(defsetf aref aset)
-(defsetf car setcar)
-(defsetf cdr setcdr)
-(defsetf caar (x) (val) `(setcar (car ,x) ,val))
-(defsetf cadr (x) (val) `(setcar (cdr ,x) ,val))
-(defsetf cdar (x) (val) `(setcdr (car ,x) ,val))
-(defsetf cddr (x) (val) `(setcdr (cdr ,x) ,val))
-(defsetf elt (seq n) (store)
+(cl-defsetf aref aset)
+(cl-defsetf car setcar)
+(cl-defsetf cdr setcdr)
+(cl-defsetf caar (x) (val) `(setcar (car ,x) ,val))
+(cl-defsetf cadr (x) (val) `(setcar (cdr ,x) ,val))
+(cl-defsetf cdar (x) (val) `(setcdr (car ,x) ,val))
+(cl-defsetf cddr (x) (val) `(setcdr (cdr ,x) ,val))
+(cl-defsetf elt (seq n) (store)
`(if (listp ,seq) (setcar (nthcdr ,n ,seq) ,store)
(aset ,seq ,n ,store)))
-(defsetf get put)
-(defsetf get* (x y &optional d) (store) `(put ,x ,y ,store))
-(defsetf gethash (x h &optional d) (store) `(puthash ,x ,store ,h))
-(defsetf nth (n x) (store) `(setcar (nthcdr ,n ,x) ,store))
-(defsetf subseq (seq start &optional end) (new)
- `(progn (replace ,seq ,new :start1 ,start :end1 ,end) ,new))
-(defsetf symbol-function fset)
-(defsetf symbol-plist setplist)
-(defsetf symbol-value set)
+(cl-defsetf get put)
+(cl-defsetf cl-get (x y &optional d) (store) `(put ,x ,y ,store))
+(cl-defsetf gethash (x h &optional d) (store) `(puthash ,x ,store ,h))
+(cl-defsetf nth (n x) (store) `(setcar (nthcdr ,n ,x) ,store))
+(cl-defsetf cl-subseq (seq start &optional end) (new)
+ `(progn (cl-replace ,seq ,new :start1 ,start :end1 ,end) ,new))
+(cl-defsetf symbol-function fset)
+(cl-defsetf symbol-plist setplist)
+(cl-defsetf symbol-value set)
;;; Various car/cdr aliases. Note that `cadr' is handled specially.
-(defsetf first setcar)
-(defsetf second (x) (store) `(setcar (cdr ,x) ,store))
-(defsetf third (x) (store) `(setcar (cddr ,x) ,store))
-(defsetf fourth (x) (store) `(setcar (cdddr ,x) ,store))
-(defsetf fifth (x) (store) `(setcar (nthcdr 4 ,x) ,store))
-(defsetf sixth (x) (store) `(setcar (nthcdr 5 ,x) ,store))
-(defsetf seventh (x) (store) `(setcar (nthcdr 6 ,x) ,store))
-(defsetf eighth (x) (store) `(setcar (nthcdr 7 ,x) ,store))
-(defsetf ninth (x) (store) `(setcar (nthcdr 8 ,x) ,store))
-(defsetf tenth (x) (store) `(setcar (nthcdr 9 ,x) ,store))
-(defsetf rest setcdr)
+(cl-defsetf cl-first setcar)
+(cl-defsetf cl-second (x) (store) `(setcar (cdr ,x) ,store))
+(cl-defsetf cl-third (x) (store) `(setcar (cddr ,x) ,store))
+(cl-defsetf cl-fourth (x) (store) `(setcar (cl-cdddr ,x) ,store))
+(cl-defsetf cl-fifth (x) (store) `(setcar (nthcdr 4 ,x) ,store))
+(cl-defsetf cl-sixth (x) (store) `(setcar (nthcdr 5 ,x) ,store))
+(cl-defsetf cl-seventh (x) (store) `(setcar (nthcdr 6 ,x) ,store))
+(cl-defsetf cl-eighth (x) (store) `(setcar (nthcdr 7 ,x) ,store))
+(cl-defsetf cl-ninth (x) (store) `(setcar (nthcdr 8 ,x) ,store))
+(cl-defsetf cl-tenth (x) (store) `(setcar (nthcdr 9 ,x) ,store))
+(cl-defsetf cl-rest setcdr)
;;; Some more Emacs-related place types.
-(defsetf buffer-file-name set-visited-file-name t)
-(defsetf buffer-modified-p (&optional buf) (flag)
+(cl-defsetf buffer-file-name set-visited-file-name t)
+(cl-defsetf buffer-modified-p (&optional buf) (flag)
`(with-current-buffer ,buf
(set-buffer-modified-p ,flag)))
-(defsetf buffer-name rename-buffer t)
-(defsetf buffer-string () (store)
+(cl-defsetf buffer-name rename-buffer t)
+(cl-defsetf buffer-string () (store)
`(progn (erase-buffer) (insert ,store)))
-(defsetf buffer-substring cl-set-buffer-substring)
-(defsetf current-buffer set-buffer)
-(defsetf current-case-table set-case-table)
-(defsetf current-column move-to-column t)
-(defsetf current-global-map use-global-map t)
-(defsetf current-input-mode () (store)
+(cl-defsetf buffer-substring cl-set-buffer-substring)
+(cl-defsetf current-buffer set-buffer)
+(cl-defsetf current-case-table set-case-table)
+(cl-defsetf current-column move-to-column t)
+(cl-defsetf current-global-map use-global-map t)
+(cl-defsetf current-input-mode () (store)
`(progn (apply #'set-input-mode ,store) ,store))
-(defsetf current-local-map use-local-map t)
-(defsetf current-window-configuration set-window-configuration t)
-(defsetf default-file-modes set-default-file-modes t)
-(defsetf default-value set-default)
-(defsetf documentation-property put)
-(defsetf face-background (f &optional s) (x) `(set-face-background ,f ,x ,s))
-(defsetf face-background-pixmap (f &optional s) (x)
+(cl-defsetf current-local-map use-local-map t)
+(cl-defsetf current-window-configuration set-window-configuration t)
+(cl-defsetf default-file-modes set-default-file-modes t)
+(cl-defsetf default-value set-default)
+(cl-defsetf documentation-property put)
+(cl-defsetf face-background (f &optional s) (x) `(set-face-background ,f ,x ,s))
+(cl-defsetf face-background-pixmap (f &optional s) (x)
`(set-face-background-pixmap ,f ,x ,s))
-(defsetf face-font (f &optional s) (x) `(set-face-font ,f ,x ,s))
-(defsetf face-foreground (f &optional s) (x) `(set-face-foreground ,f ,x ,s))
-(defsetf face-underline-p (f &optional s) (x)
+(cl-defsetf face-font (f &optional s) (x) `(set-face-font ,f ,x ,s))
+(cl-defsetf face-foreground (f &optional s) (x) `(set-face-foreground ,f ,x ,s))
+(cl-defsetf face-underline-p (f &optional s) (x)
`(set-face-underline-p ,f ,x ,s))
-(defsetf file-modes set-file-modes t)
-(defsetf frame-height set-screen-height t)
-(defsetf frame-parameters modify-frame-parameters t)
-(defsetf frame-visible-p cl-set-frame-visible-p)
-(defsetf frame-width set-screen-width t)
-(defsetf frame-parameter set-frame-parameter t)
-(defsetf terminal-parameter set-terminal-parameter)
-(defsetf getenv setenv t)
-(defsetf get-register set-register)
-(defsetf global-key-binding global-set-key)
-(defsetf keymap-parent set-keymap-parent)
-(defsetf local-key-binding local-set-key)
-(defsetf mark set-mark t)
-(defsetf mark-marker set-mark t)
-(defsetf marker-position set-marker t)
-(defsetf match-data set-match-data t)
-(defsetf mouse-position (scr) (store)
+(cl-defsetf file-modes set-file-modes t)
+(cl-defsetf frame-height set-screen-height t)
+(cl-defsetf frame-parameters modify-frame-parameters t)
+(cl-defsetf frame-visible-p cl-set-frame-visible-p)
+(cl-defsetf frame-width set-screen-width t)
+(cl-defsetf frame-parameter set-frame-parameter t)
+(cl-defsetf terminal-parameter set-terminal-parameter)
+(cl-defsetf getenv setenv t)
+(cl-defsetf get-register set-register)
+(cl-defsetf global-key-binding global-set-key)
+(cl-defsetf keymap-parent set-keymap-parent)
+(cl-defsetf local-key-binding local-set-key)
+(cl-defsetf mark set-mark t)
+(cl-defsetf mark-marker set-mark t)
+(cl-defsetf marker-position set-marker t)
+(cl-defsetf match-data set-match-data t)
+(cl-defsetf mouse-position (scr) (store)
`(set-mouse-position ,scr (car ,store) (cadr ,store)
(cddr ,store)))
-(defsetf overlay-get overlay-put)
-(defsetf overlay-start (ov) (store)
+(cl-defsetf overlay-get overlay-put)
+(cl-defsetf overlay-start (ov) (store)
`(progn (move-overlay ,ov ,store (overlay-end ,ov)) ,store))
-(defsetf overlay-end (ov) (store)
+(cl-defsetf overlay-end (ov) (store)
`(progn (move-overlay ,ov (overlay-start ,ov) ,store) ,store))
-(defsetf point goto-char)
-(defsetf point-marker goto-char t)
-(defsetf point-max () (store)
+(cl-defsetf point goto-char)
+(cl-defsetf point-marker goto-char t)
+(cl-defsetf point-max () (store)
`(progn (narrow-to-region (point-min) ,store) ,store))
-(defsetf point-min () (store)
+(cl-defsetf point-min () (store)
`(progn (narrow-to-region ,store (point-max)) ,store))
-(defsetf process-buffer set-process-buffer)
-(defsetf process-filter set-process-filter)
-(defsetf process-sentinel set-process-sentinel)
-(defsetf process-get process-put)
-(defsetf read-mouse-position (scr) (store)
+(cl-defsetf process-buffer set-process-buffer)
+(cl-defsetf process-filter set-process-filter)
+(cl-defsetf process-sentinel set-process-sentinel)
+(cl-defsetf process-get process-put)
+(cl-defsetf read-mouse-position (scr) (store)
`(set-mouse-position ,scr (car ,store) (cdr ,store)))
-(defsetf screen-height set-screen-height t)
-(defsetf screen-width set-screen-width t)
-(defsetf selected-window select-window)
-(defsetf selected-screen select-screen)
-(defsetf selected-frame select-frame)
-(defsetf standard-case-table set-standard-case-table)
-(defsetf syntax-table set-syntax-table)
-(defsetf visited-file-modtime set-visited-file-modtime t)
-(defsetf window-buffer set-window-buffer t)
-(defsetf window-display-table set-window-display-table t)
-(defsetf window-dedicated-p set-window-dedicated-p t)
-(defsetf window-height () (store)
+(cl-defsetf screen-height set-screen-height t)
+(cl-defsetf screen-width set-screen-width t)
+(cl-defsetf selected-window select-window)
+(cl-defsetf selected-screen select-screen)
+(cl-defsetf selected-frame select-frame)
+(cl-defsetf standard-case-table set-standard-case-table)
+(cl-defsetf syntax-table set-syntax-table)
+(cl-defsetf visited-file-modtime set-visited-file-modtime t)
+(cl-defsetf window-buffer set-window-buffer t)
+(cl-defsetf window-display-table set-window-display-table t)
+(cl-defsetf window-dedicated-p set-window-dedicated-p t)
+(cl-defsetf window-height () (store)
`(progn (enlarge-window (- ,store (window-height))) ,store))
-(defsetf window-hscroll set-window-hscroll)
-(defsetf window-parameter set-window-parameter)
-(defsetf window-point set-window-point)
-(defsetf window-start set-window-start)
-(defsetf window-width () (store)
+(cl-defsetf window-hscroll set-window-hscroll)
+(cl-defsetf window-parameter set-window-parameter)
+(cl-defsetf window-point set-window-point)
+(cl-defsetf window-start set-window-start)
+(cl-defsetf window-width () (store)
`(progn (enlarge-window (- ,store (window-width)) t) ,store))
-(defsetf x-get-secondary-selection x-own-secondary-selection t)
-(defsetf x-get-selection x-own-selection t)
+(cl-defsetf x-get-secondary-selection x-own-secondary-selection t)
+(cl-defsetf x-get-selection x-own-selection t)
-;; This is a hack that allows (setf (eq a 7) B) to mean either
+;; This is a hack that allows (cl-setf (eq a 7) B) to mean either
;; (setq a 7) or (setq a nil) depending on whether B is nil or not.
;; This is useful when you have control over the PLACE but not over
;; the VALUE, as is the case in define-minor-mode's :variable.
-(define-setf-method eq (place val)
- (let ((method (get-setf-method place cl-macro-environment))
+(cl-define-setf-method eq (place val)
+ (let ((method (cl-get-setf-method place cl-macro-environment))
(val-temp (make-symbol "--eq-val--"))
(store-temp (make-symbol "--eq-store--")))
(list (append (nth 0 method) (list val-temp))
;; available while compiling cl-macs, we fake it by referring to the global
;; variable cl-macro-environment directly.
-(define-setf-method apply (func arg1 &rest rest)
- (or (and (memq (car-safe func) '(quote function function*))
+(cl-define-setf-method apply (func arg1 &rest rest)
+ (or (and (memq (car-safe func) '(quote function cl-function))
(symbolp (car-safe (cdr-safe func))))
- (error "First arg to apply in setf is not (function SYM): %s" func))
+ (error "First arg to apply in cl-setf is not (function SYM): %s" func))
(let* ((form (cons (nth 1 func) (cons arg1 rest)))
- (method (get-setf-method form cl-macro-environment)))
+ (method (cl-get-setf-method form cl-macro-environment)))
(list (car method) (nth 1 method) (nth 2 method)
(cl-setf-make-apply (nth 3 method) (cadr func) (car method))
(cl-setf-make-apply (nth 4 method) (cadr func) (car method)))))
(error "%s is not suitable for use with setf-of-apply" func))
`(apply ',(car form) ,@(cdr form))))
-(define-setf-method nthcdr (n place)
- (let ((method (get-setf-method place cl-macro-environment))
+(cl-define-setf-method nthcdr (n place)
+ (let ((method (cl-get-setf-method place cl-macro-environment))
(n-temp (make-symbol "--cl-nthcdr-n--"))
(store-temp (make-symbol "--cl-nthcdr-store--")))
(list (cons n-temp (car method))
,(nth 3 method) ,store-temp)
`(nthcdr ,n-temp ,(nth 4 method)))))
-(define-setf-method getf (place tag &optional def)
- (let ((method (get-setf-method place cl-macro-environment))
+(cl-define-setf-method cl-getf (place tag &optional def)
+ (let ((method (cl-get-setf-method place cl-macro-environment))
(tag-temp (make-symbol "--cl-getf-tag--"))
(def-temp (make-symbol "--cl-getf-def--"))
(store-temp (make-symbol "--cl-getf-store--")))
`(let ((,(car (nth 2 method))
(cl-set-getf ,(nth 4 method) ,tag-temp ,store-temp)))
,(nth 3 method) ,store-temp)
- `(getf ,(nth 4 method) ,tag-temp ,def-temp))))
+ `(cl-getf ,(nth 4 method) ,tag-temp ,def-temp))))
-(define-setf-method substring (place from &optional to)
- (let ((method (get-setf-method place cl-macro-environment))
+(cl-define-setf-method substring (place from &optional to)
+ (let ((method (cl-get-setf-method place cl-macro-environment))
(from-temp (make-symbol "--cl-substring-from--"))
(to-temp (make-symbol "--cl-substring-to--"))
(store-temp (make-symbol "--cl-substring-store--")))
;;; Getting and optimizing setf-methods.
;;;###autoload
-(defun get-setf-method (place &optional env)
+(defun cl-get-setf-method (place &optional env)
"Return a list of five values describing the setf-method for PLACE.
PLACE may be any Lisp form which can appear as the PLACE argument to
-a macro like `setf' or `incf'."
+a macro like `cl-setf' or `cl-incf'."
(if (symbolp place)
(let ((temp (make-symbol "--cl-setf--")))
(list nil nil (list temp) `(setq ,place ,temp) place))
(error "Setf-method for %s returns malformed method"
func)))
(and (string-match-p "\\`c[ad][ad][ad]?[ad]?r\\'" name)
- (get-setf-method (compiler-macroexpand place)))
+ (cl-get-setf-method (cl-compiler-macroexpand place)))
(and (eq func 'edebug-after)
- (get-setf-method (nth (1- (length place)) place)
+ (cl-get-setf-method (nth (1- (length place)) place)
env)))))
(if (eq place (setq place (macroexpand place env)))
(if (and (symbolp (car place)) (fboundp (car place))
(symbolp (symbol-function (car place))))
- (get-setf-method (cons (symbol-function (car place))
+ (cl-get-setf-method (cons (symbol-function (car place))
(cdr place)) env)
(error "No setf-method known for %s" (car place)))
- (get-setf-method place env)))))
+ (cl-get-setf-method place env)))))
(defun cl-setf-do-modify (place opt-expr)
- (let* ((method (get-setf-method place cl-macro-environment))
+ (let* ((method (cl-get-setf-method place cl-macro-environment))
(temps (car method)) (values (nth 1 method))
(lets nil) (subs nil)
(optimize (and (not (eq opt-expr 'no-opt))
(push (cons (pop temps) (pop values)) subs)
(push (list (pop temps) (pop values)) lets)))
(list (nreverse lets)
- (cons (car (nth 2 method)) (sublis subs (nth 3 method)))
- (sublis subs (nth 4 method)))))
+ (cons (car (nth 2 method)) (cl-sublis subs (nth 3 method)))
+ (cl-sublis subs (nth 4 method)))))
(defun cl-setf-do-store (spec val)
(let ((sym (car spec))
(if (or (cl-const-expr-p val)
(and (cl-simple-expr-p val) (eq (cl-expr-contains form sym) 1))
(cl-setf-simple-store-p sym form))
- (subst val sym form)
+ (cl-subst val sym form)
`(let ((,sym ,val)) ,form))))
(defun cl-setf-simple-store-p (sym form)
;;; The standard modify macros.
;;;###autoload
-(defmacro setf (&rest args)
+(defmacro cl-setf (&rest args)
"Set each PLACE to the value of its VAL.
This is a generalized version of `setq'; the PLACEs may be symbolic
references such as (car x) or (aref x i), as well as plain symbols.
-For example, (setf (cadar x) y) is equivalent to (setcar (cdar x) y).
+For example, (cl-setf (cl-cadar x) y) is equivalent to (setcar (cdar x) y).
The return value is the last VAL in the list.
\(fn PLACE VAL PLACE VAL ...)"
(declare (debug (&rest [place form])))
(if (cdr (cdr args))
(let ((sets nil))
- (while args (push `(setf ,(pop args) ,(pop args)) sets))
+ (while args (push `(cl-setf ,(pop args) ,(pop args)) sets))
(cons 'progn (nreverse sets)))
(if (symbolp (car args))
(and args (cons 'setq args))
(if (car method) `(let* ,(car method) ,store) store)))))
;;;###autoload
-(defmacro psetf (&rest args)
+(defmacro cl-psetf (&rest args)
"Set PLACEs to the values VALs in parallel.
-This is like `setf', except that all VAL forms are evaluated (in order)
+This is like `cl-setf', except that all VAL forms are evaluated (in order)
before assigning any PLACEs to the corresponding values.
\(fn PLACE VAL PLACE VAL ...)"
- (declare (debug setf))
+ (declare (debug cl-setf))
(let ((p args) (simple t) (vars nil))
(while p
(if (or (not (symbolp (car p))) (cl-expr-depends-p (nth 1 p) vars))
(if (memq (car p) vars)
(error "Destination duplicated in psetf: %s" (car p)))
(push (pop p) vars)
- (or p (error "Odd number of arguments to psetf"))
+ (or p (error "Odd number of arguments to cl-psetf"))
(pop p))
(if simple
- `(progn (setf ,@args) nil)
+ `(progn (cl-setf ,@args) nil)
(setq args (reverse args))
- (let ((expr `(setf ,(cadr args) ,(car args))))
+ (let ((expr `(cl-setf ,(cadr args) ,(car args))))
(while (setq args (cddr args))
- (setq expr `(setf ,(cadr args) (prog1 ,(car args) ,expr))))
+ (setq expr `(cl-setf ,(cadr args) (prog1 ,(car args) ,expr))))
`(progn ,expr nil)))))
;;;###autoload
(defun cl-do-pop (place)
(if (cl-simple-expr-p place)
- `(prog1 (car ,place) (setf ,place (cdr ,place)))
+ `(prog1 (car ,place) (cl-setf ,place (cdr ,place)))
(let* ((method (cl-setf-do-modify place t))
(temp (make-symbol "--cl-pop--")))
`(let* (,@(car method)
,(cl-setf-do-store (nth 1 method) `(cdr ,temp)))))))
;;;###autoload
-(defmacro remf (place tag)
+(defmacro cl-remf (place tag)
"Remove TAG from property list PLACE.
-PLACE may be a symbol, or any generalized variable allowed by `setf'.
+PLACE may be a symbol, or any generalized variable allowed by `cl-setf'.
The form returns true if TAG was found and removed, nil otherwise."
(declare (debug (place form)))
(let* ((method (cl-setf-do-modify place t))
`(cl-do-remf ,tval ,ttag)))))
;;;###autoload
-(defmacro shiftf (place &rest args)
+(defmacro cl-shiftf (place &rest args)
"Shift left among PLACEs.
-Example: (shiftf A B C) sets A to B, B to C, and returns the old A.
-Each PLACE may be a symbol, or any generalized variable allowed by `setf'.
+Example: (cl-shiftf A B C) sets A to B, B to C, and returns the old A.
+Each PLACE may be a symbol, or any generalized variable allowed by `cl-setf'.
\(fn PLACE... VAL)"
(declare (debug (&rest place)))
(cond
((null args) place)
- ((symbolp place) `(prog1 ,place (setq ,place (shiftf ,@args))))
+ ((symbolp place) `(prog1 ,place (setq ,place (cl-shiftf ,@args))))
(t
(let ((method (cl-setf-do-modify place 'unsafe)))
`(let* ,(car method)
(prog1 ,(nth 2 method)
- ,(cl-setf-do-store (nth 1 method) `(shiftf ,@args))))))))
+ ,(cl-setf-do-store (nth 1 method) `(cl-shiftf ,@args))))))))
;;;###autoload
-(defmacro rotatef (&rest args)
+(defmacro cl-rotatef (&rest args)
"Rotate left among PLACEs.
-Example: (rotatef A B C) sets A to B, B to C, and C to A. It returns nil.
-Each PLACE may be a symbol, or any generalized variable allowed by `setf'.
+Example: (cl-rotatef A B C) sets A to B, B to C, and C to A. It returns nil.
+Each PLACE may be a symbol, or any generalized variable allowed by `cl-setf'.
\(fn PLACE...)"
(declare (debug (&rest place)))
(first (car args)))
(while (cdr args)
(setq sets (nconc sets (list (pop args) (car args)))))
- `(psetf ,@sets ,(car args) ,first)))
+ `(cl-psetf ,@sets ,(car args) ,first)))
(let* ((places (reverse args))
(temp (make-symbol "--cl-rotatef--"))
(form temp))
,(cl-setf-do-store (nth 1 method) form) nil)))))
;;;###autoload
-(defmacro letf (bindings &rest body)
+(defmacro cl-letf (bindings &rest body)
"Temporarily bind to PLACEs.
This is the analogue of `let', but with generalized variables (in the
-sense of `setf') for the PLACEs. Each PLACE is set to the corresponding
+sense of `cl-setf') for the PLACEs. Each PLACE is set to the corresponding
VALUE, then the BODY forms are executed. On exit, either normally or
because of a `throw' or error, the PLACEs are set back to their original
values. Note that this macro is *not* available in Common Lisp.
(let* ((place (if (symbolp (caar rev))
`(symbol-value ',(caar rev))
(caar rev)))
- (value (cadar rev))
+ (value (cl-cadar rev))
(method (cl-setf-do-modify place 'no-opt))
(save (make-symbol "--cl-letf-save--"))
(bound (and (memq (car place) '(symbol-value symbol-function))
;;;###autoload
-(defmacro letf* (bindings &rest body)
+(defmacro cl-letf* (bindings &rest body)
"Temporarily bind to PLACEs.
This is the analogue of `let*', but with generalized variables (in the
-sense of `setf') for the PLACEs. Each PLACE is set to the corresponding
+sense of `cl-setf') for the PLACEs. Each PLACE is set to the corresponding
VALUE, then the BODY forms are executed. On exit, either normally or
because of a `throw' or error, the PLACEs are set back to their original
values. Note that this macro is *not* available in Common Lisp.
the PLACE is not modified before executing BODY.
\(fn ((PLACE VALUE) ...) BODY...)"
- (declare (indent 1) (debug letf))
+ (declare (indent 1) (debug cl-letf))
(if (null bindings)
(cons 'progn body)
(setq bindings (reverse bindings))
(while bindings
- (setq body (list `(letf (,(pop bindings)) ,@body))))
+ (setq body (list `(cl-letf (,(pop bindings)) ,@body))))
(car body)))
;;;###autoload
-(defmacro callf (func place &rest args)
+(defmacro cl-callf (func place &rest args)
"Set PLACE to (FUNC PLACE ARGS...).
FUNC should be an unquoted function name. PLACE may be a symbol,
-or any generalized variable allowed by `setf'.
+or any generalized variable allowed by `cl-setf'.
\(fn FUNC PLACE ARGS...)"
- (declare (indent 2) (debug (function* place &rest form)))
+ (declare (indent 2) (debug (cl-function place &rest form)))
(let* ((method (cl-setf-do-modify place (cons 'list args)))
(rargs (cons (nth 2 method) args)))
`(let* ,(car method)
`(funcall #',func ,@rargs))))))
;;;###autoload
-(defmacro callf2 (func arg1 place &rest args)
+(defmacro cl-callf2 (func arg1 place &rest args)
"Set PLACE to (FUNC ARG1 PLACE ARGS...).
-Like `callf', but PLACE is the second argument of FUNC, not the first.
+Like `cl-callf', but PLACE is the second argument of FUNC, not the first.
\(fn FUNC ARG1 PLACE ARGS...)"
- (declare (indent 3) (debug (function* form place &rest form)))
+ (declare (indent 3) (debug (cl-function form place &rest form)))
(if (and (cl-safe-expr-p arg1) (cl-simple-expr-p place) (symbolp func))
- `(setf ,place (,func ,arg1 ,place ,@args))
+ `(cl-setf ,place (,func ,arg1 ,place ,@args))
(let* ((method (cl-setf-do-modify place (cons 'list args)))
(temp (and (not (cl-const-expr-p arg1)) (make-symbol "--cl-arg1--")))
- (rargs (list* (or temp arg1) (nth 2 method) args)))
+ (rargs (cl-list* (or temp arg1) (nth 2 method) args)))
`(let* (,@(and temp (list (list temp arg1))) ,@(car method))
,(cl-setf-do-store (nth 1 method)
(if (symbolp func) (cons func rargs)
`(funcall #',func ,@rargs)))))))
;;;###autoload
-(defmacro define-modify-macro (name arglist func &optional doc)
- "Define a `setf'-like modify macro.
+(defmacro cl-define-modify-macro (name arglist func &optional doc)
+ "Define a `cl-setf'-like modify macro.
If NAME is called, it combines its PLACE argument with the other arguments
-from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)"
+from ARGLIST using FUNC: (cl-define-modify-macro cl-incf (&optional (n 1)) +)"
(declare (debug
(&define name cl-lambda-list ;; should exclude &key
symbolp &optional stringp)))
- (if (memq '&key arglist) (error "&key not allowed in define-modify-macro"))
+ (if (memq '&key arglist) (error "&key not allowed in cl-define-modify-macro"))
(let ((place (make-symbol "--cl-place--")))
- `(defmacro* ,name (,place ,@arglist)
+ `(cl-defmacro ,name (,place ,@arglist)
,doc
- (,(if (memq '&rest arglist) #'list* #'list)
- #'callf ',func ,place
+ (,(if (memq '&rest arglist) #'cl-list* #'list)
+ #'cl-callf ',func ,place
,@(cl-arglist-args arglist)))))
;;; Structures.
;;;###autoload
-(defmacro defstruct (struct &rest descs)
+(defmacro cl-defstruct (struct &rest descs)
"Define a struct type.
This macro defines a new data type called NAME that stores data
in SLOTs. It defines a `make-NAME' constructor, a `copy-NAME'
copier, a `NAME-p' predicate, and slot accessors named `NAME-SLOT'.
-You can use the accessors to set the corresponding slots, via `setf'.
+You can use the accessors to set the corresponding slots, via `cl-setf'.
NAME may instead take the form (NAME OPTIONS...), where each
OPTION is either a single keyword or (KEYWORD VALUE).
Each SLOT may instead take the form (SLOT SLOT-OPTS...), where
SLOT-OPTS are keyword-value pairs for that slot. Currently, only
one keyword is supported, `:read-only'. If this has a non-nil
-value, that slot cannot be set via `setf'.
+value, that slot cannot be set via `cl-setf'.
\(fn NAME SLOTS...)"
(declare (doc-string 2)
(if (cadr inc-type) (setq tag name named t))
(let ((incl include))
(while incl
- (push `(pushnew ',tag
+ (push `(cl-pushnew ',tag
,(intern (format "cl-struct-%s-tags" incl)))
forms)
(setq incl (get incl 'cl-struct-include)))))
`(and (consp cl-x)
(memq (nth ,pos cl-x) ,tag-symbol))))))
pred-check (and pred-form (> safety 0)
- (if (and (eq (caadr pred-form) 'vectorp)
+ (if (and (eq (cl-caadr pred-form) 'vectorp)
(= safety 1))
- (cons 'and (cdddr pred-form)) pred-form)))
+ (cons 'and (cl-cdddr pred-form)) pred-form)))
(let ((pos 0) (descp descs))
(while descp
(let* ((desc (pop descp))
(let ((accessor (intern (format "%s%s" conc-name slot))))
(push slot slots)
(push (nth 1 desc) defaults)
- (push (list*
- 'defsubst* accessor '(cl-x)
+ (push (cl-list*
+ 'cl-defsubst accessor '(cl-x)
(append
(and pred-check
(list `(or ,pred-check
(if (= pos 0) '(car cl-x)
`(nth ,pos cl-x)))))) forms)
(push (cons accessor t) side-eff)
- (push `(define-setf-method ,accessor (cl-x)
+ (push `(cl-define-setf-method ,accessor (cl-x)
,(if (cadr (memq :read-only (cddr desc)))
`(progn (ignore cl-x)
(error "%s is a read-only slot"
(setq slots (nreverse slots)
defaults (nreverse defaults))
(and predicate pred-form
- (progn (push `(defsubst* ,predicate (cl-x)
+ (progn (push `(cl-defsubst ,predicate (cl-x)
,(if (eq (car pred-form) 'and)
(append pred-form '(t))
`(and ,pred-form t))) forms)
(let* ((name (caar constrs))
(args (cadr (pop constrs)))
(anames (cl-arglist-args args))
- (make (mapcar* (function (lambda (s d) (if (memq s anames) s d)))
+ (make (cl-mapcar (function (lambda (s d) (if (memq s anames) s d)))
slots defaults)))
- (push `(defsubst* ,name
+ (push `(cl-defsubst ,name
(&cl-defs '(nil ,@descs) ,@args)
(,type ,@make)) forms)
- (if (cl-safe-expr-p `(progn ,@(mapcar #'second descs)))
+ (if (cl-safe-expr-p `(progn ,@(mapcar #'cl-second descs)))
(push (cons name t) side-eff))))
(if print-auto (nconc print-func (list '(princ ")" cl-s) t)))
(if print-func
;; the depth argument cl-n.
(lambda (cl-x cl-s ,(if print-auto '_cl-n 'cl-n))
(and ,pred-form ,print-func))
- custom-print-functions)
+ cl-custom-print-functions)
forms))
(push `(setq ,tag-symbol (list ',tag)) forms)
- (push `(eval-when (compile load eval)
+ (push `(cl-eval-when (compile load eval)
(put ',name 'cl-struct-slots ',descs)
(put ',name 'cl-struct-type ',(list type (eq named t)))
(put ',name 'cl-struct-include ',include)
(list (list temp) (list x) (list store)
`(progn
,@(and pred-form
- (list `(or ,(subst temp 'cl-x pred-form)
+ (list `(or ,(cl-subst temp 'cl-x pred-form)
(error ,(format
"%s storing a non-%s"
accessor name)))))
;;; Types and assertions.
;;;###autoload
-(defmacro deftype (name arglist &rest body)
+(defmacro cl-deftype (name arglist &rest body)
"Define NAME as a new data type.
-The type name can then be used in `typecase', `check-type', etc."
- (declare (debug defmacro*) (doc-string 3))
- `(eval-when (compile load eval)
+The type name can then be used in `cl-typecase', `cl-check-type', etc."
+ (declare (debug cl-defmacro) (doc-string 3))
+ `(cl-eval-when (compile load eval)
,(cl-transform-function-property
name 'cl-deftype-handler (cons `(&cl-defs '('*) ,@arglist) body))))
((memq type '(nil t)) type)
((eq type 'null) `(null ,val))
((eq type 'atom) `(atom ,val))
- ((eq type 'float) `(floatp-safe ,val))
+ ((eq type 'float) `(cl-floatp-safe ,val))
((eq type 'real) `(numberp ,val))
((eq type 'fixnum) `(integerp ,val))
- ;; FIXME: Should `character' accept things like ?\C-\M-a ? -stef
+ ;; FIXME: Should `character' accept things like ?\C-\M-a ? --Stef
((memq type '(character string-char)) `(characterp ,val))
(t
(let* ((name (symbol-name type))
((memq (car type) '(integer float real number))
(delq t `(and ,(cl-make-type-test val (car type))
,(if (memq (cadr type) '(* nil)) t
- (if (consp (cadr type)) `(> ,val ,(caadr type))
+ (if (consp (cadr type)) `(> ,val ,(cl-caadr type))
`(>= ,val ,(cadr type))))
- ,(if (memq (caddr type) '(* nil)) t
- (if (consp (caddr type)) `(< ,val ,(caaddr type))
- `(<= ,val ,(caddr type)))))))
+ ,(if (memq (cl-caddr type) '(* nil)) t
+ (if (consp (cl-caddr type)) `(< ,val ,(cl-caaddr type))
+ `(<= ,val ,(cl-caddr type)))))))
((memq (car type) '(and or not))
(cons (car type)
(mapcar (function (lambda (x) (cl-make-type-test val x)))
(cdr type))))
- ((memq (car type) '(member member*))
- `(and (member* ,val ',(cdr type)) t))
+ ((memq (car type) '(member cl-member))
+ `(and (cl-member ,val ',(cdr type)) t))
((eq (car type) 'satisfies) (list (cadr type) val))
(t (error "Bad type spec: %s" type)))))
;;;###autoload
-(defun typep (object type) ; See compiler macro below.
+(defun cl-typep (object type) ; See compiler macro below.
"Check that OBJECT is of type TYPE.
TYPE is a Common Lisp-style type specifier."
(eval (cl-make-type-test 'object type)))
;;;###autoload
-(defmacro check-type (form type &optional string)
+(defmacro cl-check-type (form type &optional string)
"Verify that FORM is of type TYPE; signal an error if not.
STRING is an optional description of the desired type."
(declare (debug (place cl-type-spec &optional stringp)))
`(let ((,temp ,form)) ,body nil)))))
;;;###autoload
-(defmacro assert (form &optional show-args string &rest args)
+(defmacro cl-assert (form &optional show-args string &rest args)
"Verify that FORM returns non-nil; signal an error if not.
Second arg SHOW-ARGS means to include arguments of FORM in message.
Other args STRING and ARGS... are arguments to be passed to `error'.
;;; Compiler macros.
;;;###autoload
-(defmacro define-compiler-macro (func args &rest body)
+(defmacro cl-define-compiler-macro (func args &rest body)
"Define a compiler-only macro.
This is like `defmacro', but macro expansion occurs only if the call to
FUNC is compiled (i.e., not interpreted). Compiler macros should be used
possible. Unlike regular macros, BODY can decide to \"punt\" and leave the
original function call alone by declaring an initial `&whole foo' parameter
and then returning foo."
- (declare (debug defmacro*))
+ (declare (debug cl-defmacro))
(let ((p args) (res nil))
(while (consp p) (push (pop p) res))
(setq args (nconc (nreverse res) (and p (list '&rest p)))))
- `(eval-when (compile load eval)
+ `(cl-eval-when (compile load eval)
,(cl-transform-function-property
func 'cl-compiler-macro
(cons (if (memq '&whole args) (delq '&whole args)
(purecopy (file-name-nondirectory file)))))))))
;;;###autoload
-(defun compiler-macroexpand (form)
+(defun cl-compiler-macroexpand (form)
(while
(let ((func (car-safe form)) (handler nil))
(while (and (symbolp func)
form)
(defun cl-byte-compile-compiler-macro (form)
- (if (eq form (setq form (compiler-macroexpand form)))
+ (if (eq form (setq form (cl-compiler-macroexpand form)))
(byte-compile-normal-call form)
(byte-compile-form form)))
(defvar cl-active-block-names nil)
-(define-compiler-macro cl-block-wrapper (cl-form)
+(cl-define-compiler-macro cl-block-wrapper (cl-form)
(let* ((cl-entry (cons (nth 1 (nth 1 cl-form)) nil))
(cl-active-block-names (cons cl-entry cl-active-block-names))
(cl-body (macroexpand-all ;Performs compiler-macro expansions.
`(catch ,(nth 1 cl-form) ,@(cdr cl-body))
cl-body)))
-(define-compiler-macro cl-block-throw (cl-tag cl-value)
+(cl-define-compiler-macro cl-block-throw (cl-tag cl-value)
(let ((cl-found (assq (nth 1 cl-tag) cl-active-block-names)))
(if cl-found (setcdr cl-found t)))
`(throw ,cl-tag ,cl-value))
;;;###autoload
-(defmacro defsubst* (name args &rest body)
+(defmacro cl-defsubst (name args &rest body)
"Define NAME as a function.
Like `defun', except the function is automatically declared `inline',
ARGLIST allows full Common Lisp conventions, and BODY is implicitly
-surrounded by (block NAME ...).
+surrounded by (cl-block NAME ...).
\(fn NAME ARGLIST [DOCSTRING] BODY...)"
- (declare (debug defun*))
+ (declare (debug cl-defun))
(let* ((argns (cl-arglist-args args)) (p argns)
(pbody (cons 'progn body))
(unsafe (not (cl-safe-expr-p pbody))))
(while (and p (eq (cl-expr-contains args (car p)) 1)) (pop p))
`(progn
,(if p nil ; give up if defaults refer to earlier args
- `(define-compiler-macro ,name
+ `(cl-define-compiler-macro ,name
,(if (memq '&key args)
`(&whole cl-whole &cl-quote ,@args)
(cons '&cl-quote args))
(cl-defsubst-expand
- ',argns '(block ,name ,@body)
+ ',argns '(cl-block ,name ,@body)
;; We used to pass `simple' as
;; (not (or unsafe (cl-expr-access-order pbody argns)))
;; But this is much too simplistic since it
;; cl-expr-access-order itself is also too naive).
nil
,(and (memq '&key args) 'cl-whole) ,unsafe ,@argns)))
- (defun* ,name ,args ,@body))))
+ (cl-defun ,name ,args ,@body))))
(defun cl-defsubst-expand (argns body simple whole unsafe &rest argvs)
(if (and whole (not (cl-safe-expr-p (cons 'progn argvs)))) whole
(if (cl-simple-exprs-p argvs) (setq simple t))
(let* ((substs ())
(lets (delq nil
- (mapcar* (function
- (lambda (argn argv)
- (if (or simple (cl-const-expr-p argv))
- (progn (push (cons argn argv) substs)
- (and unsafe (list argn argv)))
- (list argn argv))))
- argns argvs))))
+ (cl-mapcar (lambda (argn argv)
+ (if (or simple (cl-const-expr-p argv))
+ (progn (push (cons argn argv) substs)
+ (and unsafe (list argn argv)))
+ (list argn argv)))
+ argns argvs))))
;; FIXME: `sublis/subst' will happily substitute the symbol
;; `argn' in places where it's not used as a reference
;; to a variable.
;; scope, leading to name capture.
(setq body (cond ((null substs) body)
((null (cdr substs))
- (subst (cdar substs) (caar substs) body))
- (t (sublis substs body))))
+ (cl-subst (cdar substs) (caar substs) body))
+ (t (cl-sublis substs body))))
(if lets `(let ,lets ,body) body))))
;; mainly to make sure these macros will be present.
(put 'eql 'byte-compile nil)
-(define-compiler-macro eql (&whole form a b)
+(cl-define-compiler-macro eql (&whole form a b)
(cond ((eq (cl-const-expr-p a) t)
(let ((val (cl-const-expr-val a)))
(if (and (numberp val) (not (integerp val)))
(eq ,a ,b)))
(t form)))
-(define-compiler-macro member* (&whole form a list &rest keys)
+(cl-define-compiler-macro cl-member (&whole form a list &rest keys)
(let ((test (and (= (length keys) 2) (eq (car keys) :test)
(cl-const-expr-val (nth 1 keys)))))
(cond ((eq test 'eq) `(memq ,a ,list))
((or (null keys) (eq test 'eql)) `(memql ,a ,list))
(t form))))
-(define-compiler-macro assoc* (&whole form a list &rest keys)
+(cl-define-compiler-macro cl-assoc (&whole form a list &rest keys)
(let ((test (and (= (length keys) 2) (eq (car keys) :test)
(cl-const-expr-val (nth 1 keys)))))
(cond ((eq test 'eq) `(assq ,a ,list))
((eq test 'equal) `(assoc ,a ,list))
((and (eq (cl-const-expr-p a) t) (or (null keys) (eq test 'eql)))
- (if (floatp-safe (cl-const-expr-val a))
+ (if (cl-floatp-safe (cl-const-expr-val a))
`(assoc ,a ,list) `(assq ,a ,list)))
(t form))))
-(define-compiler-macro adjoin (&whole form a list &rest keys)
+(cl-define-compiler-macro cl-adjoin (&whole form a list &rest keys)
(if (and (cl-simple-expr-p a) (cl-simple-expr-p list)
(not (memq :key keys)))
- `(if (member* ,a ,list ,@keys) ,list (cons ,a ,list))
+ `(if (cl-member ,a ,list ,@keys) ,list (cons ,a ,list))
form))
-(define-compiler-macro list* (arg &rest others)
+(cl-define-compiler-macro cl-list* (arg &rest others)
(let* ((args (reverse (cons arg others)))
(form (car args)))
(while (setq args (cdr args))
(setq form `(cons ,(car args) ,form)))
form))
-(define-compiler-macro get* (sym prop &optional def)
+(cl-define-compiler-macro cl-get (sym prop &optional def)
(if def
- `(getf (symbol-plist ,sym) ,prop ,def)
+ `(cl-getf (symbol-plist ,sym) ,prop ,def)
`(get ,sym ,prop)))
-(define-compiler-macro typep (&whole form val type)
+(cl-define-compiler-macro cl-typep (&whole form val type)
(if (cl-const-expr-p type)
(let ((res (cl-make-type-test val (cl-const-expr-val type))))
(if (or (memq (cl-expr-contains res val) '(nil 1))
(cl-simple-expr-p val)) res
(let ((temp (make-symbol "--cl-var--")))
- `(let ((,temp ,val)) ,(subst temp val res)))))
+ `(let ((,temp ,val)) ,(cl-subst temp val res)))))
form))
`(lambda (w x)
,(if (symbolp (cadr y))
`(list ',(cadr y)
- (list ',(caddr y) x))
+ (list ',(cl-caddr y) x))
(cons 'list (cdr y))))))
- '((first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr x)
- (fifth 'nth 4 x) (sixth 'nth 5 x) (seventh 'nth 6 x)
- (eighth 'nth 7 x) (ninth 'nth 8 x) (tenth 'nth 9 x)
- (rest 'cdr x) (endp 'null x) (plusp '> x 0) (minusp '< x 0)
- (caaar car caar) (caadr car cadr) (cadar car cdar)
- (caddr car cddr) (cdaar cdr caar) (cdadr cdr cadr)
- (cddar cdr cdar) (cdddr cdr cddr) (caaaar car caaar)
- (caaadr car caadr) (caadar car cadar) (caaddr car caddr)
- (cadaar car cdaar) (cadadr car cdadr) (caddar car cddar)
- (cadddr car cdddr) (cdaaar cdr caaar) (cdaadr cdr caadr)
- (cdadar cdr cadar) (cdaddr cdr caddr) (cddaar cdr cdaar)
- (cddadr cdr cdadr) (cdddar cdr cddar) (cddddr cdr cdddr) ))
+ '((cl-first 'car x) (cl-second 'cadr x) (cl-third 'cl-caddr x) (cl-fourth 'cl-cadddr x)
+ (cl-fifth 'nth 4 x) (cl-sixth 'nth 5 x) (cl-seventh 'nth 6 x)
+ (cl-eighth 'nth 7 x) (cl-ninth 'nth 8 x) (cl-tenth 'nth 9 x)
+ (cl-rest 'cdr x) (cl-endp 'null x) (cl-plusp '> x 0) (cl-minusp '< x 0)
+ (cl-caaar car caar) (cl-caadr car cadr) (cl-cadar car cdar)
+ (cl-caddr car cddr) (cl-cdaar cdr caar) (cl-cdadr cdr cadr)
+ (cl-cddar cdr cdar) (cl-cdddr cdr cddr) (cl-caaaar car cl-caaar)
+ (cl-caaadr car cl-caadr) (cl-caadar car cl-cadar) (cl-caaddr car cl-caddr)
+ (cl-cadaar car cl-cdaar) (cl-cadadr car cl-cdadr) (cl-caddar car cl-cddar)
+ (cl-cadddr car cl-cdddr) (cl-cdaaar cdr cl-caaar) (cl-cdaadr cdr cl-caadr)
+ (cl-cdadar cdr cl-cadar) (cl-cdaddr cdr cl-caddr) (cl-cddaar cdr cl-cdaar)
+ (cl-cddadr cdr cl-cdadr) (cl-cdddar cdr cl-cddar) (cl-cddddr cdr cl-cdddr) ))
;;; Things that are inline.
-(proclaim '(inline floatp-safe acons map concatenate notany notevery
- cl-set-elt revappend nreconc gethash))
+(cl-proclaim '(inline cl-floatp-safe cl-acons cl-map cl-concatenate cl-notany cl-notevery
+ cl-set-elt cl-revappend cl-nreconc gethash))
;;; Things that are side-effect-free.
(mapc (lambda (x) (put x 'side-effect-free t))
- '(oddp evenp signum last butlast ldiff pairlis gcd lcm
- isqrt floor* ceiling* truncate* round* mod* rem* subseq
- list-length get* getf))
+ '(cl-oddp cl-evenp cl-signum last butlast cl-ldiff cl-pairlis cl-gcd cl-lcm
+ cl-isqrt cl-floor cl-ceiling cl-truncate cl-round cl-mod cl-rem cl-subseq
+ cl-list-length cl-get cl-getf))
;;; Things that are side-effect-and-error-free.
(mapc (lambda (x) (put x 'side-effect-free 'error-free))
- '(eql floatp-safe list* subst acons equalp random-state-p
- copy-tree sublis))
+ '(eql cl-floatp-safe cl-list* cl-subst cl-acons cl-equalp cl-random-state-p
+ copy-tree cl-sublis))
(run-hooks 'cl-macs-load-hook)
;;; Code:
-(require 'cl)
+(require 'cl-lib)
;;; Keyword parsing. This is special-cased here so that we can compile
;;; this file independent from cl-macs.
;;;###autoload
-(defun reduce (cl-func cl-seq &rest cl-keys)
+(defun cl-reduce (cl-func cl-seq &rest cl-keys)
"Reduce two-argument FUNCTION across SEQ.
\nKeywords supported: :start :end :from-end :initial-value :key
\n(fn FUNCTION SEQ [KEYWORD VALUE]...)"
(cl-parsing-keywords (:from-end (:start 0) :end :initial-value :key) ()
(or (listp cl-seq) (setq cl-seq (append cl-seq nil)))
- (setq cl-seq (subseq cl-seq cl-start cl-end))
+ (setq cl-seq (cl-subseq cl-seq cl-start cl-end))
(if cl-from-end (setq cl-seq (nreverse cl-seq)))
(let ((cl-accum (cond ((memq :initial-value cl-keys) cl-initial-value)
(cl-seq (cl-check-key (pop cl-seq)))
cl-accum)))
;;;###autoload
-(defun fill (seq item &rest cl-keys)
+(defun cl-fill (seq item &rest cl-keys)
"Fill the elements of SEQ with ITEM.
\nKeywords supported: :start :end
\n(fn SEQ ITEM [KEYWORD VALUE]...)"
seq))
;;;###autoload
-(defun replace (cl-seq1 cl-seq2 &rest cl-keys)
+(defun cl-replace (cl-seq1 cl-seq2 &rest cl-keys)
"Replace the elements of SEQ1 with the elements of SEQ2.
SEQ1 is destructively modified, then returned.
\nKeywords supported: :start1 :end1 :start2 :end2
cl-seq1))
;;;###autoload
-(defun remove* (cl-item cl-seq &rest cl-keys)
+(defun cl-remove (cl-item cl-seq &rest cl-keys)
"Remove all occurrences of ITEM in SEQ.
This is a non-destructive function; it makes a copy of SEQ if necessary
to avoid corrupting the original SEQ.
(let ((cl-i (cl--position cl-item cl-seq cl-start cl-end
cl-from-end)))
(if cl-i
- (let ((cl-res (apply 'delete* cl-item (append cl-seq nil)
+ (let ((cl-res (apply 'cl-delete cl-item (append cl-seq nil)
(append (if cl-from-end
(list :end (1+ cl-i))
(list :start cl-i))
(not (cl-check-test cl-item (car cl-p))))
(setq cl-p (cdr cl-p) cl-end (1- cl-end)))
(if (and cl-p (> cl-end 0))
- (nconc (ldiff cl-seq cl-p)
+ (nconc (cl-ldiff cl-seq cl-p)
(if (= cl-count 1) (cdr cl-p)
(and (cdr cl-p)
- (apply 'delete* cl-item
+ (apply 'cl-delete cl-item
(copy-sequence (cdr cl-p))
:start 0 :end (1- cl-end)
:count (1- cl-count) cl-keys))))
cl-seq)))))
;;;###autoload
-(defun remove-if (cl-pred cl-list &rest cl-keys)
+(defun cl-remove-if (cl-pred cl-list &rest cl-keys)
"Remove all items satisfying PREDICATE in SEQ.
This is a non-destructive function; it makes a copy of SEQ if necessary
to avoid corrupting the original SEQ.
\nKeywords supported: :key :count :start :end :from-end
\n(fn PREDICATE SEQ [KEYWORD VALUE]...)"
- (apply 'remove* nil cl-list :if cl-pred cl-keys))
+ (apply 'cl-remove nil cl-list :if cl-pred cl-keys))
;;;###autoload
-(defun remove-if-not (cl-pred cl-list &rest cl-keys)
+(defun cl-remove-if-not (cl-pred cl-list &rest cl-keys)
"Remove all items not satisfying PREDICATE in SEQ.
This is a non-destructive function; it makes a copy of SEQ if necessary
to avoid corrupting the original SEQ.
\nKeywords supported: :key :count :start :end :from-end
\n(fn PREDICATE SEQ [KEYWORD VALUE]...)"
- (apply 'remove* nil cl-list :if-not cl-pred cl-keys))
+ (apply 'cl-remove nil cl-list :if-not cl-pred cl-keys))
;;;###autoload
-(defun delete* (cl-item cl-seq &rest cl-keys)
+(defun cl-delete (cl-item cl-seq &rest cl-keys)
"Remove all occurrences of ITEM in SEQ.
This is a destructive function; it reuses the storage of SEQ whenever possible.
\nKeywords supported: :test :test-not :key :count :start :end :from-end
(setq cl-p (cdr cl-p)))
(setq cl-end (1- cl-end)))))
cl-seq)
- (apply 'remove* cl-item cl-seq cl-keys)))))
+ (apply 'cl-remove cl-item cl-seq cl-keys)))))
;;;###autoload
-(defun delete-if (cl-pred cl-list &rest cl-keys)
+(defun cl-delete-if (cl-pred cl-list &rest cl-keys)
"Remove all items satisfying PREDICATE in SEQ.
This is a destructive function; it reuses the storage of SEQ whenever possible.
\nKeywords supported: :key :count :start :end :from-end
\n(fn PREDICATE SEQ [KEYWORD VALUE]...)"
- (apply 'delete* nil cl-list :if cl-pred cl-keys))
+ (apply 'cl-delete nil cl-list :if cl-pred cl-keys))
;;;###autoload
-(defun delete-if-not (cl-pred cl-list &rest cl-keys)
+(defun cl-delete-if-not (cl-pred cl-list &rest cl-keys)
"Remove all items not satisfying PREDICATE in SEQ.
This is a destructive function; it reuses the storage of SEQ whenever possible.
\nKeywords supported: :key :count :start :end :from-end
\n(fn PREDICATE SEQ [KEYWORD VALUE]...)"
- (apply 'delete* nil cl-list :if-not cl-pred cl-keys))
+ (apply 'cl-delete nil cl-list :if-not cl-pred cl-keys))
;;;###autoload
-(defun remove-duplicates (cl-seq &rest cl-keys)
+(defun cl-remove-duplicates (cl-seq &rest cl-keys)
"Return a copy of SEQ with all duplicate elements removed.
\nKeywords supported: :test :test-not :key :start :end :from-end
\n(fn SEQ [KEYWORD VALUE]...)"
(cl--delete-duplicates cl-seq cl-keys t))
;;;###autoload
-(defun delete-duplicates (cl-seq &rest cl-keys)
+(defun cl-delete-duplicates (cl-seq &rest cl-keys)
"Remove all duplicate elements from SEQ (destructively).
\nKeywords supported: :test :test-not :key :start :end :from-end
\n(fn SEQ [KEYWORD VALUE]...)"
(if (stringp cl-seq) (concat cl-res) (vconcat cl-res)))))
;;;###autoload
-(defun substitute (cl-new cl-old cl-seq &rest cl-keys)
+(defun cl-substitute (cl-new cl-old cl-seq &rest cl-keys)
"Substitute NEW for OLD in SEQ.
This is a non-destructive function; it makes a copy of SEQ if necessary
to avoid corrupting the original SEQ.
(or cl-from-end
(progn (cl-set-elt cl-seq cl-i cl-new)
(setq cl-i (1+ cl-i) cl-count (1- cl-count))))
- (apply 'nsubstitute cl-new cl-old cl-seq :count cl-count
+ (apply 'cl-nsubstitute cl-new cl-old cl-seq :count cl-count
:start cl-i cl-keys))))))
;;;###autoload
-(defun substitute-if (cl-new cl-pred cl-list &rest cl-keys)
+(defun cl-substitute-if (cl-new cl-pred cl-list &rest cl-keys)
"Substitute NEW for all items satisfying PREDICATE in SEQ.
This is a non-destructive function; it makes a copy of SEQ if necessary
to avoid corrupting the original SEQ.
\nKeywords supported: :key :count :start :end :from-end
\n(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)"
- (apply 'substitute cl-new nil cl-list :if cl-pred cl-keys))
+ (apply 'cl-substitute cl-new nil cl-list :if cl-pred cl-keys))
;;;###autoload
-(defun substitute-if-not (cl-new cl-pred cl-list &rest cl-keys)
+(defun cl-substitute-if-not (cl-new cl-pred cl-list &rest cl-keys)
"Substitute NEW for all items not satisfying PREDICATE in SEQ.
This is a non-destructive function; it makes a copy of SEQ if necessary
to avoid corrupting the original SEQ.
\nKeywords supported: :key :count :start :end :from-end
\n(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)"
- (apply 'substitute cl-new nil cl-list :if-not cl-pred cl-keys))
+ (apply 'cl-substitute cl-new nil cl-list :if-not cl-pred cl-keys))
;;;###autoload
-(defun nsubstitute (cl-new cl-old cl-seq &rest cl-keys)
+(defun cl-nsubstitute (cl-new cl-old cl-seq &rest cl-keys)
"Substitute NEW for OLD in SEQ.
This is a destructive function; it reuses the storage of SEQ whenever possible.
\nKeywords supported: :test :test-not :key :count :start :end :from-end
cl-seq))
;;;###autoload
-(defun nsubstitute-if (cl-new cl-pred cl-list &rest cl-keys)
+(defun cl-nsubstitute-if (cl-new cl-pred cl-list &rest cl-keys)
"Substitute NEW for all items satisfying PREDICATE in SEQ.
This is a destructive function; it reuses the storage of SEQ whenever possible.
\nKeywords supported: :key :count :start :end :from-end
\n(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)"
- (apply 'nsubstitute cl-new nil cl-list :if cl-pred cl-keys))
+ (apply 'cl-nsubstitute cl-new nil cl-list :if cl-pred cl-keys))
;;;###autoload
-(defun nsubstitute-if-not (cl-new cl-pred cl-list &rest cl-keys)
+(defun cl-nsubstitute-if-not (cl-new cl-pred cl-list &rest cl-keys)
"Substitute NEW for all items not satisfying PREDICATE in SEQ.
This is a destructive function; it reuses the storage of SEQ whenever possible.
\nKeywords supported: :key :count :start :end :from-end
\n(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)"
- (apply 'nsubstitute cl-new nil cl-list :if-not cl-pred cl-keys))
+ (apply 'cl-nsubstitute cl-new nil cl-list :if-not cl-pred cl-keys))
;;;###autoload
-(defun find (cl-item cl-seq &rest cl-keys)
+(defun cl-find (cl-item cl-seq &rest cl-keys)
"Find the first occurrence of ITEM in SEQ.
Return the matching ITEM, or nil if not found.
\nKeywords supported: :test :test-not :key :start :end :from-end
\n(fn ITEM SEQ [KEYWORD VALUE]...)"
- (let ((cl-pos (apply 'position cl-item cl-seq cl-keys)))
+ (let ((cl-pos (apply 'cl-position cl-item cl-seq cl-keys)))
(and cl-pos (elt cl-seq cl-pos))))
;;;###autoload
-(defun find-if (cl-pred cl-list &rest cl-keys)
+(defun cl-find-if (cl-pred cl-list &rest cl-keys)
"Find the first item satisfying PREDICATE in SEQ.
Return the matching item, or nil if not found.
\nKeywords supported: :key :start :end :from-end
\n(fn PREDICATE SEQ [KEYWORD VALUE]...)"
- (apply 'find nil cl-list :if cl-pred cl-keys))
+ (apply 'cl-find nil cl-list :if cl-pred cl-keys))
;;;###autoload
-(defun find-if-not (cl-pred cl-list &rest cl-keys)
+(defun cl-find-if-not (cl-pred cl-list &rest cl-keys)
"Find the first item not satisfying PREDICATE in SEQ.
Return the matching item, or nil if not found.
\nKeywords supported: :key :start :end :from-end
\n(fn PREDICATE SEQ [KEYWORD VALUE]...)"
- (apply 'find nil cl-list :if-not cl-pred cl-keys))
+ (apply 'cl-find nil cl-list :if-not cl-pred cl-keys))
;;;###autoload
-(defun position (cl-item cl-seq &rest cl-keys)
+(defun cl-position (cl-item cl-seq &rest cl-keys)
"Find the first occurrence of ITEM in SEQ.
Return the index of the matching item, or nil if not found.
\nKeywords supported: :test :test-not :key :start :end :from-end
(and (< cl-start cl-end) cl-start))))
;;;###autoload
-(defun position-if (cl-pred cl-list &rest cl-keys)
+(defun cl-position-if (cl-pred cl-list &rest cl-keys)
"Find the first item satisfying PREDICATE in SEQ.
Return the index of the matching item, or nil if not found.
\nKeywords supported: :key :start :end :from-end
\n(fn PREDICATE SEQ [KEYWORD VALUE]...)"
- (apply 'position nil cl-list :if cl-pred cl-keys))
+ (apply 'cl-position nil cl-list :if cl-pred cl-keys))
;;;###autoload
-(defun position-if-not (cl-pred cl-list &rest cl-keys)
+(defun cl-position-if-not (cl-pred cl-list &rest cl-keys)
"Find the first item not satisfying PREDICATE in SEQ.
Return the index of the matching item, or nil if not found.
\nKeywords supported: :key :start :end :from-end
\n(fn PREDICATE SEQ [KEYWORD VALUE]...)"
- (apply 'position nil cl-list :if-not cl-pred cl-keys))
+ (apply 'cl-position nil cl-list :if-not cl-pred cl-keys))
;;;###autoload
-(defun count (cl-item cl-seq &rest cl-keys)
+(defun cl-count (cl-item cl-seq &rest cl-keys)
"Count the number of occurrences of ITEM in SEQ.
\nKeywords supported: :test :test-not :key :start :end
\n(fn ITEM SEQ [KEYWORD VALUE]...)"
cl-count)))
;;;###autoload
-(defun count-if (cl-pred cl-list &rest cl-keys)
+(defun cl-count-if (cl-pred cl-list &rest cl-keys)
"Count the number of items satisfying PREDICATE in SEQ.
\nKeywords supported: :key :start :end
\n(fn PREDICATE SEQ [KEYWORD VALUE]...)"
- (apply 'count nil cl-list :if cl-pred cl-keys))
+ (apply 'cl-count nil cl-list :if cl-pred cl-keys))
;;;###autoload
-(defun count-if-not (cl-pred cl-list &rest cl-keys)
+(defun cl-count-if-not (cl-pred cl-list &rest cl-keys)
"Count the number of items not satisfying PREDICATE in SEQ.
\nKeywords supported: :key :start :end
\n(fn PREDICATE SEQ [KEYWORD VALUE]...)"
- (apply 'count nil cl-list :if-not cl-pred cl-keys))
+ (apply 'cl-count nil cl-list :if-not cl-pred cl-keys))
;;;###autoload
-(defun mismatch (cl-seq1 cl-seq2 &rest cl-keys)
+(defun cl-mismatch (cl-seq1 cl-seq2 &rest cl-keys)
"Compare SEQ1 with SEQ2, return index of first mismatching element.
Return nil if the sequences match. If one sequence is a prefix of the
other, the return value indicates the end of the shorter sequence.
cl-start1)))))
;;;###autoload
-(defun search (cl-seq1 cl-seq2 &rest cl-keys)
+(defun cl-search (cl-seq1 cl-seq2 &rest cl-keys)
"Search for SEQ1 as a subsequence of SEQ2.
Return the index of the leftmost element of the first match found;
return nil if there are no matches.
(while (and (< cl-start2 cl-end2)
(setq cl-pos (cl--position cl-first cl-seq2
cl-start2 cl-end2 cl-from-end))
- (apply 'mismatch cl-seq1 cl-seq2
+ (apply 'cl-mismatch cl-seq1 cl-seq2
:start1 (1+ cl-start1) :end1 cl-end1
:start2 (1+ cl-pos) :end2 (+ cl-pos cl-len)
:from-end nil cl-keys))
(and (< cl-start2 cl-end2) cl-pos)))))
;;;###autoload
-(defun sort* (cl-seq cl-pred &rest cl-keys)
+(defun cl-sort (cl-seq cl-pred &rest cl-keys)
"Sort the argument SEQ according to PREDICATE.
This is a destructive function; it reuses the storage of SEQ if possible.
\nKeywords supported: :key
\n(fn SEQ PREDICATE [KEYWORD VALUE]...)"
(if (nlistp cl-seq)
- (replace cl-seq (apply 'sort* (append cl-seq nil) cl-pred cl-keys))
+ (cl-replace cl-seq (apply 'cl-sort (append cl-seq nil) cl-pred cl-keys))
(cl-parsing-keywords (:key) ()
(if (memq cl-key '(nil identity))
(sort cl-seq cl-pred)
(funcall cl-key cl-y)))))))))
;;;###autoload
-(defun stable-sort (cl-seq cl-pred &rest cl-keys)
+(defun cl-stable-sort (cl-seq cl-pred &rest cl-keys)
"Sort the argument SEQ stably according to PREDICATE.
This is a destructive function; it reuses the storage of SEQ if possible.
\nKeywords supported: :key
\n(fn SEQ PREDICATE [KEYWORD VALUE]...)"
- (apply 'sort* cl-seq cl-pred cl-keys))
+ (apply 'cl-sort cl-seq cl-pred cl-keys))
;;;###autoload
-(defun merge (cl-type cl-seq1 cl-seq2 cl-pred &rest cl-keys)
+(defun cl-merge (cl-type cl-seq1 cl-seq2 cl-pred &rest cl-keys)
"Destructively merge the two sequences to produce a new sequence.
TYPE is the sequence type to return, SEQ1 and SEQ2 are the two argument
sequences, and PREDICATE is a `less-than' predicate on the elements.
(cl-check-key (car cl-seq1)))
(push (pop cl-seq2) cl-res)
(push (pop cl-seq1) cl-res)))
- (coerce (nconc (nreverse cl-res) cl-seq1 cl-seq2) cl-type))))
+ (cl-coerce (nconc (nreverse cl-res) cl-seq1 cl-seq2) cl-type))))
;;; See compiler macro in cl-macs.el
;;;###autoload
-(defun member* (cl-item cl-list &rest cl-keys)
+(defun cl-member (cl-item cl-list &rest cl-keys)
"Find the first occurrence of ITEM in LIST.
Return the sublist of LIST whose car is ITEM.
\nKeywords supported: :test :test-not :key
(memq cl-item cl-list))))
;;;###autoload
-(defun member-if (cl-pred cl-list &rest cl-keys)
+(defun cl-member-if (cl-pred cl-list &rest cl-keys)
"Find the first item satisfying PREDICATE in LIST.
Return the sublist of LIST whose car matches.
\nKeywords supported: :key
\n(fn PREDICATE LIST [KEYWORD VALUE]...)"
- (apply 'member* nil cl-list :if cl-pred cl-keys))
+ (apply 'cl-member nil cl-list :if cl-pred cl-keys))
;;;###autoload
-(defun member-if-not (cl-pred cl-list &rest cl-keys)
+(defun cl-member-if-not (cl-pred cl-list &rest cl-keys)
"Find the first item not satisfying PREDICATE in LIST.
Return the sublist of LIST whose car matches.
\nKeywords supported: :key
\n(fn PREDICATE LIST [KEYWORD VALUE]...)"
- (apply 'member* nil cl-list :if-not cl-pred cl-keys))
+ (apply 'cl-member nil cl-list :if-not cl-pred cl-keys))
;;;###autoload
(defun cl--adjoin (cl-item cl-list &rest cl-keys)
(if (cl-parsing-keywords (:key) t
- (apply 'member* (cl-check-key cl-item) cl-list cl-keys))
+ (apply 'cl-member (cl-check-key cl-item) cl-list cl-keys))
cl-list
(cons cl-item cl-list)))
;;; See compiler macro in cl-macs.el
;;;###autoload
-(defun assoc* (cl-item cl-alist &rest cl-keys)
+(defun cl-assoc (cl-item cl-alist &rest cl-keys)
"Find the first item whose car matches ITEM in LIST.
\nKeywords supported: :test :test-not :key
\n(fn ITEM LIST [KEYWORD VALUE]...)"
(assq cl-item cl-alist))))
;;;###autoload
-(defun assoc-if (cl-pred cl-list &rest cl-keys)
+(defun cl-assoc-if (cl-pred cl-list &rest cl-keys)
"Find the first item whose car satisfies PREDICATE in LIST.
\nKeywords supported: :key
\n(fn PREDICATE LIST [KEYWORD VALUE]...)"
- (apply 'assoc* nil cl-list :if cl-pred cl-keys))
+ (apply 'cl-assoc nil cl-list :if cl-pred cl-keys))
;;;###autoload
-(defun assoc-if-not (cl-pred cl-list &rest cl-keys)
+(defun cl-assoc-if-not (cl-pred cl-list &rest cl-keys)
"Find the first item whose car does not satisfy PREDICATE in LIST.
\nKeywords supported: :key
\n(fn PREDICATE LIST [KEYWORD VALUE]...)"
- (apply 'assoc* nil cl-list :if-not cl-pred cl-keys))
+ (apply 'cl-assoc nil cl-list :if-not cl-pred cl-keys))
;;;###autoload
-(defun rassoc* (cl-item cl-alist &rest cl-keys)
+(defun cl-rassoc (cl-item cl-alist &rest cl-keys)
"Find the first item whose cdr matches ITEM in LIST.
\nKeywords supported: :test :test-not :key
\n(fn ITEM LIST [KEYWORD VALUE]...)"
(rassq cl-item cl-alist)))
;;;###autoload
-(defun rassoc-if (cl-pred cl-list &rest cl-keys)
+(defun cl-rassoc-if (cl-pred cl-list &rest cl-keys)
"Find the first item whose cdr satisfies PREDICATE in LIST.
\nKeywords supported: :key
\n(fn PREDICATE LIST [KEYWORD VALUE]...)"
- (apply 'rassoc* nil cl-list :if cl-pred cl-keys))
+ (apply 'cl-rassoc nil cl-list :if cl-pred cl-keys))
;;;###autoload
-(defun rassoc-if-not (cl-pred cl-list &rest cl-keys)
+(defun cl-rassoc-if-not (cl-pred cl-list &rest cl-keys)
"Find the first item whose cdr does not satisfy PREDICATE in LIST.
\nKeywords supported: :key
\n(fn PREDICATE LIST [KEYWORD VALUE]...)"
- (apply 'rassoc* nil cl-list :if-not cl-pred cl-keys))
+ (apply 'cl-rassoc nil cl-list :if-not cl-pred cl-keys))
;;;###autoload
-(defun union (cl-list1 cl-list2 &rest cl-keys)
+(defun cl-union (cl-list1 cl-list2 &rest cl-keys)
"Combine LIST1 and LIST2 using a set-union operation.
The resulting list contains all items that appear in either LIST1 or LIST2.
This is a non-destructive function; it makes a copy of the data if necessary
(setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1))))
(while cl-list2
(if (or cl-keys (numberp (car cl-list2)))
- (setq cl-list1 (apply 'adjoin (car cl-list2) cl-list1 cl-keys))
+ (setq cl-list1 (apply 'cl-adjoin (car cl-list2) cl-list1 cl-keys))
(or (memq (car cl-list2) cl-list1)
(push (car cl-list2) cl-list1)))
(pop cl-list2))
cl-list1)))
;;;###autoload
-(defun nunion (cl-list1 cl-list2 &rest cl-keys)
+(defun cl-nunion (cl-list1 cl-list2 &rest cl-keys)
"Combine LIST1 and LIST2 using a set-union operation.
The resulting list contains all items that appear in either LIST1 or LIST2.
This is a destructive function; it reuses the storage of LIST1 and LIST2
\nKeywords supported: :test :test-not :key
\n(fn LIST1 LIST2 [KEYWORD VALUE]...)"
(cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
- (t (apply 'union cl-list1 cl-list2 cl-keys))))
+ (t (apply 'cl-union cl-list1 cl-list2 cl-keys))))
;;;###autoload
-(defun intersection (cl-list1 cl-list2 &rest cl-keys)
+(defun cl-intersection (cl-list1 cl-list2 &rest cl-keys)
"Combine LIST1 and LIST2 using a set-intersection operation.
The resulting list contains all items that appear in both LIST1 and LIST2.
This is a non-destructive function; it makes a copy of the data if necessary
(setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1))))
(while cl-list2
(if (if (or cl-keys (numberp (car cl-list2)))
- (apply 'member* (cl-check-key (car cl-list2))
+ (apply 'cl-member (cl-check-key (car cl-list2))
cl-list1 cl-keys)
(memq (car cl-list2) cl-list1))
(push (car cl-list2) cl-res))
cl-res)))))
;;;###autoload
-(defun nintersection (cl-list1 cl-list2 &rest cl-keys)
+(defun cl-nintersection (cl-list1 cl-list2 &rest cl-keys)
"Combine LIST1 and LIST2 using a set-intersection operation.
The resulting list contains all items that appear in both LIST1 and LIST2.
This is a destructive function; it reuses the storage of LIST1 and LIST2
whenever possible.
\nKeywords supported: :test :test-not :key
\n(fn LIST1 LIST2 [KEYWORD VALUE]...)"
- (and cl-list1 cl-list2 (apply 'intersection cl-list1 cl-list2 cl-keys)))
+ (and cl-list1 cl-list2 (apply 'cl-intersection cl-list1 cl-list2 cl-keys)))
;;;###autoload
-(defun set-difference (cl-list1 cl-list2 &rest cl-keys)
+(defun cl-set-difference (cl-list1 cl-list2 &rest cl-keys)
"Combine LIST1 and LIST2 using a set-difference operation.
The resulting list contains all items that appear in LIST1 but not LIST2.
This is a non-destructive function; it makes a copy of the data if necessary
(let ((cl-res nil))
(while cl-list1
(or (if (or cl-keys (numberp (car cl-list1)))
- (apply 'member* (cl-check-key (car cl-list1))
+ (apply 'cl-member (cl-check-key (car cl-list1))
cl-list2 cl-keys)
(memq (car cl-list1) cl-list2))
(push (car cl-list1) cl-res))
cl-res))))
;;;###autoload
-(defun nset-difference (cl-list1 cl-list2 &rest cl-keys)
+(defun cl-nset-difference (cl-list1 cl-list2 &rest cl-keys)
"Combine LIST1 and LIST2 using a set-difference operation.
The resulting list contains all items that appear in LIST1 but not LIST2.
This is a destructive function; it reuses the storage of LIST1 and LIST2
\nKeywords supported: :test :test-not :key
\n(fn LIST1 LIST2 [KEYWORD VALUE]...)"
(if (or (null cl-list1) (null cl-list2)) cl-list1
- (apply 'set-difference cl-list1 cl-list2 cl-keys)))
+ (apply 'cl-set-difference cl-list1 cl-list2 cl-keys)))
;;;###autoload
-(defun set-exclusive-or (cl-list1 cl-list2 &rest cl-keys)
+(defun cl-set-exclusive-or (cl-list1 cl-list2 &rest cl-keys)
"Combine LIST1 and LIST2 using a set-exclusive-or operation.
The resulting list contains all items appearing in exactly one of LIST1, LIST2.
This is a non-destructive function; it makes a copy of the data if necessary
\n(fn LIST1 LIST2 [KEYWORD VALUE]...)"
(cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
((equal cl-list1 cl-list2) nil)
- (t (append (apply 'set-difference cl-list1 cl-list2 cl-keys)
- (apply 'set-difference cl-list2 cl-list1 cl-keys)))))
+ (t (append (apply 'cl-set-difference cl-list1 cl-list2 cl-keys)
+ (apply 'cl-set-difference cl-list2 cl-list1 cl-keys)))))
;;;###autoload
-(defun nset-exclusive-or (cl-list1 cl-list2 &rest cl-keys)
+(defun cl-nset-exclusive-or (cl-list1 cl-list2 &rest cl-keys)
"Combine LIST1 and LIST2 using a set-exclusive-or operation.
The resulting list contains all items appearing in exactly one of LIST1, LIST2.
This is a destructive function; it reuses the storage of LIST1 and LIST2
\n(fn LIST1 LIST2 [KEYWORD VALUE]...)"
(cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
((equal cl-list1 cl-list2) nil)
- (t (nconc (apply 'nset-difference cl-list1 cl-list2 cl-keys)
- (apply 'nset-difference cl-list2 cl-list1 cl-keys)))))
+ (t (nconc (apply 'cl-nset-difference cl-list1 cl-list2 cl-keys)
+ (apply 'cl-nset-difference cl-list2 cl-list1 cl-keys)))))
;;;###autoload
-(defun subsetp (cl-list1 cl-list2 &rest cl-keys)
+(defun cl-subsetp (cl-list1 cl-list2 &rest cl-keys)
"Return true if LIST1 is a subset of LIST2.
I.e., if every element of LIST1 also appears in LIST2.
\nKeywords supported: :test :test-not :key
((equal cl-list1 cl-list2) t)
(t (cl-parsing-keywords (:key) (:test :test-not)
(while (and cl-list1
- (apply 'member* (cl-check-key (car cl-list1))
+ (apply 'cl-member (cl-check-key (car cl-list1))
cl-list2 cl-keys))
(pop cl-list1))
(null cl-list1)))))
;;;###autoload
-(defun subst-if (cl-new cl-pred cl-tree &rest cl-keys)
+(defun cl-subst-if (cl-new cl-pred cl-tree &rest cl-keys)
"Substitute NEW for elements matching PREDICATE in TREE (non-destructively).
Return a copy of TREE with all matching elements replaced by NEW.
\nKeywords supported: :key
\n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)"
- (apply 'sublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys))
+ (apply 'cl-sublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys))
;;;###autoload
-(defun subst-if-not (cl-new cl-pred cl-tree &rest cl-keys)
+(defun cl-subst-if-not (cl-new cl-pred cl-tree &rest cl-keys)
"Substitute NEW for elts not matching PREDICATE in TREE (non-destructively).
Return a copy of TREE with all non-matching elements replaced by NEW.
\nKeywords supported: :key
\n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)"
- (apply 'sublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys))
+ (apply 'cl-sublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys))
;;;###autoload
-(defun nsubst (cl-new cl-old cl-tree &rest cl-keys)
+(defun cl-nsubst (cl-new cl-old cl-tree &rest cl-keys)
"Substitute NEW for OLD everywhere in TREE (destructively).
Any element of TREE which is `eql' to OLD is changed to NEW (via a call
to `setcar').
\nKeywords supported: :test :test-not :key
\n(fn NEW OLD TREE [KEYWORD VALUE]...)"
- (apply 'nsublis (list (cons cl-old cl-new)) cl-tree cl-keys))
+ (apply 'cl-nsublis (list (cons cl-old cl-new)) cl-tree cl-keys))
;;;###autoload
-(defun nsubst-if (cl-new cl-pred cl-tree &rest cl-keys)
+(defun cl-nsubst-if (cl-new cl-pred cl-tree &rest cl-keys)
"Substitute NEW for elements matching PREDICATE in TREE (destructively).
Any element of TREE which matches is changed to NEW (via a call to `setcar').
\nKeywords supported: :key
\n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)"
- (apply 'nsublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys))
+ (apply 'cl-nsublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys))
;;;###autoload
-(defun nsubst-if-not (cl-new cl-pred cl-tree &rest cl-keys)
+(defun cl-nsubst-if-not (cl-new cl-pred cl-tree &rest cl-keys)
"Substitute NEW for elements not matching PREDICATE in TREE (destructively).
Any element of TREE which matches is changed to NEW (via a call to `setcar').
\nKeywords supported: :key
\n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)"
- (apply 'nsublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys))
+ (apply 'cl-nsublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys))
;;;###autoload
-(defun sublis (cl-alist cl-tree &rest cl-keys)
+(defun cl-sublis (cl-alist cl-tree &rest cl-keys)
"Perform substitutions indicated by ALIST in TREE (non-destructively).
Return a copy of TREE with all matching elements replaced.
\nKeywords supported: :test :test-not :key
cl-tree))))
;;;###autoload
-(defun nsublis (cl-alist cl-tree &rest cl-keys)
+(defun cl-nsublis (cl-alist cl-tree &rest cl-keys)
"Perform substitutions indicated by ALIST in TREE (destructively).
Any matching element of TREE is changed via a call to `setcar'.
\nKeywords supported: :test :test-not :key
(setq cl-tree (cdr cl-tree))))))
;;;###autoload
-(defun tree-equal (cl-x cl-y &rest cl-keys)
+(defun cl-tree-equal (cl-x cl-y &rest cl-keys)
"Return t if trees TREE1 and TREE2 have `eql' leaves.
Atoms are compared by `eql'; cons cells are compared recursively.
\nKeywords supported: :test :test-not :key
-;;; cl.el --- Common Lisp extensions for Emacs
+;;; cl.el --- Compatibility aliases for the old CL library.
-;; Copyright (C) 1993, 2001-2012 Free Software Foundation, Inc.
+;; Copyright (C) 2012 Free Software Foundation, Inc.
-;; Author: Dave Gillespie <daveg@synaptics.com>
-;; Version: 2.02
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: extensions
;; This file is part of GNU Emacs.
;;; Commentary:
-;; These are extensions to Emacs Lisp that provide a degree of
-;; Common Lisp compatibility, beyond what is already built-in
-;; in Emacs Lisp.
-;;
-;; This package was written by Dave Gillespie; it is a complete
-;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
-;;
-;; Bug reports, comments, and suggestions are welcome!
-
-;; This file contains the portions of the Common Lisp extensions
-;; package which should always be present.
-
-
-;;; Future notes:
-
-;; Once Emacs 19 becomes standard, many things in this package which are
-;; messy for reasons of compatibility can be greatly simplified. For now,
-;; I prefer to maintain one unified version.
-
-
-;;; Change Log:
-
-;; Version 2.02 (30 Jul 93):
-;; * Added "cl-compat.el" file, extra compatibility with old package.
-;; * Added `lexical-let' and `lexical-let*'.
-;; * Added `define-modify-macro', `callf', and `callf2'.
-;; * Added `ignore-errors'.
-;; * Changed `(setf (nthcdr N PLACE) X)' to work when N is zero.
-;; * Merged `*gentemp-counter*' into `*gensym-counter*'.
-;; * Extended `subseq' to allow negative START and END like `substring'.
-;; * Added `in-ref', `across-ref', `elements of-ref' loop clauses.
-;; * Added `concat', `vconcat' loop clauses.
-;; * Cleaned up a number of compiler warnings.
-
-;; Version 2.01 (7 Jul 93):
-;; * Added support for FSF version of Emacs 19.
-;; * Added `add-hook' for Emacs 18 users.
-;; * Added `defsubst*' and `symbol-macrolet'.
-;; * Added `maplist', `mapc', `mapl', `mapcan', `mapcon'.
-;; * Added `map', `concatenate', `reduce', `merge'.
-;; * Added `revappend', `nreconc', `tailp', `tree-equal'.
-;; * Added `assert', `check-type', `typecase', `typep', and `deftype'.
-;; * Added destructuring and `&environment' support to `defmacro*'.
-;; * Added destructuring to `loop', and added the following clauses:
-;; `elements', `frames', `overlays', `intervals', `buffers', `key-seqs'.
-;; * Renamed `delete' to `delete*' and `remove' to `remove*'.
-;; * Completed support for all keywords in `remove*', `substitute', etc.
-;; * Added `most-positive-float' and company.
-;; * Fixed hash tables to work with latest Lucid Emacs.
-;; * `proclaim' forms are no longer compile-time-evaluating; use `declaim'.
-;; * Syntax for `warn' declarations has changed.
-;; * Improved implementation of `random*'.
-;; * Moved most sequence functions to a new file, cl-seq.el.
-;; * Moved `eval-when' into cl-macs.el.
-;; * Moved `pushnew' and `adjoin' to cl.el for most common cases.
-;; * Moved `provide' forms down to ends of files.
-;; * Changed expansion of `pop' to something that compiles to better code.
-;; * Changed so that no patch is required for Emacs 19 byte compiler.
-;; * Made more things dependent on `optimize' declarations.
-;; * Added a partial implementation of struct print functions.
-;; * Miscellaneous minor changes.
-
-;; Version 2.00:
-;; * First public release of this package.
-
+;; This is a compatibility file which provides the old names provided by CL
+;; before we cleaned up its namespace usage.
;;; Code:
-(defvar cl-optimize-speed 1)
-(defvar cl-optimize-safety 1)
-
-
-;;;###autoload
-(defvar custom-print-functions nil
- "This is a list of functions that format user objects for printing.
-Each function is called in turn with three arguments: the object, the
-stream, and the print level (currently ignored). If it is able to
-print the object it returns true; otherwise it returns nil and the
-printer proceeds to the next function on the list.
-
-This variable is not used at present, but it is defined in hopes that
-a future Emacs interpreter will be able to use it.")
-
-(defun cl-unload-function ()
- "Stop unloading of the Common Lisp extensions."
- (message "Cannot unload the feature `cl'")
- ;; stop standard unloading!
- t)
-
-;;; Generalized variables.
-;; These macros are defined here so that they
-;; can safely be used in .emacs files.
-
-(defmacro incf (place &optional x)
- "Increment PLACE by X (1 by default).
-PLACE may be a symbol, or any generalized variable allowed by `setf'.
-The return value is the incremented value of PLACE."
- (declare (debug (place &optional form)))
- (if (symbolp place)
- (list 'setq place (if x (list '+ place x) (list '1+ place)))
- (list 'callf '+ place (or x 1))))
-
-(defmacro decf (place &optional x)
- "Decrement PLACE by X (1 by default).
-PLACE may be a symbol, or any generalized variable allowed by `setf'.
-The return value is the decremented value of PLACE."
- (declare (debug incf))
- (if (symbolp place)
- (list 'setq place (if x (list '- place x) (list '1- place)))
- (list 'callf '- place (or x 1))))
-
-;; Autoloaded, but we haven't loaded cl-loaddefs yet.
-(declare-function cl-do-pop "cl-macs" (place))
-
-(defmacro pop (place)
- "Remove and return the head of the list stored in PLACE.
-Analogous to (prog1 (car PLACE) (setf PLACE (cdr PLACE))), though more
-careful about evaluating each argument only once and in the right order.
-PLACE may be a symbol, or any generalized variable allowed by `setf'."
- (declare (debug (place)))
- (if (symbolp place)
- (list 'car (list 'prog1 place (list 'setq place (list 'cdr place))))
- (cl-do-pop place)))
-
-(defmacro push (x place)
- "Insert X at the head of the list stored in PLACE.
-Analogous to (setf PLACE (cons X PLACE)), though more careful about
-evaluating each argument only once and in the right order. PLACE may
-be a symbol, or any generalized variable allowed by `setf'."
- (declare (debug (form place)))
- (if (symbolp place) (list 'setq place (list 'cons x place))
- (list 'callf2 'cons x place)))
-
-(defmacro pushnew (x place &rest keys)
- "(pushnew X PLACE): insert X at the head of the list if not already there.
-Like (push X PLACE), except that the list is unmodified if X is `eql' to
-an element already on the list.
-\nKeywords supported: :test :test-not :key
-\n(fn X PLACE [KEYWORD VALUE]...)"
- (declare (debug
- (form place &rest
- &or [[&or ":test" ":test-not" ":key"] function-form]
- [keywordp form])))
- (if (symbolp place)
- (if (null keys)
- `(let ((x ,x))
- (if (memql x ,place)
- ;; This symbol may later on expand to actual code which then
- ;; trigger warnings like "value unused" since pushnew's return
- ;; value is rarely used. It should not matter that other
- ;; warnings may be silenced, since `place' is used earlier and
- ;; should have triggered them already.
- (with-no-warnings ,place)
- (setq ,place (cons x ,place))))
- (list 'setq place (list* 'adjoin x place keys)))
- (list* 'callf2 'adjoin x place keys)))
-
-(defun cl-set-elt (seq n val)
- (if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val)))
-
-(defsubst cl-set-nthcdr (n list x)
- (if (<= n 0) x (setcdr (nthcdr (1- n) list) x) list))
-
-(defun cl-set-buffer-substring (start end val)
- (save-excursion (delete-region start end)
- (goto-char start)
- (insert val)
- val))
-
-(defun cl-set-substring (str start end val)
- (if end (if (< end 0) (incf end (length str)))
- (setq end (length str)))
- (if (< start 0) (incf start (length str)))
- (concat (and (> start 0) (substring str 0 start))
- val
- (and (< end (length str)) (substring str end))))
-
-
-;;; Control structures.
-
-;; These macros are so simple and so often-used that it's better to have
-;; them all the time than to load them from cl-macs.el.
-
-(defun cl-map-extents (&rest cl-args)
- (apply 'cl-map-overlays cl-args))
-
-
-;;; Blocks and exits.
-
-(defalias 'cl-block-wrapper 'identity)
-(defalias 'cl-block-throw 'throw)
-
-
-;;; Multiple values.
-;; True multiple values are not supported, or even
-;; simulated. Instead, multiple-value-bind and friends simply expect
-;; the target form to return the values as a list.
-
-(defsubst values (&rest values)
- "Return multiple values, Common Lisp style.
-The arguments of `values' are the values
-that the containing function should return."
- values)
-
-(defsubst values-list (list)
- "Return multiple values, Common Lisp style, taken from a list.
-LIST specifies the list of values
-that the containing function should return."
- list)
-
-(defsubst multiple-value-list (expression)
- "Return a list of the multiple values produced by EXPRESSION.
-This handles multiple values in Common Lisp style, but it does not
-work right when EXPRESSION calls an ordinary Emacs Lisp function
-that returns just one value."
- expression)
-
-(defsubst multiple-value-apply (function expression)
- "Evaluate EXPRESSION to get multiple values and apply FUNCTION to them.
-This handles multiple values in Common Lisp style, but it does not work
-right when EXPRESSION calls an ordinary Emacs Lisp function that returns just
-one value."
- (apply function expression))
-
-(defalias 'multiple-value-call 'apply
- "Apply FUNCTION to ARGUMENTS, taking multiple values into account.
-This implementation only handles the case where there is only one argument.")
-
-(defsubst nth-value (n expression)
- "Evaluate EXPRESSION to get multiple values and return the Nth one.
-This handles multiple values in Common Lisp style, but it does not work
-right when EXPRESSION calls an ordinary Emacs Lisp function that returns just
-one value."
- (nth n expression))
-
-;;; Macros.
-
-(defvar cl-macro-environment)
-(defvar cl-old-macroexpand (prog1 (symbol-function 'macroexpand)
- (defalias 'macroexpand 'cl-macroexpand)))
-
-(defun cl-macroexpand (cl-macro &optional cl-env)
- "Return result of expanding macros at top level of FORM.
-If FORM is not a macro call, it is returned unchanged.
-Otherwise, the macro is expanded and the expansion is considered
-in place of FORM. When a non-macro-call results, it is returned.
-
-The second optional arg ENVIRONMENT specifies an environment of macro
-definitions to shadow the loaded ones for use in file byte-compilation.
-\n(fn FORM &optional ENVIRONMENT)"
- (let ((cl-macro-environment cl-env))
- (while (progn (setq cl-macro (funcall cl-old-macroexpand cl-macro cl-env))
- (and (symbolp cl-macro)
- (cdr (assq (symbol-name cl-macro) cl-env))))
- (setq cl-macro (cadr (assq (symbol-name cl-macro) cl-env))))
- cl-macro))
-
-
-;;; Declarations.
-
-(defvar cl-compiling-file nil)
-(defun cl-compiling-file ()
- (or cl-compiling-file
- (and (boundp 'byte-compile--outbuffer)
- (bufferp (symbol-value 'byte-compile--outbuffer))
- (equal (buffer-name (symbol-value 'byte-compile--outbuffer))
- " *Compiler Output*"))))
-
-(defvar cl-proclaims-deferred nil)
-
-(defun proclaim (spec)
- (if (fboundp 'cl-do-proclaim) (cl-do-proclaim spec t)
- (push spec cl-proclaims-deferred))
- nil)
-
-(defmacro declaim (&rest specs)
- (let ((body (mapcar (function (lambda (x) (list 'proclaim (list 'quote x))))
- specs)))
- (if (cl-compiling-file) (list* 'eval-when '(compile load eval) body)
- (cons 'progn body)))) ; avoid loading cl-macs.el for eval-when
-
-
-;;; Symbols.
-
-(defun cl-random-time ()
- (let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0))
- (while (>= (decf i) 0) (setq v (+ (* v 3) (aref time i))))
- v))
-
-(defvar cl--gensym-counter (* (logand (cl-random-time) 1023) 100))
-
-
-;;; Numbers.
-
-(defun floatp-safe (object)
- "Return t if OBJECT is a floating point number.
-On Emacs versions that lack floating-point support, this function
-always returns nil."
- (and (numberp object) (not (integerp object))))
-
-(defun plusp (number)
- "Return t if NUMBER is positive."
- (> number 0))
-
-(defun minusp (number)
- "Return t if NUMBER is negative."
- (< number 0))
-
-(defun oddp (integer)
- "Return t if INTEGER is odd."
- (eq (logand integer 1) 1))
-
-(defun evenp (integer)
- "Return t if INTEGER is even."
- (eq (logand integer 1) 0))
-
-(defvar cl--random-state (vector 'cl-random-state-tag -1 30 (cl-random-time)))
-
-(defconst most-positive-float nil
- "The largest value that a Lisp float can hold.
-If your system supports infinities, this is the largest finite value.
-For IEEE machines, this is approximately 1.79e+308.
-Call `cl-float-limits' to set this.")
-
-(defconst most-negative-float nil
- "The largest negative value that a Lisp float can hold.
-This is simply -`most-positive-float'.
-Call `cl-float-limits' to set this.")
-
-(defconst least-positive-float nil
- "The smallest value greater than zero that a Lisp float can hold.
-For IEEE machines, it is about 4.94e-324 if denormals are supported,
-or 2.22e-308 if they are not.
-Call `cl-float-limits' to set this.")
-
-(defconst least-negative-float nil
- "The smallest value less than zero that a Lisp float can hold.
-This is simply -`least-positive-float'.
-Call `cl-float-limits' to set this.")
-
-(defconst least-positive-normalized-float nil
- "The smallest normalized Lisp float greater than zero.
-This is the smallest value for which IEEE denormalization does not lose
-precision. For IEEE machines, this value is about 2.22e-308.
-For machines that do not support the concept of denormalization
-and gradual underflow, this constant equals `least-positive-float'.
-Call `cl-float-limits' to set this.")
-
-(defconst least-negative-normalized-float nil
- "The smallest normalized Lisp float less than zero.
-This is simply -`least-positive-normalized-float'.
-Call `cl-float-limits' to set this.")
-
-(defconst float-epsilon nil
- "The smallest positive float that adds to 1.0 to give a distinct value.
-Adding a number less than this to 1.0 returns 1.0 due to roundoff.
-For IEEE machines, epsilon is about 2.22e-16.
-Call `cl-float-limits' to set this.")
+(require 'cl-lib)
+
+;; (defun cl--rename ()
+;; (let ((vdefs ())
+;; (fdefs ())
+;; (case-fold-search nil)
+;; (files '("cl.el" "cl-macs.el" "cl-seq.el" "cl-extra.el")))
+;; (dolist (file files)
+;; (with-current-buffer (find-file-noselect file)
+;; (goto-char (point-min))
+;; (while (re-search-forward
+;; "^(\\(def[^ \t\n]*\\) +'?\\(\\(\\sw\\|\\s_\\)+\\)" nil t)
+;; (let ((name (match-string-no-properties 2))
+;; (type (match-string-no-properties 1)))
+;; (unless (string-match-p "\\`cl-" name)
+;; (cond
+;; ((member type '("defvar" "defconst"))
+;; (unless (member name vdefs) (push name vdefs)))
+;; ((member type '("defun" "defsubst" "defalias" "defmacro"))
+;; (unless (member name fdefs) (push name fdefs)))
+;; ((member type '("def-edebug-spec" "defsetf" "define-setf-method"
+;; "define-compiler-macro"))
+;; nil)
+;; (t (error "Unknown type %S" type))))))))
+;; (let ((re (concat "\\_<" (regexp-opt (append vdefs fdefs)) "\\_>"))
+;; (conflicts ()))
+;; (dolist (file files)
+;; (with-current-buffer (find-file-noselect file)
+;; (goto-char (point-min))
+;; (while (re-search-forward re nil t)
+;; (replace-match "cl-\\&"))
+;; (save-buffer))))
+;; (with-current-buffer (find-file-noselect "cl-rename.el")
+;; (dolist (def vdefs)
+;; (insert (format "(defvaralias '%s 'cl-%s)\n" def def)))
+;; (dolist (def fdefs)
+;; (insert (format "(defalias '%s 'cl-%s)\n" def def)))
+;; (save-buffer))))
+
+;; (defun cl--unrename ()
+;; ;; Taken from "Naming Conventions" node of the doc.
+;; (let* ((names '(defun* defsubst* defmacro* function* member*
+;; assoc* rassoc* get* remove* delete*
+;; mapcar* sort* floor* ceiling* truncate*
+;; round* mod* rem* random*))
+;; (files '("cl.el" "cl-lib.el" "cl-macs.el" "cl-seq.el" "cl-extra.el"))
+;; (re (concat "\\_<cl-" (regexp-opt (mapcar #'symbol-name names))
+;; "\\_>")))
+;; (dolist (file files)
+;; (with-current-buffer (find-file-noselect file)
+;; (goto-char (point-min))
+;; (while (re-search-forward re nil t)
+;; (delete-region (1- (point)) (point)))
+;; (save-buffer)))))
+(dolist (var '(
+ ;; loop-result-var
+ ;; loop-result
+ ;; loop-initially
+ ;; loop-finally
+ ;; loop-bindings
+ ;; loop-args
+ ;; bind-inits
+ ;; bind-block
+ ;; lambda-list-keywords
+ float-negative-epsilon
+ float-epsilon
+ least-negative-normalized-float
+ least-positive-normalized-float
+ least-negative-float
+ least-positive-float
+ most-negative-float
+ most-positive-float
+ ;; custom-print-functions
+ ))
+ (defvaralias var (intern (format "cl-%s" var))))
+
+(dolist (fun '(
+ (get* . cl-get)
+ (random* . cl-random)
+ (rem* . cl-rem)
+ (mod* . cl-mod)
+ (round* . cl-round)
+ (truncate* . cl-truncate)
+ (ceiling* . cl-ceiling)
+ (floor* . cl-floor)
+ (rassoc* . cl-rassoc)
+ (assoc* . cl-assoc)
+ (member* . cl-member)
+ (delete* . cl-delete)
+ (remove* . cl-remove)
+ (defsubst* . cl-defsubst)
+ (sort* . cl-sort)
+ (function* . cl-function)
+ (defmacro* . cl-defmacro)
+ (defun* . cl-defun)
+ (mapcar* . cl-mapcar)
+
+ remprop
+ getf
+ tailp
+ list-length
+ nreconc
+ revappend
+ concatenate
+ subseq
+ random-state-p
+ make-random-state
+ signum
+ isqrt
+ lcm
+ gcd
+ notevery
+ notany
+ every
+ some
+ mapcon
+ mapcan
+ mapl
+ maplist
+ map
+ equalp
+ coerce
+ tree-equal
+ nsublis
+ sublis
+ nsubst-if-not
+ nsubst-if
+ nsubst
+ subst-if-not
+ subst-if
+ subsetp
+ nset-exclusive-or
+ set-exclusive-or
+ nset-difference
+ set-difference
+ nintersection
+ intersection
+ nunion
+ union
+ rassoc-if-not
+ rassoc-if
+ assoc-if-not
+ assoc-if
+ member-if-not
+ member-if
+ merge
+ stable-sort
+ search
+ mismatch
+ count-if-not
+ count-if
+ count
+ position-if-not
+ position-if
+ position
+ find-if-not
+ find-if
+ find
+ nsubstitute-if-not
+ nsubstitute-if
+ nsubstitute
+ substitute-if-not
+ substitute-if
+ substitute
+ delete-duplicates
+ remove-duplicates
+ delete-if-not
+ delete-if
+ remove-if-not
+ remove-if
+ replace
+ fill
+ reduce
+ compiler-macroexpand
+ define-compiler-macro
+ assert
+ check-type
+ typep
+ deftype
+ defstruct
+ define-modify-macro
+ callf2
+ callf
+ letf*
+ letf
+ rotatef
+ shiftf
+ remf
+ psetf
+ setf
+ get-setf-method
+ defsetf
+ define-setf-expander
+ define-setf-method
+ declare
+ the
+ locally
+ multiple-value-setq
+ multiple-value-bind
+ lexical-let*
+ lexical-let
+ symbol-macrolet
+ macrolet
+ labels
+ flet
+ progv
+ psetq
+ do-all-symbols
+ do-symbols
+ dotimes
+ dolist
+ do*
+ do
+ loop
+ return-from
+ return
+ block
+ etypecase
+ typecase
+ ecase
+ case
+ load-time-value
+ eval-when
+ destructuring-bind
+ gentemp
+ gensym
+ pairlis
+ acons
+ subst
+ adjoin
+ copy-list
+ ldiff
+ list*
+ cddddr
+ cdddar
+ cddadr
+ cddaar
+ cdaddr
+ cdadar
+ cdaadr
+ cdaaar
+ cadddr
+ caddar
+ cadadr
+ cadaar
+ caaddr
+ caadar
+ caaadr
+ caaaar
+ cdddr
+ cddar
+ cdadr
+ cdaar
+ caddr
+ cadar
+ caadr
+ caaar
+ tenth
+ ninth
+ eighth
+ seventh
+ sixth
+ fifth
+ fourth
+ third
+ endp
+ rest
+ second
+ first
+ svref
+ copy-seq
+ evenp
+ oddp
+ minusp
+ plusp
+ floatp-safe
+ declaim
+ proclaim
+ nth-value
+ multiple-value-call
+ multiple-value-apply
+ multiple-value-list
+ values-list
+ values
+ pushnew
+ push
+ pop
+ decf
+ incf
+ ))
+ (let ((new (if (consp fun) (prog1 (cdr fun) (setq fun (car fun)))
+ (intern (format "cl-%s" fun)))))
+ (defalias fun new)
+ ;; If `cl-foo' is declare inline, then make `foo' inline as well, and
+ ;; similarly, if `cl-foo' has a compiler-macro, make it available for `foo'
+ ;; as well. Same for edebug specifications, indent rules and
+ ;; doc-string position.
+ ;; FIXME: For most of them, we should instead follow aliases
+ ;; where applicable.
+ (dolist (prop '(byte-optimizer byte-compile cl-compiler-macro
+ doc-string-elt edebug-form-spec
+ lisp-indent-function))
+ (if (get new prop)
+ (put fun prop (get new prop))))))
-(defconst float-negative-epsilon nil
- "The smallest positive float that subtracts from 1.0 to give a distinct value.
-For IEEE machines, it is about 1.11e-16.
-Call `cl-float-limits' to set this.")
-
-
-;;; Sequence functions.
-
-(defalias 'copy-seq 'copy-sequence)
-
-(declare-function cl-mapcar-many "cl-extra" (cl-func cl-seqs))
-
-(defun mapcar* (cl-func cl-x &rest cl-rest)
- "Apply FUNCTION to each element of SEQ, and make a list of the results.
-If there are several SEQs, FUNCTION is called with that many arguments,
-and mapping stops as soon as the shortest list runs out. With just one
-SEQ, this is like `mapcar'. With several, it is like the Common Lisp
-`mapcar' function extended to arbitrary sequence types.
-\n(fn FUNCTION SEQ...)"
- (if cl-rest
- (if (or (cdr cl-rest) (nlistp cl-x) (nlistp (car cl-rest)))
- (cl-mapcar-many cl-func (cons cl-x cl-rest))
- (let ((cl-res nil) (cl-y (car cl-rest)))
- (while (and cl-x cl-y)
- (push (funcall cl-func (pop cl-x) (pop cl-y)) cl-res))
- (nreverse cl-res)))
- (mapcar cl-func cl-x)))
-
-(defalias 'svref 'aref)
-
-;;; List functions.
-
-(defalias 'first 'car)
-(defalias 'second 'cadr)
-(defalias 'rest 'cdr)
-(defalias 'endp 'null)
-
-(defun third (x)
- "Return the third element of the list X."
- (car (cdr (cdr x))))
-
-(defun fourth (x)
- "Return the fourth element of the list X."
- (nth 3 x))
-
-(defun fifth (x)
- "Return the fifth element of the list X."
- (nth 4 x))
-
-(defun sixth (x)
- "Return the sixth element of the list X."
- (nth 5 x))
-
-(defun seventh (x)
- "Return the seventh element of the list X."
- (nth 6 x))
-
-(defun eighth (x)
- "Return the eighth element of the list X."
- (nth 7 x))
-
-(defun ninth (x)
- "Return the ninth element of the list X."
- (nth 8 x))
-
-(defun tenth (x)
- "Return the tenth element of the list X."
- (nth 9 x))
-
-(defun caaar (x)
- "Return the `car' of the `car' of the `car' of X."
- (car (car (car x))))
-
-(defun caadr (x)
- "Return the `car' of the `car' of the `cdr' of X."
- (car (car (cdr x))))
-
-(defun cadar (x)
- "Return the `car' of the `cdr' of the `car' of X."
- (car (cdr (car x))))
-
-(defun caddr (x)
- "Return the `car' of the `cdr' of the `cdr' of X."
- (car (cdr (cdr x))))
-
-(defun cdaar (x)
- "Return the `cdr' of the `car' of the `car' of X."
- (cdr (car (car x))))
-
-(defun cdadr (x)
- "Return the `cdr' of the `car' of the `cdr' of X."
- (cdr (car (cdr x))))
-
-(defun cddar (x)
- "Return the `cdr' of the `cdr' of the `car' of X."
- (cdr (cdr (car x))))
-
-(defun cdddr (x)
- "Return the `cdr' of the `cdr' of the `cdr' of X."
- (cdr (cdr (cdr x))))
-
-(defun caaaar (x)
- "Return the `car' of the `car' of the `car' of the `car' of X."
- (car (car (car (car x)))))
-
-(defun caaadr (x)
- "Return the `car' of the `car' of the `car' of the `cdr' of X."
- (car (car (car (cdr x)))))
-
-(defun caadar (x)
- "Return the `car' of the `car' of the `cdr' of the `car' of X."
- (car (car (cdr (car x)))))
-
-(defun caaddr (x)
- "Return the `car' of the `car' of the `cdr' of the `cdr' of X."
- (car (car (cdr (cdr x)))))
-
-(defun cadaar (x)
- "Return the `car' of the `cdr' of the `car' of the `car' of X."
- (car (cdr (car (car x)))))
-
-(defun cadadr (x)
- "Return the `car' of the `cdr' of the `car' of the `cdr' of X."
- (car (cdr (car (cdr x)))))
-
-(defun caddar (x)
- "Return the `car' of the `cdr' of the `cdr' of the `car' of X."
- (car (cdr (cdr (car x)))))
-
-(defun cadddr (x)
- "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X."
- (car (cdr (cdr (cdr x)))))
-
-(defun cdaaar (x)
- "Return the `cdr' of the `car' of the `car' of the `car' of X."
- (cdr (car (car (car x)))))
-
-(defun cdaadr (x)
- "Return the `cdr' of the `car' of the `car' of the `cdr' of X."
- (cdr (car (car (cdr x)))))
-
-(defun cdadar (x)
- "Return the `cdr' of the `car' of the `cdr' of the `car' of X."
- (cdr (car (cdr (car x)))))
-
-(defun cdaddr (x)
- "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X."
- (cdr (car (cdr (cdr x)))))
-
-(defun cddaar (x)
- "Return the `cdr' of the `cdr' of the `car' of the `car' of X."
- (cdr (cdr (car (car x)))))
-
-(defun cddadr (x)
- "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X."
- (cdr (cdr (car (cdr x)))))
-
-(defun cdddar (x)
- "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X."
- (cdr (cdr (cdr (car x)))))
-
-(defun cddddr (x)
- "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X."
- (cdr (cdr (cdr (cdr x)))))
-
-;;(defun last* (x &optional n)
-;; "Returns the last link in the list LIST.
-;;With optional argument N, returns Nth-to-last link (default 1)."
-;; (if n
-;; (let ((m 0) (p x))
-;; (while (consp p) (incf m) (pop p))
-;; (if (<= n 0) p
-;; (if (< n m) (nthcdr (- m n) x) x)))
-;; (while (consp (cdr x)) (pop x))
-;; x))
-
-(defun list* (arg &rest rest) ; See compiler macro in cl-macs.el
- "Return a new list with specified ARGs as elements, consed to last ARG.
-Thus, `(list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to
-`(cons A (cons B (cons C D)))'.
-\n(fn ARG...)"
- (cond ((not rest) arg)
- ((not (cdr rest)) (cons arg (car rest)))
- (t (let* ((n (length rest))
- (copy (copy-sequence rest))
- (last (nthcdr (- n 2) copy)))
- (setcdr last (car (cdr last)))
- (cons arg copy)))))
-
-(defun ldiff (list sublist)
- "Return a copy of LIST with the tail SUBLIST removed."
- (let ((res nil))
- (while (and (consp list) (not (eq list sublist)))
- (push (pop list) res))
- (nreverse res)))
-
-(defun copy-list (list)
- "Return a copy of LIST, which may be a dotted list.
-The elements of LIST are not copied, just the list structure itself."
- (if (consp list)
- (let ((res nil))
- (while (consp list) (push (pop list) res))
- (prog1 (nreverse res) (setcdr res list)))
- (car list)))
-
-(defun cl-maclisp-member (item list)
- (while (and list (not (equal item (car list)))) (setq list (cdr list)))
- list)
-
-(defalias 'cl-member 'memq) ; for compatibility with old CL package
-
-;; Autoloaded, but we have not loaded cl-loaddefs yet.
-(declare-function floor* "cl-extra" (x &optional y))
-(declare-function ceiling* "cl-extra" (x &optional y))
-(declare-function truncate* "cl-extra" (x &optional y))
-(declare-function round* "cl-extra" (x &optional y))
-(declare-function mod* "cl-extra" (x y))
-
-(defalias 'cl-floor 'floor*)
-(defalias 'cl-ceiling 'ceiling*)
-(defalias 'cl-truncate 'truncate*)
-(defalias 'cl-round 'round*)
-(defalias 'cl-mod 'mod*)
-
-(defun adjoin (cl-item cl-list &rest cl-keys) ; See compiler macro in cl-macs
- "Return ITEM consed onto the front of LIST only if it's not already there.
-Otherwise, return LIST unmodified.
-\nKeywords supported: :test :test-not :key
-\n(fn ITEM LIST [KEYWORD VALUE]...)"
- (cond ((or (equal cl-keys '(:test eq))
- (and (null cl-keys) (not (numberp cl-item))))
- (if (memq cl-item cl-list) cl-list (cons cl-item cl-list)))
- ((or (equal cl-keys '(:test equal)) (null cl-keys))
- (if (member cl-item cl-list) cl-list (cons cl-item cl-list)))
- (t (apply 'cl--adjoin cl-item cl-list cl-keys))))
-
-(defun subst (cl-new cl-old cl-tree &rest cl-keys)
- "Substitute NEW for OLD everywhere in TREE (non-destructively).
-Return a copy of TREE with all elements `eql' to OLD replaced by NEW.
-\nKeywords supported: :test :test-not :key
-\n(fn NEW OLD TREE [KEYWORD VALUE]...)"
- (if (or cl-keys (and (numberp cl-old) (not (integerp cl-old))))
- (apply 'sublis (list (cons cl-old cl-new)) cl-tree cl-keys)
- (cl-do-subst cl-new cl-old cl-tree)))
-
-(defun cl-do-subst (cl-new cl-old cl-tree)
- (cond ((eq cl-tree cl-old) cl-new)
- ((consp cl-tree)
- (let ((a (cl-do-subst cl-new cl-old (car cl-tree)))
- (d (cl-do-subst cl-new cl-old (cdr cl-tree))))
- (if (and (eq a (car cl-tree)) (eq d (cdr cl-tree)))
- cl-tree (cons a d))))
- (t cl-tree)))
-
-(defun acons (key value alist)
- "Add KEY and VALUE to ALIST.
-Return a new list with (cons KEY VALUE) as car and ALIST as cdr."
- (cons (cons key value) alist))
-
-(defun pairlis (keys values &optional alist)
- "Make an alist from KEYS and VALUES.
-Return a new alist composed by associating KEYS to corresponding VALUES;
-the process stops as soon as KEYS or VALUES run out.
-If ALIST is non-nil, the new pairs are prepended to it."
- (nconc (mapcar* 'cons keys values) alist))
-
-
-;;; Miscellaneous.
-
-;; Autoload the other portions of the package.
-;; We want to replace the basic versions of dolist, dotimes, declare below.
-(fmakunbound 'dolist)
-(fmakunbound 'dotimes)
-(fmakunbound 'declare)
-;;;###autoload
-(progn
- ;; Autoload, so autoload.el and font-lock can use it even when CL
- ;; is not loaded.
- (put 'defun* 'doc-string-elt 3)
- (put 'defmacro* 'doc-string-elt 3)
- (put 'defsubst 'doc-string-elt 3)
- (put 'defstruct 'doc-string-elt 2))
-
-(load "cl-loaddefs" nil 'quiet)
-
-;; This goes here so that cl-macs can find it if it loads right now.
(provide 'cl)
-
-;; Things to do after byte-compiler is loaded.
-
-(defvar cl-hacked-flag nil)
-(defun cl-hack-byte-compiler ()
- (and (not cl-hacked-flag) (fboundp 'byte-compile-file-form)
- (progn
- (setq cl-hacked-flag t) ; Do it first, to prevent recursion.
- (load "cl-macs" nil t)
- (run-hooks 'cl-hack-bytecomp-hook))))
-
-;; Try it now in case the compiler has already been loaded.
-(cl-hack-byte-compiler)
-
-;; Also make a hook in case compiler is loaded after this file.
-(add-hook 'bytecomp-load-hook 'cl-hack-byte-compiler)
-
-
-;; The following ensures that packages which expect the old-style cl.el
-;; will be happy with this one.
-
-(provide 'cl)
-
-(run-hooks 'cl-load-hook)
-
-;; Local variables:
-;; byte-compile-dynamic: t
-;; byte-compile-warnings: (not cl-functions)
-;; End:
-
;;; cl.el ends here
projects / emacs.git / commitdiff