[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] trunk r117000: Untabify cl-macs.el
|
From: |
Daniel Colascione |
|
Subject: |
[Emacs-diffs] trunk r117000: Untabify cl-macs.el |
|
Date: |
Mon, 21 Apr 2014 00:03:53 +0000 |
|
User-agent: |
Bazaar (2.6b2) |
------------------------------------------------------------
revno: 117000
revision-id: address@hidden
parent: address@hidden
committer: Daniel Colascione <address@hidden>
branch nick: trunk
timestamp: Sun 2014-04-20 17:03:44 -0700
message:
Untabify cl-macs.el
modified:
lisp/ChangeLog changelog-20091113204419-o5vbwnq5f7feedwu-1432
lisp/emacs-lisp/cl-macs.el clmacs.el-20091113204419-o5vbwnq5f7feedwu-612
=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog 2014-04-20 23:24:04 +0000
+++ b/lisp/ChangeLog 2014-04-21 00:03:44 +0000
@@ -1,3 +1,7 @@
+2014-04-21 Daniel Colascione <address@hidden>
+
+ * emacs-lisp/cl-macs.el: Untabify file.
+
2014-04-20 Daniel Colascione <address@hidden>
* vc/vc.el (vc-root-dir): New public autoloaded function for
=== modified file 'lisp/emacs-lisp/cl-macs.el'
--- a/lisp/emacs-lisp/cl-macs.el 2014-04-20 14:46:13 +0000
+++ b/lisp/emacs-lisp/cl-macs.el 2014-04-21 00:03:44 +0000
@@ -65,7 +65,7 @@
;;;###autoload
(defun cl--compiler-macro-list* (_form arg &rest others)
(let* ((args (reverse (cons arg others)))
- (form (car args)))
+ (form (car args)))
(while (setq args (cdr args))
(setq form `(cons ,(car args) ,form)))
form))
@@ -90,22 +90,22 @@
;; macro expanders to optimize the results in certain common cases.
(defconst cl--simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max
- car-safe cdr-safe progn prog1 prog2))
+ car-safe cdr-safe progn prog1 prog2))
(defconst cl--safe-funcs '(* / % length memq list vector vectorp
- < > <= >= = error))
+ < > <= >= = error))
(defun cl--simple-expr-p (x &optional size)
"Check if no side effects, and executes quickly."
(or size (setq size 10))
(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))
- (progn
- (setq size (1- size))
- (while (and (setq x (cdr x))
- (setq size (cl--simple-expr-p (car x) size))))
- (and (null x) (>= size 0) size)))
+ (or (memq (car x) cl--simple-funcs)
+ (get (car x) 'side-effect-free))
+ (progn
+ (setq size (1- size))
+ (while (and (setq x (cdr x))
+ (setq size (cl--simple-expr-p (car x) size))))
+ (and (null x) (>= size 0) size)))
(and (> size 0) (1- size))))
(defun cl--simple-exprs-p (xs)
@@ -117,22 +117,22 @@
"Check if no side effects."
(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)
- (get (car x) 'side-effect-free))
- (progn
- (while (and (setq x (cdr x)) (cl--safe-expr-p (car x))))
- (null x)))))
+ (or (memq (car x) cl--simple-funcs)
+ (memq (car x) cl--safe-funcs)
+ (get (car x) 'side-effect-free))
+ (progn
+ (while (and (setq x (cdr x)) (cl--safe-expr-p (car x))))
+ (null x)))))
;;; Check if constant (i.e., no side effects or dependencies).
(defun cl--const-expr-p (x)
(cond ((consp x)
- (or (eq (car x) 'quote)
- (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))
- (t t)))
+ (or (eq (car x) 'quote)
+ (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))
+ (t t)))
(defun cl--const-expr-val (x &optional environment default)
"Return the value of X known at compile-time.
@@ -151,13 +151,13 @@
;; 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 cl-function))))
- (let ((sum 0))
- (while (consp x)
- (setq sum (+ sum (or (cl--expr-contains (pop x) y) 0))))
- (setq sum (+ sum (or (cl--expr-contains x y) 0)))
- (and (> sum 0) sum)))
- (t nil)))
+ ((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))))
+ (setq sum (+ sum (or (cl--expr-contains x y) 0)))
+ (and (> sum 0) sum)))
+ (t nil)))
(defun cl--expr-contains-any (x y)
(while (and y (not (cl--expr-contains x (car y)))) (pop y))
@@ -176,9 +176,9 @@
"Generate a new uninterned symbol.
The name is made by appending a number to PREFIX, default \"G\"."
(let ((pfix (if (stringp prefix) prefix "G"))
- (num (if (integerp prefix) prefix
- (prog1 cl--gensym-counter
- (setq cl--gensym-counter (1+ cl--gensym-counter))))))
+ (num (if (integerp prefix) prefix
+ (prog1 cl--gensym-counter
+ (setq cl--gensym-counter (1+ cl--gensym-counter))))))
(make-symbol (format "%s%d" pfix num))))
;;;###autoload
@@ -186,7 +186,7 @@
"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"))
- name)
+ name)
(while (intern-soft (setq name (format "%s%d" pfix cl--gensym-counter)))
(setq cl--gensym-counter (1+ cl--gensym-counter)))
(intern name)))
@@ -205,9 +205,9 @@
[&optional ["&optional" cl-&optional-arg &rest cl-&optional-arg]]
[&optional ["&rest" arg]]
[&optional ["&key" [cl-&key-arg &rest cl-&key-arg]
- &optional "&allow-other-keys"]]
+ &optional "&allow-other-keys"]]
[&optional ["&aux" &rest
- &or (symbolp &optional def-form) symbolp]]
+ &or (symbolp &optional def-form) symbolp]]
)))
(def-edebug-spec cl-&optional-arg
@@ -231,42 +231,42 @@
function's body.
FORM is of the form (ARGS . BODY)."
(let* ((args (car form)) (body (cdr form)) (orig-args args)
- (cl--bind-block bind-block) (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))
+ (cl--bind-block bind-block) (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 cl-declare)))
+ (memq (car-safe (car body)) '(interactive declare cl-declare)))
(push (pop body) header))
(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 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)))
+ (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)))
+ (setq args (delq '&cl-quote args)))
(if (memq '&whole args) (error "&whole not currently implemented"))
(let* ((p (memq '&environment args)) (v (cadr p))
(env-exp 'macroexpand-all-environment))
(if p (setq args (nconc (delq (car p) (delq v args))
(list '&aux (list v env-exp))))))
(while (and args (symbolp (car args))
- (not (memq (car args) '(nil &rest &body &key &aux)))
- (not (and (eq (car args) '&optional)
- (or cl--bind-defs (consp (cadr args))))))
+ (not (memq (car args) '(nil &rest &body &key &aux)))
+ (not (and (eq (car args) '&optional)
+ (or cl--bind-defs (consp (cadr args))))))
(push (pop args) simple-args))
(or (eq cl--bind-block 'cl-none)
- (setq body (list `(cl-block ,cl--bind-block ,@body))))
+ (setq body (list `(cl-block ,cl--bind-block ,@body))))
(if (null args)
- (cl-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 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 cl--bind-lets))))
- (nconc (let ((hdr (nreverse header)))
+ (nconc (nreverse simple-args)
+ (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
;; touch the match-data.
@@ -280,7 +280,7 @@
(format "%S" (cons 'fn (cl--make-usage-args
orig-args)))))
hdr)))
- (list `(let* ,cl--bind-lets
+ (list `(let* ,cl--bind-lets
,@(nreverse cl--bind-forms)
,@body)))))))
@@ -301,7 +301,7 @@
(doc-string 3)
(indent 2))
(let* ((res (cl--transform-lambda (cons args body) name))
- (form `(defun ,name ,@(cdr res))))
+ (form `(defun ,name ,@(cdr res))))
(if (car res) `(progn ,(car res) ,form) form)))
;; The lambda list for macros is different from that of normal lambdas.
@@ -312,15 +312,15 @@
(([&optional "&environment" arg]
[&rest cl-macro-arg]
[&optional ["&optional" &rest
- &or (cl-macro-arg &optional def-form cl-macro-arg) arg]]
+ &or (cl-macro-arg &optional def-form cl-macro-arg) arg]]
[&optional [[&or "&rest" "&body"] cl-macro-arg]]
[&optional ["&key" [&rest
- [&or ([&or (symbolp cl-macro-arg) arg]
- &optional def-form cl-macro-arg)
- arg]]
- &optional "&allow-other-keys"]]
+ [&or ([&or (symbolp cl-macro-arg) arg]
+ &optional def-form cl-macro-arg)
+ arg]]
+ &optional "&allow-other-keys"]]
[&optional ["&aux" &rest
- &or (symbolp &optional def-form) symbolp]]
+ &or (symbolp &optional def-form) symbolp]]
[&optional "&environment" arg]
)))
@@ -331,15 +331,15 @@
(([&optional "&whole" arg] ;; only allowed at lower levels
[&rest cl-macro-arg]
[&optional ["&optional" &rest
- &or (cl-macro-arg &optional def-form cl-macro-arg) arg]]
+ &or (cl-macro-arg &optional def-form cl-macro-arg) arg]]
[&optional [[&or "&rest" "&body"] cl-macro-arg]]
[&optional ["&key" [&rest
- [&or ([&or (symbolp cl-macro-arg) arg]
- &optional def-form cl-macro-arg)
- arg]]
- &optional "&allow-other-keys"]]
+ [&or ([&or (symbolp cl-macro-arg) arg]
+ &optional def-form cl-macro-arg)
+ arg]]
+ &optional "&allow-other-keys"]]
[&optional ["&aux" &rest
- &or (symbolp &optional def-form) symbolp]]
+ &or (symbolp &optional def-form) symbolp]]
. [&or arg nil])))
;;;###autoload
@@ -354,14 +354,14 @@
(doc-string 3)
(indent 2))
(let* ((res (cl--transform-lambda (cons args body) name))
- (form `(defmacro ,name ,@(cdr res))))
+ (form `(defmacro ,name ,@(cdr res))))
(if (car res) `(progn ,(car res) ,form) form)))
(def-edebug-spec cl-lambda-expr
(&define ("lambda" cl-lambda-list
- ;;cl-declarations-or-string
- ;;[&optional ("interactive" interactive)]
- def-body)))
+ ;;cl-declarations-or-string
+ ;;[&optional ("interactive" interactive)]
+ def-body)))
;; Redefine function-form to also match cl-function
(def-edebug-spec function-form
@@ -379,8 +379,8 @@
(declare (debug (&or symbolp cl-lambda-expr)))
(if (eq (car-safe func) 'lambda)
(let* ((res (cl--transform-lambda (cdr func) 'cl-none))
- (form `(function (lambda . ,(cdr res)))))
- (if (car res) `(progn ,(car res) ,form) form))
+ (form `(function (lambda . ,(cdr res)))))
+ (if (car res) `(progn ,(car res) ,form) form))
`(function ,func)))
(declare-function help-add-fundoc-usage "help-fns" (docstring arglist))
@@ -432,63 +432,63 @@
(defun cl--do-arglist (args expr &optional num) ; uses bind-*
(if (nlistp args)
(if (or (memq args cl--lambda-list-keywords) (not (symbolp args)))
- (error "Invalid argument name: %s" args)
- (push (list args expr) cl--bind-lets))
+ (error "Invalid argument name: %s" 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"))
(let ((save-args args)
- (restarg (memq '&rest args))
- (safety (if (cl--compiling-file) cl--optimize-safety 3))
- (keys nil)
- (laterarg nil) (exactarg nil) minarg)
+ (restarg (memq '&rest args))
+ (safety (if (cl--compiling-file) cl--optimize-safety 3))
+ (keys nil)
+ (laterarg nil) (exactarg nil) minarg)
(or num (setq num 0))
(if (listp (cadr restarg))
- (setq restarg (make-symbol "--cl-rest--"))
- (setq restarg (cadr restarg)))
+ (setq restarg (make-symbol "--cl-rest--"))
+ (setq restarg (cadr restarg)))
(push (list restarg expr) cl--bind-lets)
(if (eq (car args) '&whole)
- (push (list (cl--pop2 args) restarg) cl--bind-lets))
+ (push (list (cl--pop2 args) restarg) cl--bind-lets))
(let ((p args))
- (setq minarg restarg)
- (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)
+ (setq minarg restarg)
+ (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 (cl-ldiff args p)))
- exactarg (not (eq args p)))))
+ exactarg (not (eq args p)))))
(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
- (pop args)
- (if (or laterarg (= safety 0)) poparg
- `(if ,minarg ,poparg
+ (let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car)
+ restarg)))
+ (cl--do-arglist
+ (pop args)
+ (if (or laterarg (= safety 0)) poparg
+ `(if ,minarg ,poparg
(signal 'wrong-number-of-arguments
(list ,(and (not (eq cl--bind-block 'cl-none))
`',cl--bind-block)
(length ,restarg)))))))
- (setq num (1+ num) laterarg t))
+ (setq num (1+ num) laterarg t))
(while (and (eq (car args) '&optional) (pop args))
- (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 cl--bind-defs)
- (nth 1 (assq (car arg) cl--bind-defs)))))
- (poparg `(pop ,restarg)))
- (and def cl--bind-enquote (setq def `',def))
- (cl--do-arglist (car arg)
- (if def `(if ,restarg ,poparg ,def) poparg))
- (setq num (1+ num))))))
+ (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 cl--bind-defs)
+ (nth 1 (assq (car arg) cl--bind-defs)))))
+ (poparg `(pop ,restarg)))
+ (and def cl--bind-enquote (setq def `',def))
+ (cl--do-arglist (car arg)
+ (if def `(if ,restarg ,poparg ,def) poparg))
+ (setq num (1+ num))))))
(if (eq (car args) '&rest)
- (let ((arg (cl--pop2 args)))
- (if (consp arg) (cl--do-arglist arg restarg)))
- (or (eq (car args) '&key) (= safety 0) exactarg
- (push `(if ,restarg
+ (let ((arg (cl--pop2 args)))
+ (if (consp arg) (cl--do-arglist arg restarg)))
+ (or (eq (car args) '&key) (= safety 0) exactarg
+ (push `(if ,restarg
(signal 'wrong-number-of-arguments
(list
,(and (not (eq cl--bind-block 'cl-none))
@@ -496,10 +496,10 @@
(+ ,num (length ,restarg)))))
cl--bind-forms)))
(while (and (eq (car args) '&key) (pop args))
- (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)
+ (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)
(let ((name (symbol-name (car arg))))
;; Strip a leading underscore, since it only
;; means that this argument is unused, but
@@ -507,35 +507,35 @@
(if (eq ?_ (aref name 0))
(setq name (substring name 1)))
(intern (format ":%s" name)))))
- (varg (if (consp (car arg)) (cl-cadar arg) (car arg)))
- (def (if (cdr arg) (cadr arg)
- (or (car cl--bind-defs) (cadr (assq varg
cl--bind-defs)))))
+ (varg (if (consp (car arg)) (cl-cadar arg) (car arg)))
+ (def (if (cdr arg) (cadr arg)
+ (or (car cl--bind-defs) (cadr (assq varg
cl--bind-defs)))))
(look `(plist-member ,restarg ',karg)))
- (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))))
- (cl--do-arglist temp look)
- (cl--do-arglist varg
- `(if ,temp
+ (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))))
+ (cl--do-arglist temp look)
+ (cl--do-arglist varg
+ `(if ,temp
(prog1 ,val (setq ,temp t))
,def)))
- (cl--do-arglist
- varg
- `(car (cdr ,(if (null def)
- look
- `(or ,look
+ (cl--do-arglist
+ varg
+ `(car (cdr ,(if (null def)
+ look
+ `(or ,look
,(if (eq (cl--const-expr-p def) t)
- `'(nil ,(cl--const-expr-val
+ `'(nil ,(cl--const-expr-val
def
macroexpand-all-environment))
- `(list nil ,def))))))))
- (push karg keys)))))
+ `(list nil ,def))))))))
+ (push karg keys)))))
(setq keys (nreverse keys))
(or (and (eq (car args) '&allow-other-keys) (pop args))
- (null keys) (= safety 0)
- (let* ((var (make-symbol "--cl-keys--"))
- (allow '(:allow-other-keys))
- (check `(while ,var
+ (null keys) (= safety 0)
+ (let* ((var (make-symbol "--cl-keys--"))
+ (allow '(:allow-other-keys))
+ (check `(while ,var
(cond
((memq (car ,var) ',(append keys allow))
(setq ,var (cdr (cdr ,var))))
@@ -546,27 +546,27 @@
,(format "Keyword argument %%s not one of %s"
keys)
(car ,var)))))))
- (push `(let ((,var ,restarg)) ,check) cl--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) cl--lambda-list-keywords)))
- (if (consp (car 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))))
- (cl--do-arglist (pop args) nil))))
+ (while (and args (not (memq (car args) cl--lambda-list-keywords)))
+ (if (consp (car 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))))
+ (cl--do-arglist (pop args) nil))))
(if args (error "Malformed argument list %s" save-args)))))
(defun cl--arglist-args (args)
(if (nlistp args) (list args)
(let ((res nil) (kind nil) arg)
(while (consp args)
- (setq arg (pop args))
- (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)))
- (setq res (nconc res (cl--arglist-args arg))))))
+ (setq arg (pop args))
+ (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)))
+ (setq res (nconc res (cl--arglist-args arg))))))
(nconc res (and args (list args))))))
;;;###autoload
@@ -575,10 +575,10 @@
(declare (indent 2)
(debug (&define cl-macro-list def-form cl-declarations def-body)))
(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--bind-defs nil) (cl--bind-block 'cl-none) (cl--bind-enquote nil))
(cl--do-arglist (or args '(&aux)) expr)
(append '(progn) cl--bind-inits
- (list `(let* ,(nreverse cl--bind-lets)
+ (list `(let* ,(nreverse cl--bind-lets)
,@(nreverse cl--bind-forms) ,@body)))))
@@ -596,28 +596,28 @@
\(fn (WHEN...) BODY...)"
(declare (indent 1) (debug (sexp body)))
(if (and (fboundp 'cl--compiling-file) (cl--compiling-file)
- (not cl--not-toplevel) (not (boundp 'for-effect))) ;Horrible kludge.
+ (not cl--not-toplevel) (not (boundp 'for-effect))) ;Horrible kludge.
(let ((comp (or (memq 'compile when) (memq :compile-toplevel when)))
- (cl--not-toplevel t))
- (if (or (memq 'load when) (memq :load-toplevel when))
- (if comp (cons 'progn (mapcar 'cl--compile-time-too body))
- `(if nil nil ,@body))
- (progn (if comp (eval (cons 'progn body))) nil)))
+ (cl--not-toplevel t))
+ (if (or (memq 'load when) (memq :load-toplevel when))
+ (if comp (cons 'progn (mapcar 'cl--compile-time-too body))
+ `(if nil nil ,@body))
+ (progn (if comp (eval (cons 'progn body))) nil)))
(and (or (memq 'eval when) (memq :execute when))
- (cons 'progn body))))
+ (cons 'progn body))))
(defun cl--compile-time-too (form)
(or (and (symbolp (car-safe form)) (get (car-safe form) 'byte-hunk-handler))
(setq form (macroexpand
- form (cons '(cl-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) 'cl-eval-when)
- (let ((when (nth 1 form)))
- (if (or (memq 'eval when) (memq :execute when))
- `(cl-eval-when (compile ,@when) ,@(cddr form))
- form)))
- (t (eval form) form)))
+ (cons 'progn (mapcar 'cl--compile-time-too (cdr form))))
+ ((eq (car-safe form) 'cl-eval-when)
+ (let ((when (nth 1 form)))
+ (if (or (memq 'eval when) (memq :execute when))
+ `(cl-eval-when (compile ,@when) ,@(cddr form))
+ form)))
+ (t (eval form) form)))
;;;###autoload
(defmacro cl-load-time-value (form &optional _read-only)
@@ -626,17 +626,17 @@
(declare (debug (form &optional sexp)))
(if (cl--compiling-file)
(let* ((temp (cl-gentemp "--cl-load-time--"))
- (set `(setq ,temp ,form)))
- (if (and (fboundp 'byte-compile-file-form-defmumble)
- (boundp 'this-kind) (boundp 'that-one))
- (fset 'byte-compile-file-form
- `(lambda (form)
+ (set `(setq ,temp ,form)))
+ (if (and (fboundp 'byte-compile-file-form-defmumble)
+ (boundp 'this-kind) (boundp 'that-one))
+ (fset 'byte-compile-file-form
+ `(lambda (form)
(fset 'byte-compile-file-form
',(symbol-function 'byte-compile-file-form))
(byte-compile-file-form ',set)
(byte-compile-file-form form)))
- (print set (symbol-value 'byte-compile--outbuffer)))
- `(symbol-value ',temp))
+ (print set (symbol-value 'byte-compile--outbuffer)))
+ `(symbol-value ',temp))
`',(eval form)))
@@ -654,27 +654,27 @@
\n(fn EXPR (KEYLIST BODY...)...)"
(declare (indent 1) (debug (form &rest (sexp body))))
(let* ((temp (if (cl--simple-expr-p expr 3) expr (make-symbol "--cl-var--")))
- (head-list nil)
- (body (cons
- 'cond
- (mapcar
- (function
- (lambda (c)
- (cons (cond ((memq (car c) '(t otherwise)) t)
- ((eq (car c) 'cl--ecase-error-flag)
- `(error "cl-ecase failed: %s, %s"
+ (head-list nil)
+ (body (cons
+ 'cond
+ (mapcar
+ (function
+ (lambda (c)
+ (cons (cond ((memq (car c) '(t otherwise)) t)
+ ((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))
- `(cl-member ,temp ',(car c)))
- (t
- (if (memq (car c) head-list)
- (error "Duplicate key in case: %s"
- (car c)))
- (push (car c) head-list)
- `(eql ,temp ',(car c))))
- (or (cdr c) '(nil)))))
- clauses))))
+ ((listp (car c))
+ (setq head-list (append (car c) head-list))
+ `(cl-member ,temp ',(car c)))
+ (t
+ (if (memq (car c) head-list)
+ (error "Duplicate key in case: %s"
+ (car c)))
+ (push (car c) head-list)
+ `(eql ,temp ',(car c))))
+ (or (cdr c) '(nil)))))
+ clauses))))
(if (eq temp expr) body
`(let ((,temp ,expr)) ,body))))
@@ -697,21 +697,21 @@
(declare (indent 1)
(debug (form &rest ([&or cl-type-spec "otherwise"] body))))
(let* ((temp (if (cl--simple-expr-p expr 3) expr (make-symbol "--cl-var--")))
- (type-list nil)
- (body (cons
- 'cond
- (mapcar
- (function
- (lambda (c)
- (cons (cond ((eq (car c) 'otherwise) t)
- ((eq (car c) 'cl--ecase-error-flag)
- `(error "cl-etypecase failed: %s, %s"
+ (type-list nil)
+ (body (cons
+ 'cond
+ (mapcar
+ (function
+ (lambda (c)
+ (cons (cond ((eq (car c) 'otherwise) t)
+ ((eq (car c) 'cl--ecase-error-flag)
+ `(error "cl-etypecase failed: %s, %s"
,temp ',(reverse type-list)))
- (t
- (push (car c) type-list)
- (cl--make-type-test temp (car c))))
- (or (cdr c) '(nil)))))
- clauses))))
+ (t
+ (push (car c) type-list)
+ (cl--make-type-test temp (car c))))
+ (or (cdr c) '(nil)))))
+ clauses))))
(if (eq temp expr) body
`(let ((,temp ,expr)) ,body))))
@@ -833,12 +833,12 @@
(delq nil (delq t (cl-copy-list loop-args))))))
`(cl-block nil (while t ,@loop-args))
(let ((cl--loop-args loop-args) (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-iterator-function nil) (cl--loop-first-flag 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-iterator-function nil) (cl--loop-first-flag nil)
(cl--loop-symbol-macs nil))
;; Here is more or less how those dynbind vars are used after looping
;; over cl--parse-loop-clause:
@@ -866,19 +866,19 @@
(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))
+ (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)))
+ (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
+ (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 cl--loop-initially)
- (list (if cl--loop-iterator-function
- `(cl-block --cl-finish--
+ (ands (cl--loop-build-ands (nreverse cl--loop-body)))
+ (while-body (nconc (cadr ands) (nreverse cl--loop-steps)))
+ (body (append
+ (nreverse cl--loop-initially)
+ (list (if cl--loop-iterator-function
+ `(cl-block --cl-finish--
,(funcall cl--loop-iterator-function
(if (eq (car ands) t) while-body
(cons `(or ,(car ands)
@@ -886,26 +886,26 @@
--cl-finish--
nil))
while-body))))
- `(while ,(car ands) ,@while-body)))
- (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 cl--loop-result-var
+ `(while ,(car ands) ,@while-body)))
+ (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 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 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 cl--loop-symbol-macs
- (setq body
+ (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 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 cl--loop-symbol-macs
+ (setq body
(list `(cl-symbol-macrolet ,cl--loop-symbol-macs ,@body))))
- `(cl-block ,cl--loop-name ,@body)))))
+ `(cl-block ,cl--loop-name ,@body)))))
;; 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
@@ -930,8 +930,8 @@
;; loop-type-spec
;; [&optional ["=" form]]
;; &rest ["and" loop-var
-;; loop-type-spec
-;; [&optional ["=" form]]]))
+;; loop-type-spec
+;; [&optional ["=" form]]]))
;; (def-edebug-spec loop-for-as
;; ([&or "for" "as"] loop-for-as-subclause
@@ -953,25 +953,25 @@
;; [&or "of" "in" "of-ref"] form
;; &optional "using" ["index" symbolp]];; is this right?
;; [[&or "hash-key" "hash-keys"
-;; "hash-value" "hash-values"]
+;; "hash-value" "hash-values"]
;; [&or "of" "in"]
;; hash-table-p &optional ["using" ([&or "hash-value" "hash-values"
-;; "hash-key" "hash-keys"] sexp)]]
+;; "hash-key" "hash-keys"] sexp)]]
;; [[&or "symbol" "present-symbol" "external-symbol"
-;; "symbols" "present-symbols" "external-symbols"]
+;; "symbols" "present-symbols" "external-symbols"]
;; [&or "in" "of"] package-p]
;; ;; Extensions for Emacs Lisp, including Lucid Emacs.
;; [[&or "frame" "frames"
-;; "screen" "screens"
-;; "buffer" "buffers"]]
+;; "screen" "screens"
+;; "buffer" "buffers"]]
;; [[&or "window" "windows"]
;; [&or "of" "in"] form]
;; [[&or "overlay" "overlays"
-;; "extent" "extents"]
+;; "extent" "extents"]
;; [&or "of" "in"] form
;; &optional [[&or "from" "to"] form]]
@@ -981,13 +981,13 @@
;; ["property" form]]
;; [[&or "key-code" "key-codes"
-;; "key-seq" "key-seqs"
-;; "key-binding" "key-bindings"]
+;; "key-seq" "key-seqs"
+;; "key-binding" "key-bindings"]
;; [&or "in" "of"] form
;; &optional ["using" ([&or "key-code" "key-codes"
-;; "key-seq" "key-seqs"
-;; "key-binding" "key-bindings"]
-;; sexp)]]
+;; "key-seq" "key-seqs"
+;; "key-binding" "key-bindings"]
+;; sexp)]]
;; ;; For arbitrary extensions, recognize anything else.
;; [symbolp &rest &or symbolp form]
;; ]
@@ -1000,11 +1000,11 @@
;; (def-edebug-spec loop-initial-final
;; (&or ["initially"
-;; ;; [&optional &or "do" "doing"] ;; CLtL2 doesn't allow this.
-;; &rest loop-non-atomic-expr]
+;; ;; [&optional &or "do" "doing"] ;; CLtL2 doesn't allow this.
+;; &rest loop-non-atomic-expr]
;; ["finally" &or
-;; [[&optional &or "do" "doing"] &rest loop-non-atomic-expr]
-;; ["return" form]]))
+;; [[&optional &or "do" "doing"] &rest loop-non-atomic-expr]
+;; ["return" form]]))
;; (def-edebug-spec loop-and-clause
;; (loop-clause &rest ["and" loop-clause]))
@@ -1014,17 +1014,17 @@
;; [[&or "while" "until" "always" "never" "thereis"] form]
;; [[&or "collect" "collecting"
-;; "append" "appending"
-;; "nconc" "nconcing"
-;; "concat" "vconcat"] form
-;; [&optional ["into" loop-var]]]
+;; "append" "appending"
+;; "nconc" "nconcing"
+;; "concat" "vconcat"] form
+;; [&optional ["into" loop-var]]]
;; [[&or "count" "counting"
-;; "sum" "summing"
-;; "maximize" "maximizing"
-;; "minimize" "minimizing"] form
-;; [&optional ["into" loop-var]]
-;; loop-type-spec]
+;; "sum" "summing"
+;; "maximize" "maximizing"
+;; "minimize" "minimizing"] form
+;; [&optional ["into" loop-var]]
+;; loop-type-spec]
;; [[&or "if" "when" "unless"]
;; form loop-and-clause
@@ -1059,11 +1059,11 @@
-(defun cl--parse-loop-clause () ; uses loop-*
+(defun cl--parse-loop-clause () ; uses loop-*
(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)))
+ (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 cl--loop-args)
@@ -1077,174 +1077,174 @@
(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)))
+ (push (pop cl--loop-args) cl--loop-initially)))
((eq word 'finally)
(if (eq (car cl--loop-args) 'return)
- (setq cl--loop-result-explicit
+ (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))
+ (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
+ (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)))))
+ (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 `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 macro-environment.
- (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
+ (ands nil))
+ (while
+ ;; 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 macro-environment.
+ (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
cl--loop-args (cons '(buffer-list) cl--loop-args)))
- (cond
+ (cond
- ((memq word '(from downfrom upfrom to downto upto
- above below by))
- (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)
+ ((memq word '(from downfrom upfrom to downto upto
+ above below by))
+ (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)
+ (excl (or (memq (car cl--loop-args) '(above below))
+ (memq (cl-caddr cl--loop-args)
'(above below))))
- (start (and (memq (car cl--loop-args)
+ (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 cl--loop-args)))
- (step (and (eq (car cl--loop-args) 'by)
+ (cl--pop2 cl--loop-args)))
+ (end (and (memq (car cl--loop-args)
+ '(to upto downto above below))
+ (cl--pop2 cl--loop-args)))
+ (step (and (eq (car cl--loop-args) 'by)
(cl--pop2 cl--loop-args)))
- (end-var (and (not (macroexp-const-p end))
- (make-symbol "--cl-var--")))
- (step-var (and (not (macroexp-const-p step))
- (make-symbol "--cl-var--"))))
- (and step (numberp step) (<= step 0)
- (error "Loop `by' value is not positive: %s" step))
- (push (list var (or start 0)) loop-for-bindings)
- (if end-var (push (list end-var end) loop-for-bindings))
- (if step-var (push (list step-var step)
- loop-for-bindings))
- (if end
- (push (list
- (if down (if excl '> '>=) (if excl '< '<=))
- var (or end-var end)) cl--loop-body))
- (push (list var (list (if down '- '+) var
- (or step-var step 1)))
- loop-for-steps)))
-
- ((memq word '(in in-ref on))
- (let* ((on (eq word 'on))
- (temp (if (and on (symbolp var))
- var (make-symbol "--cl-var--"))))
- (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)) 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 cl--loop-args) 'by)
- (let ((step (cl--pop2 cl--loop-args)))
- (if (and (memq (car-safe step)
- '(quote function
- cl-function))
- (symbolp (nth 1 step)))
- (list (nth 1 step) temp)
- `(funcall ,step ,temp)))
- `(cdr ,temp)))
- loop-for-steps)))
-
- ((eq word '=)
- (let* ((start (pop cl--loop-args))
- (then (if (eq (car cl--loop-args) 'then)
+ (end-var (and (not (macroexp-const-p end))
+ (make-symbol "--cl-var--")))
+ (step-var (and (not (macroexp-const-p step))
+ (make-symbol "--cl-var--"))))
+ (and step (numberp step) (<= step 0)
+ (error "Loop `by' value is not positive: %s" step))
+ (push (list var (or start 0)) loop-for-bindings)
+ (if end-var (push (list end-var end) loop-for-bindings))
+ (if step-var (push (list step-var step)
+ loop-for-bindings))
+ (if end
+ (push (list
+ (if down (if excl '> '>=) (if excl '< '<=))
+ var (or end-var end)) cl--loop-body))
+ (push (list var (list (if down '- '+) var
+ (or step-var step 1)))
+ loop-for-steps)))
+
+ ((memq word '(in in-ref on))
+ (let* ((on (eq word 'on))
+ (temp (if (and on (symbolp var))
+ var (make-symbol "--cl-var--"))))
+ (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)) 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 cl--loop-args) 'by)
+ (let ((step (cl--pop2 cl--loop-args)))
+ (if (and (memq (car-safe step)
+ '(quote function
+ cl-function))
+ (symbolp (nth 1 step)))
+ (list (nth 1 step) temp)
+ `(funcall ,step ,temp)))
+ `(cdr ,temp)))
+ loop-for-steps)))
+
+ ((eq word '=)
+ (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 cl--loop-args) 'and))
- (progn
- (push `(,var
- (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 cl--loop-first-flag
- (setq cl--loop-first-flag
- (make-symbol "--cl-var--")))
- ,start ,then)))
- loop-for-sets))))
+ (push (list var nil) loop-for-bindings)
+ (if (or ands (eq (car cl--loop-args) 'and))
+ (progn
+ (push `(,var
+ (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 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 cl--loop-args)) loop-for-bindings)
- (push (list temp-idx -1) loop-for-bindings)
- (push `(< (setq ,temp-idx (1+ ,temp-idx))
+ ((memq word '(across across-ref))
+ (let ((temp-vec (make-symbol "--cl-vec--"))
+ (temp-idx (make-symbol "--cl-idx--")))
+ (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)) cl--loop-body)
- (if (eq word 'across-ref)
- (push (list var `(aref ,temp-vec ,temp-idx))
- cl--loop-symbol-macs)
- (push (list var nil) loop-for-bindings)
- (push (list var `(aref ,temp-vec ,temp-idx))
- loop-for-sets))))
+ (if (eq word 'across-ref)
+ (push (list var `(aref ,temp-vec ,temp-idx))
+ 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 cl--loop-args) '(in-ref of-ref))
- (and (not (memq (car cl--loop-args) '(in of)))
- (error "Expected `of'"))))
- (seq (cl--pop2 cl--loop-args))
- (temp-seq (make-symbol "--cl-seq--"))
- (temp-idx
+ ((memq word '(element elements))
+ (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 cl--loop-args))
+ (temp-seq (make-symbol "--cl-seq--"))
+ (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-idx 0) loop-for-bindings)
- (if ref
- (let ((temp-len (make-symbol "--cl-len--")))
- (push (list temp-len `(length ,temp-seq))
- loop-for-bindings)
- (push (list var `(elt ,temp-seq ,temp-idx))
- 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)
+ (push (list temp-seq seq) loop-for-bindings)
+ (push (list temp-idx 0) loop-for-bindings)
+ (if ref
+ (let ((temp-len (make-symbol "--cl-len--")))
+ (push (list temp-len `(length ,temp-seq))
+ loop-for-bindings)
+ (push (list var `(elt ,temp-seq ,temp-idx))
+ 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))))
- cl--loop-body)
- (push (list var `(if (consp ,temp-seq)
+ cl--loop-body)
+ (push (list var `(if (consp ,temp-seq)
(pop ,temp-seq)
(aref ,temp-seq ,temp-idx)))
- loop-for-sets))
- (push (list temp-idx `(1+ ,temp-idx))
- loop-for-steps)))
+ loop-for-sets))
+ (push (list temp-idx `(1+ ,temp-idx))
+ loop-for-steps)))
- ((memq word hash-types)
- (or (memq (car cl--loop-args) '(in of))
+ ((memq word hash-types)
+ (or (memq (car cl--loop-args) '(in of))
(error "Expected `of'"))
- (let* ((table (cl--pop2 cl--loop-args))
- (other
+ (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)
@@ -1252,62 +1252,62 @@
(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))))
- (cl--loop-set-iterator-function
+ (if (memq word '(hash-value hash-values))
+ (setq var (prog1 other (setq other var))))
+ (cl--loop-set-iterator-function
'hash-tables (lambda (body)
`(maphash (lambda (,var ,other) . ,body)
,table)))))
- ((memq word '(symbol present-symbol external-symbol
- symbols present-symbols external-symbols))
- (let ((ob (and (memq (car cl--loop-args) '(in of))
+ ((memq word '(symbol present-symbol external-symbol
+ symbols present-symbols external-symbols))
+ (let ((ob (and (memq (car cl--loop-args) '(in of))
(cl--pop2 cl--loop-args))))
- (cl--loop-set-iterator-function
+ (cl--loop-set-iterator-function
'symbols (lambda (body)
`(mapatoms (lambda (,var) . ,body) ,ob)))))
- ((memq word '(overlay overlays extent extents))
- (let ((buf nil) (from nil) (to nil))
- (while (memq (car cl--loop-args) '(in of from to))
- (cond ((eq (car cl--loop-args) 'from)
+ ((memq word '(overlay overlays extent extents))
+ (let ((buf nil) (from nil) (to nil))
+ (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)
+ ((eq (car cl--loop-args) 'to)
(setq to (cl--pop2 cl--loop-args)))
- (t (setq buf (cl--pop2 cl--loop-args)))))
- (cl--loop-set-iterator-function
+ (t (setq buf (cl--pop2 cl--loop-args)))))
+ (cl--loop-set-iterator-function
'overlays (lambda (body)
`(cl--map-overlays
(lambda (,var ,(make-symbol "--cl-var--"))
(progn . ,body) nil)
,buf ,from ,to)))))
- ((memq word '(interval intervals))
- (let ((buf nil) (prop nil) (from nil) (to nil)
- (var1 (make-symbol "--cl-var1--"))
- (var2 (make-symbol "--cl-var2--")))
- (while (memq (car cl--loop-args) '(in of property from to))
- (cond ((eq (car cl--loop-args) 'from)
+ ((memq word '(interval intervals))
+ (let ((buf nil) (prop nil) (from nil) (to nil)
+ (var1 (make-symbol "--cl-var1--"))
+ (var2 (make-symbol "--cl-var2--")))
+ (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)
+ ((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))
- (cl--loop-set-iterator-function
+ ((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))
+ (cl--loop-set-iterator-function
'intervals (lambda (body)
`(cl--map-intervals
(lambda (,var1 ,var2) . ,body)
,buf ,prop ,from ,to)))))
- ((memq word key-types)
- (or (memq (car cl--loop-args) '(in of))
+ ((memq word key-types)
+ (or (memq (car cl--loop-args) '(in of))
(error "Expected `of'"))
- (let ((cl-map (cl--pop2 cl--loop-args))
- (other
+ (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)
@@ -1315,89 +1315,89 @@
(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))))
- (cl--loop-set-iterator-function
+ (if (memq word '(key-binding key-bindings))
+ (setq var (prog1 other (setq other var))))
+ (cl--loop-set-iterator-function
'keys (lambda (body)
`(,(if (memq word '(key-seq key-seqs))
'cl--map-keymap-recursively 'map-keymap)
(lambda (,var ,other) . ,body) ,cl-map)))))
- ((memq word '(frame frames screen screens))
- (let ((temp (make-symbol "--cl-var--")))
- (push (list var '(selected-frame))
- loop-for-bindings)
- (push (list temp nil) loop-for-bindings)
- (push `(prog1 (not (eq ,var ,temp))
+ ((memq word '(frame frames screen screens))
+ (let ((temp (make-symbol "--cl-var--")))
+ (push (list var '(selected-frame))
+ loop-for-bindings)
+ (push (list temp nil) loop-for-bindings)
+ (push `(prog1 (not (eq ,var ,temp))
(or ,temp (setq ,temp ,var)))
- cl--loop-body)
- (push (list var `(next-frame ,var))
- loop-for-steps)))
+ cl--loop-body)
+ (push (list var `(next-frame ,var))
+ loop-for-steps)))
- ((memq word '(window windows))
- (let ((scr (and (memq (car cl--loop-args) '(in of))
+ ((memq word '(window windows))
+ (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
- `(frame-selected-window ,scr)
- '(selected-window)))
- loop-for-bindings)
- ;; 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 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))
+ (temp (make-symbol "--cl-var--"))
+ (minip (make-symbol "--cl-minip--")))
+ (push (list var (if scr
+ `(frame-selected-window ,scr)
+ '(selected-window)))
+ loop-for-bindings)
+ ;; 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 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)))
- cl--loop-body)
- (push (list var `(next-window ,var ,minip))
- loop-for-steps)))
+ cl--loop-body)
+ (push (list var `(next-window ,var ,minip))
+ loop-for-steps)))
- (t
- ;; This is an advertised interface: (info "(cl)Other Clauses").
- (let ((handler (and (symbolp word)
- (get word 'cl-loop-for-handler))))
- (if handler
- (funcall handler var)
- (error "Expected a `for' preposition, found %s" word)))))
- (eq (car cl--loop-args) 'and))
- (setq ands t)
- (pop cl--loop-args))
- (if (and ands loop-for-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
+ (t
+ ;; This is an advertised interface: (info "(cl)Other Clauses").
+ (let ((handler (and (symbolp word)
+ (get word 'cl-loop-for-handler))))
+ (if handler
+ (funcall handler var)
+ (error "Expected a `for' preposition, found %s" word)))))
+ (eq (car cl--loop-args) 'and))
+ (setq ands t)
+ (pop cl--loop-args))
+ (if (and ands loop-for-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) cl--loop-body))
- (if loop-for-steps
- (push (cons (if ands 'cl-psetq 'setq)
- (apply 'append (nreverse loop-for-steps)))
- cl--loop-steps))))
+ (if loop-for-steps
+ (push (cons (if ands 'cl-psetq 'setq)
+ (apply 'append (nreverse loop-for-steps)))
+ cl--loop-steps))))
((eq word 'repeat)
(let ((temp (make-symbol "--cl-var--")))
- (push (list (list temp (pop cl--loop-args))) cl--loop-bindings)
- (push `(>= (setq ,temp (1- ,temp)) 0) cl--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 cl--loop-args))
- (var (cl--loop-handle-accum nil 'nreverse)))
- (if (eq var cl--loop-accum-var)
- (push `(progn (push ,what ,var) t) cl--loop-body)
- (push `(progn
+ (var (cl--loop-handle-accum nil 'nreverse)))
+ (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) cl--loop-body))))
((memq word '(nconc nconcing append appending))
(let ((what (pop cl--loop-args))
- (var (cl--loop-handle-accum nil 'nreverse)))
- (push `(progn
+ (var (cl--loop-handle-accum nil 'nreverse)))
+ (push `(progn
(setq ,var
,(if (eq var cl--loop-accum-var)
`(nconc
@@ -1411,44 +1411,44 @@
((memq word '(concat concating))
(let ((what (pop cl--loop-args))
- (var (cl--loop-handle-accum "")))
- (push `(progn (cl-callf concat ,var ,what) t) cl--loop-body)))
+ (var (cl--loop-handle-accum "")))
+ (push `(progn (cl-callf concat ,var ,what) t) cl--loop-body)))
((memq word '(vconcat vconcating))
(let ((what (pop cl--loop-args))
- (var (cl--loop-handle-accum [])))
- (push `(progn (cl-callf vconcat ,var ,what) t) cl--loop-body)))
+ (var (cl--loop-handle-accum [])))
+ (push `(progn (cl-callf vconcat ,var ,what) t) cl--loop-body)))
((memq word '(sum summing))
(let ((what (pop cl--loop-args))
- (var (cl--loop-handle-accum 0)))
- (push `(progn (cl-incf ,var ,what) t) cl--loop-body)))
+ (var (cl--loop-handle-accum 0)))
+ (push `(progn (cl-incf ,var ,what) t) cl--loop-body)))
((memq word '(count counting))
(let ((what (pop cl--loop-args))
- (var (cl--loop-handle-accum 0)))
- (push `(progn (if ,what (cl-incf ,var)) t) cl--loop-body)))
+ (var (cl--loop-handle-accum 0)))
+ (push `(progn (if ,what (cl-incf ,var)) t) cl--loop-body)))
((memq word '(minimize minimizing maximize maximizing))
(let* ((what (pop cl--loop-args))
- (temp (if (cl--simple-expr-p what) what
+ (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
+ (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) cl--loop-body)))
((eq word 'with)
(let ((bindings nil))
- (while (progn (push (list (pop cl--loop-args)
- (and (eq (car cl--loop-args) '=)
+ (while (progn (push (list (pop cl--loop-args)
+ (and (eq (car cl--loop-args) '=)
(cl--pop2 cl--loop-args)))
- bindings)
- (eq (car cl--loop-args) 'and))
- (pop cl--loop-args))
- (push (nreverse bindings) cl--loop-bindings)))
+ bindings)
+ (eq (car cl--loop-args) 'and))
+ (pop cl--loop-args))
+ (push (nreverse bindings) cl--loop-bindings)))
((eq word 'while)
(push (pop cl--loop-args) cl--loop-body))
@@ -1466,7 +1466,7 @@
(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)
+ cl--loop-body)
(setq cl--loop-result t))
((eq word 'thereis)
@@ -1476,32 +1476,32 @@
(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))
+ cl--loop-body))
((memq word '(if when unless))
(let* ((cond (pop cl--loop-args))
- (then (let ((cl--loop-body nil))
- (cl--parse-loop-clause)
- (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 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))))))
- (setq form (if (cl--expr-contains form 'it)
+ (then (let ((cl--loop-body nil))
+ (cl--parse-loop-clause)
+ (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 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))))))
+ (setq form (if (cl--expr-contains form 'it)
`(let ((it ,cond)) (if it ,@form))
`(if ,cond ,@form)))
- (push (if simple `(progn ,form t) form) cl--loop-body))))
+ (push (if simple `(progn ,form t) form) cl--loop-body))))
((memq word '(do doing))
(let ((body nil))
- (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)))
+ (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 cl--loop-finish-flag
@@ -1514,10 +1514,10 @@
(t
;; This is an advertised interface: (info "(cl)Other Clauses").
(let ((handler (and (symbolp word) (get word 'cl-loop-handler))))
- (or handler (error "Expected a cl-loop keyword, found %s" word))
- (funcall handler))))
+ (or handler (error "Expected a cl-loop keyword, found %s" word))
+ (funcall handler))))
(if (eq (car cl--loop-args) 'and)
- (progn (pop cl--loop-args) (cl--parse-loop-clause)))))
+ (progn (pop cl--loop-args) (cl--parse-loop-clause)))))
(defun cl--unused-var-p (sym)
(or (null sym) (eq ?_ (aref (symbol-name sym) 0))))
@@ -1549,7 +1549,7 @@
(temp (last spec 0)))
(if (and (cl--unused-var-p temp) (null expr))
nil ;; Don't bother declaring/setting `temp' since it won't
- ;; be used when `expr' is nil, anyway.
+ ;; be used when `expr' is nil, anyway.
(when (and (eq body 'setq) (cl--unused-var-p temp))
;; Prefer a fresh uninterned symbol over "_to", to avoid
;; warnings that we set an unused variable.
@@ -1564,28 +1564,28 @@
(setq specs (nconc (nreverse nspecs) specs)))
(push binding new))))
(if (eq body 'setq)
- (let ((set (cons (if par 'cl-psetq 'setq)
+ (let ((set (cons (if par 'cl-psetq 'setq)
(apply 'nconc (nreverse new)))))
- (if temps `(let* ,(nreverse temps) ,set) set))
+ (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 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 (memq var cl--loop-accum-vars)
+ (progn (push (list (list var def)) cl--loop-bindings)
+ (push var cl--loop-accum-vars)))
+ var)
(or cl--loop-accum-var
- (progn
- (push (list (list
+ (progn
+ (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)
+ (setq cl--loop-result (if func (list func cl--loop-accum-var)
cl--loop-accum-var))
- cl--loop-accum-var))))
+ cl--loop-accum-var))))
(defun cl--loop-build-ands (clauses)
"Return various representations of (and . CLAUSES).
@@ -1594,29 +1594,29 @@
The return value has shape (COND BODY COMBO)
such that COMBO is equivalent to (and . CLAUSES)."
(let ((ands nil)
- (body nil))
+ (body nil))
;; Look through `clauses', trying to optimize (progn ,@A t) (progn ,@B) ,@C
;; into (progn ,@A ,@B) ,@C.
(while clauses
(if (and (eq (car-safe (car clauses)) 'progn)
- (eq (car (last (car clauses))) t))
- (if (cdr clauses)
- (setq clauses (cons (nconc (butlast (car clauses))
- (if (eq (car-safe (cadr clauses))
- 'progn)
- (cl-cdadr clauses)
- (list (cadr clauses))))
- (cddr clauses)))
+ (eq (car (last (car clauses))) t))
+ (if (cdr clauses)
+ (setq clauses (cons (nconc (butlast (car clauses))
+ (if (eq (car-safe (cadr clauses))
+ 'progn)
+ (cl-cdadr clauses)
+ (list (cadr clauses))))
+ (cddr clauses)))
;; A final (progn ,@A t) is moved outside of the `and'.
- (setq body (cdr (butlast (pop clauses)))))
- (push (pop clauses) ands)))
+ (setq body (cdr (butlast (pop clauses)))))
+ (push (pop clauses) ands)))
(setq ands (or (nreverse ands) (list t)))
(list (if (cdr ands) (cons 'and ands) (car ands))
- body
- (let ((full (if body
- (append ands (list (cons 'progn (append body '(t)))))
- ands)))
- (if (cdr full) (cons 'and full) (car full))))))
+ body
+ (let ((full (if body
+ (append ands (list (cons 'progn (append body '(t)))))
+ ands)))
+ (if (cdr full) (cons 'and full) (car full))))))
;;; Other iteration control structures.
@@ -1823,8 +1823,8 @@
(let ((binds ()) (newenv macroexpand-all-environment))
(dolist (binding bindings)
(let ((var (make-symbol (format "--cl-%s--" (car binding)))))
- (push (list var `(cl-function (lambda . ,(cdr binding)))) binds)
- (push (cons (car binding)
+ (push (list var `(cl-function (lambda . ,(cdr binding)))) binds)
+ (push (cons (car binding)
`(lambda (&rest cl-labels-args)
(cl-list* 'funcall ',var
cl-labels-args)))
@@ -1860,8 +1860,8 @@
(let ((binds ()) (newenv macroexpand-all-environment))
(dolist (binding bindings)
(let ((var (make-symbol (format "--cl-%s--" (car binding)))))
- (push (list var `(cl-function (lambda . ,(cdr binding)))) binds)
- (push (cons (car binding)
+ (push (list var `(cl-function (lambda . ,(cdr binding)))) binds)
+ (push (cons (car binding)
`(lambda (&rest cl-labels-args)
(cl-list* 'funcall ',var
cl-labels-args)))
@@ -1888,9 +1888,9 @@
`(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))
- (macroexpand-all (cons 'progn body)
+ (res (cl--transform-lambda (cdar bindings) name)))
+ (eval (car res))
+ (macroexpand-all (cons 'progn body)
(cons (cons name `(lambda ,@(cdr res)))
macroexpand-all-environment))))))
@@ -2045,10 +2045,10 @@
\(fn (SYM...) FORM)"
(declare (indent 1) (debug ((&rest symbolp) form)))
(cond ((null vars) `(progn ,form nil))
- ((null (cdr vars)) `(setq ,(car vars) (car ,form)))
- (t
- (let* ((temp (make-symbol "--cl-var--")) (n 0))
- `(let ((,temp ,form))
+ ((null (cdr vars)) `(setq ,(car vars) (car ,form)))
+ (t
+ (let* ((temp (make-symbol "--cl-var--")) (n 0))
+ `(let ((,temp ,form))
(prog1 (setq ,(pop vars) (car ,temp))
(setq ,@(apply #'nconc
(mapcar (lambda (v)
@@ -2087,38 +2087,38 @@
(defun cl--do-proclaim (spec hist)
(and hist (listp cl--proclaim-history) (push spec cl--proclaim-history))
(cond ((eq (car-safe spec) 'special)
- (if (boundp 'byte-compile-bound-variables)
- (setq byte-compile-bound-variables
- (append (cdr spec) byte-compile-bound-variables))))
-
- ((eq (car-safe spec) 'inline)
- (while (setq spec (cdr spec))
- (or (memq (get (car spec) 'byte-optimizer)
- '(nil byte-compile-inline-expand))
- (error "%s already has a byte-optimizer, can't make it inline"
- (car spec)))
- (put (car spec) 'byte-optimizer 'byte-compile-inline-expand)))
-
- ((eq (car-safe spec) 'notinline)
- (while (setq spec (cdr spec))
- (if (eq (get (car spec) 'byte-optimizer)
- 'byte-compile-inline-expand)
- (put (car spec) 'byte-optimizer nil))))
-
- ((eq (car-safe spec) 'optimize)
- (let ((speed (assq (nth 1 (assq 'speed (cdr spec)))
- '((0 nil) (1 t) (2 t) (3 t))))
- (safety (assq (nth 1 (assq 'safety (cdr spec)))
- '((0 t) (1 t) (2 t) (3 nil)))))
- (if speed (setq cl--optimize-speed (car speed)
- byte-optimize (nth 1 speed)))
- (if safety (setq cl--optimize-safety (car safety)
- byte-compile-delete-errors (nth 1 safety)))))
-
- ((and (eq (car-safe spec) 'warn) (boundp 'byte-compile-warnings))
- (while (setq spec (cdr spec))
- (if (consp (car spec))
- (if (eq (cl-cadar spec) 0)
+ (if (boundp 'byte-compile-bound-variables)
+ (setq byte-compile-bound-variables
+ (append (cdr spec) byte-compile-bound-variables))))
+
+ ((eq (car-safe spec) 'inline)
+ (while (setq spec (cdr spec))
+ (or (memq (get (car spec) 'byte-optimizer)
+ '(nil byte-compile-inline-expand))
+ (error "%s already has a byte-optimizer, can't make it inline"
+ (car spec)))
+ (put (car spec) 'byte-optimizer 'byte-compile-inline-expand)))
+
+ ((eq (car-safe spec) 'notinline)
+ (while (setq spec (cdr spec))
+ (if (eq (get (car spec) 'byte-optimizer)
+ 'byte-compile-inline-expand)
+ (put (car spec) 'byte-optimizer nil))))
+
+ ((eq (car-safe spec) 'optimize)
+ (let ((speed (assq (nth 1 (assq 'speed (cdr spec)))
+ '((0 nil) (1 t) (2 t) (3 t))))
+ (safety (assq (nth 1 (assq 'safety (cdr spec)))
+ '((0 t) (1 t) (2 t) (3 nil)))))
+ (if speed (setq cl--optimize-speed (car speed)
+ byte-optimize (nth 1 speed)))
+ (if safety (setq cl--optimize-safety (car safety)
+ byte-compile-delete-errors (nth 1 safety)))))
+
+ ((and (eq (car-safe spec) 'warn) (boundp 'byte-compile-warnings))
+ (while (setq spec (cdr spec))
+ (if (consp (car spec))
+ (if (eq (cl-cadar spec) 0)
(byte-compile-disable-warning (caar spec))
(byte-compile-enable-warning (caar spec)))))))
nil)
@@ -2140,8 +2140,8 @@
See Info node `(cl)Declarations' for details."
(if (cl--compiling-file)
(while specs
- (if (listp cl--declare-stack) (push (car specs) cl--declare-stack))
- (cl--do-proclaim (pop specs) nil)))
+ (if (listp cl--declare-stack) (push (car specs) cl--declare-stack))
+ (cl--do-proclaim (pop specs) nil)))
nil)
;;; The standard modify macros.
@@ -2159,19 +2159,19 @@
(let ((p args) (simple t) (vars nil))
(while p
(if (or (not (symbolp (car p))) (cl--expr-depends-p (nth 1 p) vars))
- (setq simple nil))
+ (setq simple nil))
(if (memq (car p) vars)
- (error "Destination duplicated in psetf: %s" (car p)))
+ (error "Destination duplicated in psetf: %s" (car p)))
(push (pop p) vars)
(or p (error "Odd number of arguments to cl-psetf"))
(pop p))
(if simple
- `(progn (setq ,@args) nil)
+ `(progn (setq ,@args) nil)
(setq args (reverse args))
(let ((expr `(setf ,(cadr args) ,(car args))))
- (while (setq args (cddr args))
- (setq expr `(setf ,(cadr args) (prog1 ,(car args) ,expr))))
- `(progn ,expr nil)))))
+ (while (setq args (cddr args))
+ (setq expr `(setf ,(cadr args) (prog1 ,(car args) ,expr))))
+ `(progn ,expr nil)))))
;;;###autoload
(defmacro cl-remf (place tag)
@@ -2212,20 +2212,20 @@
(declare (debug (&rest place)))
(if (not (memq nil (mapcar 'symbolp args)))
(and (cdr args)
- (let ((sets nil)
- (first (car args)))
- (while (cdr args)
- (setq sets (nconc sets (list (pop args) (car args)))))
- `(cl-psetf ,@sets ,(car args) ,first)))
+ (let ((sets nil)
+ (first (car args)))
+ (while (cdr args)
+ (setq sets (nconc sets (list (pop args) (car args)))))
+ `(cl-psetf ,@sets ,(car args) ,first)))
(let* ((places (reverse args))
- (temp (make-symbol "--cl-rotatef--"))
- (form temp))
+ (temp (make-symbol "--cl-rotatef--"))
+ (form temp))
(while (cdr places)
(setq form
(gv-letplace (getter setter) (pop places)
`(prog1 ,getter ,(funcall setter form)))))
(gv-letplace (getter setter) (car places)
- (macroexp-let* `((,temp ,getter))
+ (macroexp-let* `((,temp ,getter))
`(progn ,(funcall setter form) nil))))))
;; FIXME: `letf' is unsatisfactory because it does not really "restore" the
@@ -2379,145 +2379,145 @@
&rest &or symbolp (symbolp def-form
&optional ":read-only" sexp))))
(let* ((name (if (consp struct) (car struct) struct))
- (opts (cdr-safe struct))
- (slots nil)
- (defaults nil)
- (conc-name (concat (symbol-name name) "-"))
- (constructor (intern (format "make-%s" name)))
- (constrs nil)
- (copier (intern (format "copy-%s" name)))
- (predicate (intern (format "%s-p" name)))
- (print-func nil) (print-auto nil)
- (safety (if (cl--compiling-file) cl--optimize-safety 3))
- (include nil)
- (tag (intern (format "cl-struct-%s" name)))
- (tag-symbol (intern (format "cl-struct-%s-tags" name)))
- (include-descs nil)
- (side-eff nil)
- (type nil)
- (named nil)
- (forms nil)
- pred-form pred-check)
+ (opts (cdr-safe struct))
+ (slots nil)
+ (defaults nil)
+ (conc-name (concat (symbol-name name) "-"))
+ (constructor (intern (format "make-%s" name)))
+ (constrs nil)
+ (copier (intern (format "copy-%s" name)))
+ (predicate (intern (format "%s-p" name)))
+ (print-func nil) (print-auto nil)
+ (safety (if (cl--compiling-file) cl--optimize-safety 3))
+ (include nil)
+ (tag (intern (format "cl-struct-%s" name)))
+ (tag-symbol (intern (format "cl-struct-%s-tags" name)))
+ (include-descs nil)
+ (side-eff nil)
+ (type nil)
+ (named nil)
+ (forms nil)
+ pred-form pred-check)
(if (stringp (car descs))
- (push `(put ',name 'structure-documentation
+ (push `(put ',name 'structure-documentation
,(pop descs)) forms))
(setq descs (cons '(cl-tag-slot)
- (mapcar (function (lambda (x) (if (consp x) x (list x))))
- descs)))
+ (mapcar (function (lambda (x) (if (consp x) x (list x))))
+ descs)))
(while opts
(let ((opt (if (consp (car opts)) (caar opts) (car opts)))
- (args (cdr-safe (pop opts))))
- (cond ((eq opt :conc-name)
- (if args
- (setq conc-name (if (car args)
- (symbol-name (car args)) ""))))
- ((eq opt :constructor)
- (if (cdr args)
+ (args (cdr-safe (pop opts))))
+ (cond ((eq opt :conc-name)
+ (if args
+ (setq conc-name (if (car args)
+ (symbol-name (car args)) ""))))
+ ((eq opt :constructor)
+ (if (cdr args)
(progn
;; If this defines a constructor of the same name as
;; the default one, don't define the default.
(if (eq (car args) constructor)
(setq constructor nil))
(push args constrs))
- (if args (setq constructor (car args)))))
- ((eq opt :copier)
- (if args (setq copier (car args))))
- ((eq opt :predicate)
- (if args (setq predicate (car args))))
- ((eq opt :include)
- (setq include (car args)
- include-descs (mapcar (function
- (lambda (x)
- (if (consp x) x (list x))))
- (cdr args))))
- ((eq opt :print-function)
- (setq print-func (car args)))
- ((eq opt :type)
- (setq type (car args)))
- ((eq opt :named)
- (setq named t))
- ((eq opt :initial-offset)
- (setq descs (nconc (make-list (car args) '(cl-skip-slot))
- descs)))
- (t
- (error "Slot option %s unrecognized" opt)))))
+ (if args (setq constructor (car args)))))
+ ((eq opt :copier)
+ (if args (setq copier (car args))))
+ ((eq opt :predicate)
+ (if args (setq predicate (car args))))
+ ((eq opt :include)
+ (setq include (car args)
+ include-descs (mapcar (function
+ (lambda (x)
+ (if (consp x) x (list x))))
+ (cdr args))))
+ ((eq opt :print-function)
+ (setq print-func (car args)))
+ ((eq opt :type)
+ (setq type (car args)))
+ ((eq opt :named)
+ (setq named t))
+ ((eq opt :initial-offset)
+ (setq descs (nconc (make-list (car args) '(cl-skip-slot))
+ descs)))
+ (t
+ (error "Slot option %s unrecognized" opt)))))
(if print-func
- (setq print-func
+ (setq print-func
`(progn (funcall #',print-func cl-x cl-s cl-n) t))
(or type (and include (not (get include 'cl-struct-print)))
- (setq print-auto t
- print-func (and (or (not (or include type)) (null print-func))
- `(progn
+ (setq print-auto t
+ print-func (and (or (not (or include type)) (null print-func))
+ `(progn
(princ ,(format "#S(%s" name) cl-s))))))
(if include
- (let ((inc-type (get include 'cl-struct-type))
- (old-descs (get include 'cl-struct-slots)))
- (or inc-type (error "%s is not a struct name" include))
- (and type (not (eq (car inc-type) type))
- (error ":type disagrees with :include for %s" name))
- (while include-descs
- (setcar (memq (or (assq (caar include-descs) old-descs)
- (error "No slot %s in included struct %s"
- (caar include-descs) include))
- old-descs)
- (pop include-descs)))
- (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs))
- type (car inc-type)
- named (assq 'cl-tag-slot descs))
- (if (cadr inc-type) (setq tag name named t))
- (let ((incl include))
- (while incl
- (push `(cl-pushnew ',tag
+ (let ((inc-type (get include 'cl-struct-type))
+ (old-descs (get include 'cl-struct-slots)))
+ (or inc-type (error "%s is not a struct name" include))
+ (and type (not (eq (car inc-type) type))
+ (error ":type disagrees with :include for %s" name))
+ (while include-descs
+ (setcar (memq (or (assq (caar include-descs) old-descs)
+ (error "No slot %s in included struct %s"
+ (caar include-descs) include))
+ old-descs)
+ (pop include-descs)))
+ (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs))
+ type (car inc-type)
+ named (assq 'cl-tag-slot descs))
+ (if (cadr inc-type) (setq tag name named t))
+ (let ((incl include))
+ (while incl
+ (push `(cl-pushnew ',tag
,(intern (format "cl-struct-%s-tags" incl)))
forms)
- (setq incl (get incl 'cl-struct-include)))))
+ (setq incl (get incl 'cl-struct-include)))))
(if type
- (progn
- (or (memq type '(vector list))
- (error "Invalid :type specifier: %s" type))
- (if named (setq tag name)))
- (setq type 'vector named 'true)))
+ (progn
+ (or (memq type '(vector list))
+ (error "Invalid :type specifier: %s" type))
+ (if named (setq tag name)))
+ (setq type 'vector named 'true)))
(or named (setq descs (delq (assq 'cl-tag-slot descs) descs)))
(push `(defvar ,tag-symbol) forms)
(setq pred-form (and named
- (let ((pos (- (length descs)
- (length (memq (assq 'cl-tag-slot descs)
- descs)))))
- (if (eq type 'vector)
- `(and (vectorp cl-x)
- (>= (length cl-x) ,(length descs))
- (memq (aref cl-x ,pos) ,tag-symbol))
- (if (= pos 0)
- `(memq (car-safe cl-x) ,tag-symbol)
- `(and (consp cl-x)
- (memq (nth ,pos cl-x) ,tag-symbol))))))
- pred-check (and pred-form (> safety 0)
- (if (and (eq (cl-caadr pred-form) 'vectorp)
- (= safety 1))
- (cons 'and (cl-cdddr pred-form)) pred-form)))
+ (let ((pos (- (length descs)
+ (length (memq (assq 'cl-tag-slot descs)
+ descs)))))
+ (if (eq type 'vector)
+ `(and (vectorp cl-x)
+ (>= (length cl-x) ,(length descs))
+ (memq (aref cl-x ,pos) ,tag-symbol))
+ (if (= pos 0)
+ `(memq (car-safe cl-x) ,tag-symbol)
+ `(and (consp cl-x)
+ (memq (nth ,pos cl-x) ,tag-symbol))))))
+ pred-check (and pred-form (> safety 0)
+ (if (and (eq (cl-caadr pred-form) 'vectorp)
+ (= safety 1))
+ (cons 'and (cl-cdddr pred-form)) pred-form)))
(let ((pos 0) (descp descs))
(while descp
- (let* ((desc (pop descp))
- (slot (car desc)))
- (if (memq slot '(cl-tag-slot cl-skip-slot))
- (progn
- (push nil slots)
- (push (and (eq slot 'cl-tag-slot) `',tag)
- defaults))
- (if (assq slot descp)
- (error "Duplicate slots named %s in %s" slot name))
- (let ((accessor (intern (format "%s%s" conc-name slot))))
- (push slot slots)
- (push (nth 1 desc) defaults)
- (push `(cl-defsubst ,accessor (cl-x)
+ (let* ((desc (pop descp))
+ (slot (car desc)))
+ (if (memq slot '(cl-tag-slot cl-skip-slot))
+ (progn
+ (push nil slots)
+ (push (and (eq slot 'cl-tag-slot) `',tag)
+ defaults))
+ (if (assq slot descp)
+ (error "Duplicate slots named %s in %s" slot name))
+ (let ((accessor (intern (format "%s%s" conc-name slot))))
+ (push slot slots)
+ (push (nth 1 desc) defaults)
+ (push `(cl-defsubst ,accessor (cl-x)
,@(and pred-check
- (list `(or ,pred-check
+ (list `(or ,pred-check
(error "%s accessing a non-%s"
',accessor ',name))))
,(if (eq type 'vector) `(aref cl-x ,pos)
(if (= pos 0) '(car cl-x)
`(nth ,pos cl-x)))) forms)
- (push (cons accessor t) side-eff)
+ (push (cons accessor t) side-eff)
(if (cadr (memq :read-only (cddr desc)))
(push `(gv-define-expander ,accessor
(lambda (_cl-do _cl-x)
@@ -2541,37 +2541,37 @@
;; ,pos)))
;; forms)
)
- (if print-auto
- (nconc print-func
- (list `(princ ,(format " %s" slot) cl-s)
- `(prin1 (,accessor cl-x) cl-s)))))))
- (setq pos (1+ pos))))
+ (if print-auto
+ (nconc print-func
+ (list `(princ ,(format " %s" slot) cl-s)
+ `(prin1 (,accessor cl-x) cl-s)))))))
+ (setq pos (1+ pos))))
(setq slots (nreverse slots)
- defaults (nreverse defaults))
+ defaults (nreverse defaults))
(and predicate pred-form
- (progn (push `(cl-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)
- (push (cons predicate 'error-free) side-eff)))
+ (push (cons predicate 'error-free) side-eff)))
(and copier
- (progn (push `(defun ,copier (x) (copy-sequence x)) forms)
- (push (cons copier t) side-eff)))
+ (progn (push `(defun ,copier (x) (copy-sequence x)) forms)
+ (push (cons copier t) side-eff)))
(if constructor
- (push (list constructor
- (cons '&key (delq nil (copy-sequence slots))))
- constrs))
+ (push (list constructor
+ (cons '&key (delq nil (copy-sequence slots))))
+ constrs))
(while constrs
(let* ((name (caar constrs))
- (args (cadr (pop constrs)))
- (anames (cl--arglist-args args))
- (make (cl-mapcar (function (lambda (s d) (if (memq s anames) s d)))
- slots defaults)))
- (push `(cl-defsubst ,name
+ (args (cadr (pop constrs)))
+ (anames (cl--arglist-args args))
+ (make (cl-mapcar (function (lambda (s d) (if (memq s anames) s
d)))
+ slots defaults)))
+ (push `(cl-defsubst ,name
(&cl-defs '(nil ,@descs) ,@args)
(,type ,@make)) forms)
- (if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs)))
- (push (cons name t) side-eff))))
+ (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)))
;; Don't bother adding to cl-custom-print-functions since it's not used
;; by anything anyway!
@@ -2638,44 +2638,44 @@
(defun cl--make-type-test (val type)
(if (symbolp type)
(cond ((get type 'cl-deftype-handler)
- (cl--make-type-test val (funcall (get type 'cl-deftype-handler))))
- ((memq type '(nil t)) type)
- ((eq type 'null) `(null ,val))
- ((eq type 'atom) `(atom ,val))
- ((eq type 'float) `(floatp ,val))
- ((eq type 'real) `(numberp ,val))
- ((eq type 'fixnum) `(integerp ,val))
- ;; FIXME: Should `character' accept things like ?\C-\M-a ? --Stef
- ((memq type '(character string-char)) `(characterp ,val))
- (t
- (let* ((name (symbol-name type))
- (namep (intern (concat name "p"))))
- (cond
+ (cl--make-type-test val (funcall (get type 'cl-deftype-handler))))
+ ((memq type '(nil t)) type)
+ ((eq type 'null) `(null ,val))
+ ((eq type 'atom) `(atom ,val))
+ ((eq type 'float) `(floatp ,val))
+ ((eq type 'real) `(numberp ,val))
+ ((eq type 'fixnum) `(integerp ,val))
+ ;; FIXME: Should `character' accept things like ?\C-\M-a ? --Stef
+ ((memq type '(character string-char)) `(characterp ,val))
+ (t
+ (let* ((name (symbol-name type))
+ (namep (intern (concat name "p"))))
+ (cond
((cl--macroexp-fboundp namep) (list namep val))
((cl--macroexp-fboundp
(setq namep (intern (concat name "-p"))))
(list namep val))
(t (list type val))))))
(cond ((get (car type) 'cl-deftype-handler)
- (cl--make-type-test val (apply (get (car type) 'cl-deftype-handler)
- (cdr type))))
- ((memq (car type) '(integer float real number))
- (delq t `(and ,(cl--make-type-test val (car type))
- ,(if (memq (cadr type) '(* nil)) t
+ (cl--make-type-test val (apply (get (car type) 'cl-deftype-handler)
+ (cdr 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 ,(cl-caadr type))
`(>= ,val ,(cadr type))))
- ,(if (memq (cl-caddr type) '(* nil)) t
+ ,(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 cl-member))
- `(and (cl-member ,val ',(cdr type)) t))
- ((eq (car type) 'satisfies) (list (cadr type) val))
- (t (error "Bad type spec: %s" 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 cl-member))
+ `(and (cl-member ,val ',(cdr type)) t))
+ ((eq (car type) 'satisfies) (list (cadr type) val))
+ (t (error "Bad type spec: %s" type)))))
(defvar cl--object)
;;;###autoload
@@ -2699,15 +2699,15 @@
STRING is an optional description of the desired type."
(declare (debug (place cl-type-spec &optional stringp)))
(and (or (not (cl--compiling-file))
- (< cl--optimize-speed 3) (= cl--optimize-safety 3))
+ (< cl--optimize-speed 3) (= cl--optimize-safety 3))
(let* ((temp (if (cl--simple-expr-p form 3)
- form (make-symbol "--cl-var--")))
- (body `(or ,(cl--make-type-test temp type)
+ form (make-symbol "--cl-var--")))
+ (body `(or ,(cl--make-type-test temp type)
(signal 'wrong-type-argument
(list ,(or string `',type)
,temp ',form)))))
- (if (eq temp form) `(progn ,body nil)
- `(let ((,temp ,form)) ,body nil)))))
+ (if (eq temp form) `(progn ,body nil)
+ `(let ((,temp ,form)) ,body nil)))))
;;;###autoload
(defmacro cl-assert (form &optional show-args string &rest args)
@@ -2719,13 +2719,13 @@
omitted, a default message listing FORM itself is used."
(declare (debug (form &rest form)))
(and (or (not (cl--compiling-file))
- (< cl--optimize-speed 3) (= cl--optimize-safety 3))
+ (< cl--optimize-speed 3) (= cl--optimize-safety 3))
(let ((sargs (and show-args
(delq nil (mapcar (lambda (x)
(unless (macroexp-const-p x)
x))
(cdr form))))))
- `(progn
+ `(progn
(or ,form
,(if string
`(error ,string ,@sargs ,@args)
@@ -2767,14 +2767,14 @@
macro that returns its `&whole' argument."
(while
(let ((func (car-safe form)) (handler nil))
- (while (and (symbolp func)
- (not (setq handler (get func 'compiler-macro)))
- (fboundp func)
- (or (not (autoloadp (symbol-function func)))
- (autoload-do-load (symbol-function func) func)))
- (setq func (symbol-function func)))
- (and handler
- (not (eq form (setq form (apply handler form (cdr form))))))))
+ (while (and (symbolp func)
+ (not (setq handler (get func 'compiler-macro)))
+ (fboundp func)
+ (or (not (autoloadp (symbol-function func)))
+ (autoload-do-load (symbol-function func) func)))
+ (setq func (symbol-function func)))
+ (and handler
+ (not (eq form (setq form (apply handler form (cdr form))))))))
form)
;; Optimize away unused block-wrappers.
@@ -2866,23 +2866,23 @@
(defun cl--compiler-macro-member (form a list &rest keys)
(let ((test (and (= (length keys) 2) (eq (car keys) :test)
- (cl--const-expr-val (nth 1 keys)
+ (cl--const-expr-val (nth 1 keys)
macroexpand-all-environment))))
(cond ((eq test 'eq) `(memq ,a ,list))
- ((eq test 'equal) `(member ,a ,list))
- ((or (null keys) (eq test 'eql)) `(memql ,a ,list))
- (t form))))
+ ((eq test 'equal) `(member ,a ,list))
+ ((or (null keys) (eq test 'eql)) `(memql ,a ,list))
+ (t form))))
(defun cl--compiler-macro-assoc (form a list &rest keys)
(let ((test (and (= (length keys) 2) (eq (car keys) :test)
- (cl--const-expr-val (nth 1 keys)
+ (cl--const-expr-val (nth 1 keys)
macroexpand-all-environment))))
(cond ((eq test 'eq) `(assq ,a ,list))
- ((eq test 'equal) `(assoc ,a ,list))
- ((and (macroexp-const-p a) (or (null keys) (eq test 'eql)))
- (if (floatp (cl--const-expr-val a macroexpand-all-environment))
- `(assoc ,a ,list) `(assq ,a ,list)))
- (t form))))
+ ((eq test 'equal) `(assoc ,a ,list))
+ ((and (macroexp-const-p a) (or (null keys) (eq test 'eql)))
+ (if (floatp (cl--const-expr-val a macroexpand-all-environment))
+ `(assoc ,a ,list) `(assq ,a ,list)))
+ (t form))))
;;;###autoload
(defun cl--compiler-macro-adjoin (form a list &rest keys)
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] trunk r117000: Untabify cl-macs.el,
Daniel Colascione <=