Mercurial > hg > xemacs-beta
diff lisp/cl-macs.el @ 5473:ac37a5f7e5be
Merge with trunk.
author | Mats Lidell <matsl@xemacs.org> |
---|---|
date | Thu, 17 Mar 2011 23:42:59 +0100 |
parents | 00e79bbbe48f 8b70d37ab80e |
children | 4dee0387b9de |
line wrap: on
line diff
--- a/lisp/cl-macs.el Tue Feb 22 22:56:02 2011 +0100 +++ b/lisp/cl-macs.el Thu Mar 17 23:42:59 2011 +0100 @@ -426,7 +426,7 @@ (or (eq p args) (setq minarg (list 'cdr minarg))) (setq p (cdr p))) (if (memq (car p) '(nil &aux)) - (setq minarg (list '= (list 'length restarg) + (setq minarg (list 'eql (list 'length restarg) (length (ldiff args p))) exactarg (not (eq args p))))) (while (and args (not (memq (car args) lambda-list-keywords))) @@ -1064,7 +1064,7 @@ Specify the name for block surrounding the loop, in place of nil. (See `block'.) " - (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list clauses)))))) + (if (notany #'symbolp (set-difference clauses '(nil t))) (list 'block nil (list* 'while t clauses)) (let ((loop-name nil) (loop-bindings nil) (loop-body nil) (loop-steps nil) @@ -1263,7 +1263,7 @@ (seq (cl-pop2 args)) (temp-seq (gensym)) (temp-idx (if (eq (car args) 'using) - (if (and (= (length (cadr args)) 2) + (if (and (eql (length (cadr args)) 2) (eq (caadr args) 'index)) (cadr (cl-pop2 args)) (error "Bad `using' clause")) @@ -1294,7 +1294,7 @@ (or (memq (car args) '(in of)) (error "Expected `of'")) (let* ((table (cl-pop2 args)) (other (if (eq (car args) 'using) - (if (and (= (length (cadr args)) 2) + (if (and (eql (length (cadr args)) 2) (memq (caadr args) hash-types) (not (eq (caadr args) word))) (cadr (cl-pop2 args)) @@ -1350,7 +1350,7 @@ (let* ((map (cl-pop2 args)) other-word (other (if (eq (car args) 'using) - (if (and (= (length (cadr args)) 2) + (if (and (eql (length (cadr args)) 2) (memq (setq other-word (caadr args)) key-types) (not (eq (caadr args) word))) @@ -1646,12 +1646,12 @@ steps) (list* 'while (list 'not (car endtest)) (append body - (let ((sets (mapcar + (let ((sets (mapcan #'(lambda (c) (and (consp c) (cdr (cdr c)) - (list (car c) (nth 2 c)))) + (list + (list (car c) (nth 2 c))))) steps))) - (setq sets (delq nil sets)) (and sets (list (cons (if (or star (not (cdr sets))) 'setq 'psetq) @@ -1878,7 +1878,7 @@ Returns the value given by the last element of BODY." (if (null syms) `(progn ,form ,@body) - (if (= 1 (length syms)) + (if (eql 1 (length syms)) ;; Code written to deal with other "implementations" of multiple ;; values may have a one-element SYMS. `(let ((,(car syms) ,form)) @@ -1905,7 +1905,7 @@ (if (null syms) ;; Never return multiple values from multiple-value-setq: (and form `(values ,form)) - (if (= 1 (length syms)) + (if (eql 1 (length syms)) `(setq ,(car syms) ,form) (let ((temp (gensym))) `(let* ((,temp (multiple-value-list-internal 0 ,(length syms) ,form))) @@ -2432,7 +2432,7 @@ (or (and method (let ((cl-macro-environment env)) (setq method (apply method (cdr place)))) - (if (and (consp method) (= (length method) 5)) + (if (and (consp method) (eql (length method) 5)) method (error "Setf-method for %s returns malformed method" func))) @@ -2577,7 +2577,7 @@ 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'." ;; XEmacs change: use iteration instead of recursion - (if (not (memq nil (mapcar 'symbolp (butlast (cons place args))))) + (if (every #'symbolp (butlast (cons place args))) (list* 'prog1 place (let ((sets nil)) (while args @@ -2598,7 +2598,7 @@ "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'." - (if (not (memq nil (mapcar 'symbolp places))) + (if (every #'symbolp places) (and (cdr places) (let ((sets nil) (first (car places))) @@ -3125,11 +3125,7 @@ omitted, a default message listing FORM itself is used." (and (or (not (cl-compiling-file)) (< cl-optimize-speed 3) (= cl-optimize-safety 3)) - (let ((sargs (and show-args (delq nil (mapcar - #'(lambda (x) - (and (not (cl-const-expr-p x)) - x)) - (cdr form)))))) + (let ((sargs (and show-args (remove-if #'cl-const-expr-p (cdr form))))) (list 'progn (list 'or form (if string @@ -3224,13 +3220,12 @@ (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 ((lets (delq nil - (mapcar* #'(lambda (argn argv) - (if (or simple (cl-const-expr-p argv)) - (progn (setq body (subst argv argn body)) - (and unsafe (list argn argv))) - (list argn argv))) - argns argvs)))) + (let ((lets (mapcan #'(lambda (argn argv) + (if (or simple (cl-const-expr-p argv)) + (progn (setq body (subst argv argn body)) + (and unsafe (list (list argn argv)))) + (list (list argn argv)))) + argns argvs))) (if lets (list 'let lets body) body))))