Mercurial > hg > xemacs-beta

comparison lisp/cl-macs.el @ 5473:ac37a5f7e5be

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge with trunk.
author Mats Lidell <matsl@xemacs.org>
date Thu, 17 Mar 2011 23:42:59 +0100
parents 00e79bbbe48f 8b70d37ab80e
children 4dee0387b9de
comparison
equal deleted inserted replaced
5472:e79980ee5efe 5473:ac37a5f7e5be
424 (setq minarg restarg) 424 (setq minarg restarg)
425 (while (and p (not (memq (car p) lambda-list-keywords))) 425 (while (and p (not (memq (car p) lambda-list-keywords)))
426 (or (eq p args) (setq minarg (list 'cdr minarg))) 426 (or (eq p args) (setq minarg (list 'cdr minarg)))
427 (setq p (cdr p))) 427 (setq p (cdr p)))
428 (if (memq (car p) '(nil &aux)) 428 (if (memq (car p) '(nil &aux))
429 (setq minarg (list '= (list 'length restarg) 429 (setq minarg (list 'eql (list 'length restarg)
430 (length (ldiff args p))) 430 (length (ldiff args p)))
431 exactarg (not (eq args p))))) 431 exactarg (not (eq args p)))))
432 (while (and args (not (memq (car args) lambda-list-keywords))) 432 (while (and args (not (memq (car args) lambda-list-keywords)))
433 (let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car) 433 (let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car)
434 restarg))) 434 restarg)))
1062 1062
1063 named NAME 1063 named NAME
1064 Specify the name for block surrounding the loop, in place of nil. 1064 Specify the name for block surrounding the loop, in place of nil.
1065 (See `block'.) 1065 (See `block'.)
1066 " 1066 "
1067 (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list clauses)))))) 1067 (if (notany #'symbolp (set-difference clauses '(nil t)))
1068 (list 'block nil (list* 'while t clauses)) 1068 (list 'block nil (list* 'while t clauses))
1069 (let ((loop-name nil) (loop-bindings nil) 1069 (let ((loop-name nil) (loop-bindings nil)
1070 (loop-body nil) (loop-steps nil) 1070 (loop-body nil) (loop-steps nil)
1071 (loop-result nil) (loop-result-explicit nil) 1071 (loop-result nil) (loop-result-explicit nil)
1072 (loop-result-var nil) (loop-finish-flag nil) 1072 (loop-result-var nil) (loop-finish-flag nil)
1261 (and (not (memq (car args) '(in of))) 1261 (and (not (memq (car args) '(in of)))
1262 (error "Expected `of'")))) 1262 (error "Expected `of'"))))
1263 (seq (cl-pop2 args)) 1263 (seq (cl-pop2 args))
1264 (temp-seq (gensym)) 1264 (temp-seq (gensym))
1265 (temp-idx (if (eq (car args) 'using) 1265 (temp-idx (if (eq (car args) 'using)
1266 (if (and (= (length (cadr args)) 2) 1266 (if (and (eql (length (cadr args)) 2)
1267 (eq (caadr args) 'index)) 1267 (eq (caadr args) 'index))
1268 (cadr (cl-pop2 args)) 1268 (cadr (cl-pop2 args))
1269 (error "Bad `using' clause")) 1269 (error "Bad `using' clause"))
1270 (gensym)))) 1270 (gensym))))
1271 (push (list temp-seq seq) loop-for-bindings) 1271 (push (list temp-seq seq) loop-for-bindings)
1292 1292
1293 ((memq word hash-types) 1293 ((memq word hash-types)
1294 (or (memq (car args) '(in of)) (error "Expected `of'")) 1294 (or (memq (car args) '(in of)) (error "Expected `of'"))
1295 (let* ((table (cl-pop2 args)) 1295 (let* ((table (cl-pop2 args))
1296 (other (if (eq (car args) 'using) 1296 (other (if (eq (car args) 'using)
1297 (if (and (= (length (cadr args)) 2) 1297 (if (and (eql (length (cadr args)) 2)
1298 (memq (caadr args) hash-types) 1298 (memq (caadr args) hash-types)
1299 (not (eq (caadr args) word))) 1299 (not (eq (caadr args) word)))
1300 (cadr (cl-pop2 args)) 1300 (cadr (cl-pop2 args))
1301 (error "Bad `using' clause")) 1301 (error "Bad `using' clause"))
1302 (gensym)))) 1302 (gensym))))
1348 ((memq word key-types) 1348 ((memq word key-types)
1349 (or (memq (car args) '(in of)) (error "Expected `of'")) 1349 (or (memq (car args) '(in of)) (error "Expected `of'"))
1350 (let* ((map (cl-pop2 args)) 1350 (let* ((map (cl-pop2 args))
1351 other-word 1351 other-word
1352 (other (if (eq (car args) 'using) 1352 (other (if (eq (car args) 'using)
1353 (if (and (= (length (cadr args)) 2) 1353 (if (and (eql (length (cadr args)) 2)
1354 (memq (setq other-word (caadr args)) 1354 (memq (setq other-word (caadr args))
1355 key-types) 1355 key-types)
1356 (not (eq (caadr args) word))) 1356 (not (eq (caadr args) word)))
1357 (cadr (cl-pop2 args)) 1357 (cadr (cl-pop2 args))
1358 (error "Bad `using' clause")) 1358 (error "Bad `using' clause"))
1644 (list* (if star 'let* 'let) 1644 (list* (if star 'let* 'let)
1645 (mapcar #'(lambda (c) (if (consp c) (list (car c) (nth 1 c)) c)) 1645 (mapcar #'(lambda (c) (if (consp c) (list (car c) (nth 1 c)) c))
1646 steps) 1646 steps)
1647 (list* 'while (list 'not (car endtest)) 1647 (list* 'while (list 'not (car endtest))
1648 (append body 1648 (append body
1649 (let ((sets (mapcar 1649 (let ((sets (mapcan
1650 #'(lambda (c) 1650 #'(lambda (c)
1651 (and (consp c) (cdr (cdr c)) 1651 (and (consp c) (cdr (cdr c))
1652 (list (car c) (nth 2 c)))) 1652 (list
1653 (list (car c) (nth 2 c)))))
1653 steps))) 1654 steps)))
1654 (setq sets (delq nil sets))
1655 (and sets 1655 (and sets
1656 (list (cons (if (or star (not (cdr sets))) 1656 (list (cons (if (or star (not (cdr sets)))
1657 'setq 'psetq) 1657 'setq 'psetq)
1658 (apply 'append sets))))))) 1658 (apply 'append sets)))))))
1659 (or (cdr endtest) '(nil))))) 1659 (or (cdr endtest) '(nil)))))
1876 not return multiple values, it is treated as returning one multiple value. 1876 not return multiple values, it is treated as returning one multiple value.
1877 1877
1878 Returns the value given by the last element of BODY." 1878 Returns the value given by the last element of BODY."
1879 (if (null syms) 1879 (if (null syms)
1880 `(progn ,form ,@body) 1880 `(progn ,form ,@body)
1881 (if (= 1 (length syms)) 1881 (if (eql 1 (length syms))
1882 ;; Code written to deal with other "implementations" of multiple 1882 ;; Code written to deal with other "implementations" of multiple
1883 ;; values may have a one-element SYMS. 1883 ;; values may have a one-element SYMS.
1884 `(let ((,(car syms) ,form)) 1884 `(let ((,(car syms) ,form))
1885 ,@body) 1885 ,@body)
1886 (let ((temp (gensym))) 1886 (let ((temp (gensym)))
1903 1903
1904 Returns the first of the multiple values given by FORM." 1904 Returns the first of the multiple values given by FORM."
1905 (if (null syms) 1905 (if (null syms)
1906 ;; Never return multiple values from multiple-value-setq: 1906 ;; Never return multiple values from multiple-value-setq:
1907 (and form `(values ,form)) 1907 (and form `(values ,form))
1908 (if (= 1 (length syms)) 1908 (if (eql 1 (length syms))
1909 `(setq ,(car syms) ,form) 1909 `(setq ,(car syms) ,form)
1910 (let ((temp (gensym))) 1910 (let ((temp (gensym)))
1911 `(let* ((,temp (multiple-value-list-internal 0 ,(length syms) ,form))) 1911 `(let* ((,temp (multiple-value-list-internal 0 ,(length syms) ,form)))
1912 (setq ,@(loop 1912 (setq ,@(loop
1913 for sym in syms 1913 for sym in syms
2430 (method (get func 'setf-method)) 2430 (method (get func 'setf-method))
2431 (case-fold-search nil)) 2431 (case-fold-search nil))
2432 (or (and method 2432 (or (and method
2433 (let ((cl-macro-environment env)) 2433 (let ((cl-macro-environment env))
2434 (setq method (apply method (cdr place)))) 2434 (setq method (apply method (cdr place))))
2435 (if (and (consp method) (= (length method) 5)) 2435 (if (and (consp method) (eql (length method) 5))
2436 method 2436 method
2437 (error "Setf-method for %s returns malformed method" 2437 (error "Setf-method for %s returns malformed method"
2438 func))) 2438 func)))
2439 (and (save-match-data 2439 (and (save-match-data
2440 (string-match "\\`c[ad][ad][ad]?[ad]?r\\'" name)) 2440 (string-match "\\`c[ad][ad][ad]?[ad]?r\\'" name))
2575 (defmacro shiftf (place &rest args) 2575 (defmacro shiftf (place &rest args)
2576 "(shiftf PLACE PLACE... VAL): shift left among PLACEs. 2576 "(shiftf PLACE PLACE... VAL): shift left among PLACEs.
2577 Example: (shiftf A B C) sets A to B, B to C, and returns the old A. 2577 Example: (shiftf A B C) sets A to B, B to C, and returns the old A.
2578 Each PLACE may be a symbol, or any generalized variable allowed by `setf'." 2578 Each PLACE may be a symbol, or any generalized variable allowed by `setf'."
2579 ;; XEmacs change: use iteration instead of recursion 2579 ;; XEmacs change: use iteration instead of recursion
2580 (if (not (memq nil (mapcar 'symbolp (butlast (cons place args))))) 2580 (if (every #'symbolp (butlast (cons place args)))
2581 (list* 'prog1 place 2581 (list* 'prog1 place
2582 (let ((sets nil)) 2582 (let ((sets nil))
2583 (while args 2583 (while args
2584 (push (list 'setq place (car args)) sets) 2584 (push (list 'setq place (car args)) sets)
2585 (setq place (pop args))) 2585 (setq place (pop args)))
2596 ;;;###autoload 2596 ;;;###autoload
2597 (defmacro rotatef (&rest places) 2597 (defmacro rotatef (&rest places)
2598 "Rotate left among PLACES. 2598 "Rotate left among PLACES.
2599 Example: (rotatef A B C) sets A to B, B to C, and C to A. It returns nil. 2599 Example: (rotatef A B C) sets A to B, B to C, and C to A. It returns nil.
2600 Each PLACE may be a symbol, or any generalized variable allowed by `setf'." 2600 Each PLACE may be a symbol, or any generalized variable allowed by `setf'."
2601 (if (not (memq nil (mapcar 'symbolp places))) 2601 (if (every #'symbolp places)
2602 (and (cdr places) 2602 (and (cdr places)
2603 (let ((sets nil) 2603 (let ((sets nil)
2604 (first (car places))) 2604 (first (car places)))
2605 (while (cdr places) 2605 (while (cdr places)
2606 (setq sets (nconc sets (list (pop places) (car places))))) 2606 (setq sets (nconc sets (list (pop places) (car places)))))
3123 Other args STRING and ARGS... are arguments to be passed to `error'. 3123 Other args STRING and ARGS... are arguments to be passed to `error'.
3124 They are not evaluated unless the assertion fails. If STRING is 3124 They are not evaluated unless the assertion fails. If STRING is
3125 omitted, a default message listing FORM itself is used." 3125 omitted, a default message listing FORM itself is used."
3126 (and (or (not (cl-compiling-file)) 3126 (and (or (not (cl-compiling-file))
3127 (< cl-optimize-speed 3) (= cl-optimize-safety 3)) 3127 (< cl-optimize-speed 3) (= cl-optimize-safety 3))
3128 (let ((sargs (and show-args (delq nil (mapcar 3128 (let ((sargs (and show-args (remove-if #'cl-const-expr-p (cdr form)))))
3129 #'(lambda (x)
3130 (and (not (cl-const-expr-p x))
3131 x))
3132 (cdr form))))))
3133 (list 'progn 3129 (list 'progn
3134 (list 'or form 3130 (list 'or form
3135 (if string 3131 (if string
3136 (list* 'error string (append sargs args)) 3132 (list* 'error string (append sargs args))
3137 (list 'signal '(quote cl-assertion-failed) 3133 (list 'signal '(quote cl-assertion-failed)
3222 (list* 'defun* name arglist docstring body)))) 3218 (list* 'defun* name arglist docstring body))))
3223 3219
3224 (defun cl-defsubst-expand (argns body simple whole unsafe &rest argvs) 3220 (defun cl-defsubst-expand (argns body simple whole unsafe &rest argvs)
3225 (if (and whole (not (cl-safe-expr-p (cons 'progn argvs)))) whole 3221 (if (and whole (not (cl-safe-expr-p (cons 'progn argvs)))) whole
3226 (if (cl-simple-exprs-p argvs) (setq simple t)) 3222 (if (cl-simple-exprs-p argvs) (setq simple t))
3227 (let ((lets (delq nil 3223 (let ((lets (mapcan #'(lambda (argn argv)
3228 (mapcar* #'(lambda (argn argv) 3224 (if (or simple (cl-const-expr-p argv))
3229 (if (or simple (cl-const-expr-p argv)) 3225 (progn (setq body (subst argv argn body))
3230 (progn (setq body (subst argv argn body)) 3226 (and unsafe (list (list argn argv))))
3231 (and unsafe (list argn argv))) 3227 (list (list argn argv))))
3232 (list argn argv))) 3228 argns argvs)))
3233 argns argvs))))
3234 (if lets (list 'let lets body) body)))) 3229 (if lets (list 'let lets body) body))))
3235 3230
3236 3231
3237 ;;; Compile-time optimizations for some functions defined in this package. 3232 ;;; Compile-time optimizations for some functions defined in this package.
3238 ;;; Note that cl.el arranges to force cl-macs to be loaded at compile-time, 3233 ;;; Note that cl.el arranges to force cl-macs to be loaded at compile-time,