Mercurial > hg > xemacs-beta

comparison lisp/cl-macs.el @ 5367:8b70d37ab80e

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Use Common Lisp-derived builtins in a few more places in core Lisp. 2011-03-08 Aidan Kehoe <kehoea@parhasard.net> * cl-macs.el: * cl-macs.el (loop): * cl-macs.el (cl-expand-do-loop): * cl-macs.el (shiftf): * cl-macs.el (rotatef): * cl-macs.el (assert): * cl-macs.el (cl-defsubst-expand): * etags.el (buffer-tag-table-list): * frame.el: * frame.el (frame-notice-user-settings): * frame.el (minibuffer-frame-list): * frame.el (get-frame-for-buffer-noselect): Use Common Lisp-derived builtins in a few more places, none of them performance-critical, but the style is better.
author Aidan Kehoe <kehoea@parhasard.net>
date Tue, 08 Mar 2011 23:57:21 +0000
parents f00192e1cd49
children 4b529b940e2e ac37a5f7e5be
comparison
equal deleted inserted replaced
5366:f00192e1cd49 5367:8b70d37ab80e
1064 1064
1065 named NAME 1065 named NAME
1066 Specify the name for block surrounding the loop, in place of nil. 1066 Specify the name for block surrounding the loop, in place of nil.
1067 (See `block'.) 1067 (See `block'.)
1068 " 1068 "
1069 (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list clauses)))))) 1069 (if (notany #'symbolp (set-difference clauses '(nil t)))
1070 (list 'block nil (list* 'while t clauses)) 1070 (list 'block nil (list* 'while t clauses))
1071 (let ((loop-name nil) (loop-bindings nil) 1071 (let ((loop-name nil) (loop-bindings nil)
1072 (loop-body nil) (loop-steps nil) 1072 (loop-body nil) (loop-steps nil)
1073 (loop-result nil) (loop-result-explicit nil) 1073 (loop-result nil) (loop-result-explicit nil)
1074 (loop-result-var nil) (loop-finish-flag nil) 1074 (loop-result-var nil) (loop-finish-flag nil)
1646 (list* (if star 'let* 'let) 1646 (list* (if star 'let* 'let)
1647 (mapcar #'(lambda (c) (if (consp c) (list (car c) (nth 1 c)) c)) 1647 (mapcar #'(lambda (c) (if (consp c) (list (car c) (nth 1 c)) c))
1648 steps) 1648 steps)
1649 (list* 'while (list 'not (car endtest)) 1649 (list* 'while (list 'not (car endtest))
1650 (append body 1650 (append body
1651 (let ((sets (mapcar 1651 (let ((sets (mapcan
1652 #'(lambda (c) 1652 #'(lambda (c)
1653 (and (consp c) (cdr (cdr c)) 1653 (and (consp c) (cdr (cdr c))
1654 (list (car c) (nth 2 c)))) 1654 (list
1655 (list (car c) (nth 2 c)))))
1655 steps))) 1656 steps)))
1656 (setq sets (delq nil sets))
1657 (and sets 1657 (and sets
1658 (list (cons (if (or star (not (cdr sets))) 1658 (list (cons (if (or star (not (cdr sets)))
1659 'setq 'psetq) 1659 'setq 'psetq)
1660 (apply 'append sets))))))) 1660 (apply 'append sets)))))))
1661 (or (cdr endtest) '(nil))))) 1661 (or (cdr endtest) '(nil)))))
2577 (defmacro shiftf (place &rest args) 2577 (defmacro shiftf (place &rest args)
2578 "(shiftf PLACE PLACE... VAL): shift left among PLACEs. 2578 "(shiftf PLACE PLACE... VAL): shift left among PLACEs.
2579 Example: (shiftf A B C) sets A to B, B to C, and returns the old A. 2579 Example: (shiftf A B C) sets A to B, B to C, and returns the old A.
2580 Each PLACE may be a symbol, or any generalized variable allowed by `setf'." 2580 Each PLACE may be a symbol, or any generalized variable allowed by `setf'."
2581 ;; XEmacs change: use iteration instead of recursion 2581 ;; XEmacs change: use iteration instead of recursion
2582 (if (not (memq nil (mapcar 'symbolp (butlast (cons place args))))) 2582 (if (every #'symbolp (butlast (cons place args)))
2583 (list* 'prog1 place 2583 (list* 'prog1 place
2584 (let ((sets nil)) 2584 (let ((sets nil))
2585 (while args 2585 (while args
2586 (push (list 'setq place (car args)) sets) 2586 (push (list 'setq place (car args)) sets)
2587 (setq place (pop args))) 2587 (setq place (pop args)))
2598 ;;;###autoload 2598 ;;;###autoload
2599 (defmacro rotatef (&rest places) 2599 (defmacro rotatef (&rest places)
2600 "Rotate left among PLACES. 2600 "Rotate left among PLACES.
2601 Example: (rotatef A B C) sets A to B, B to C, and C to A. It returns nil. 2601 Example: (rotatef A B C) sets A to B, B to C, and C to A. It returns nil.
2602 Each PLACE may be a symbol, or any generalized variable allowed by `setf'." 2602 Each PLACE may be a symbol, or any generalized variable allowed by `setf'."
2603 (if (not (memq nil (mapcar 'symbolp places))) 2603 (if (every #'symbolp places)
2604 (and (cdr places) 2604 (and (cdr places)
2605 (let ((sets nil) 2605 (let ((sets nil)
2606 (first (car places))) 2606 (first (car places)))
2607 (while (cdr places) 2607 (while (cdr places)
2608 (setq sets (nconc sets (list (pop places) (car places))))) 2608 (setq sets (nconc sets (list (pop places) (car places)))))
3125 Other args STRING and ARGS... are arguments to be passed to `error'. 3125 Other args STRING and ARGS... are arguments to be passed to `error'.
3126 They are not evaluated unless the assertion fails. If STRING is 3126 They are not evaluated unless the assertion fails. If STRING is
3127 omitted, a default message listing FORM itself is used." 3127 omitted, a default message listing FORM itself is used."
3128 (and (or (not (cl-compiling-file)) 3128 (and (or (not (cl-compiling-file))
3129 (< cl-optimize-speed 3) (= cl-optimize-safety 3)) 3129 (< cl-optimize-speed 3) (= cl-optimize-safety 3))
3130 (let ((sargs (and show-args (delq nil (mapcar 3130 (let ((sargs (and show-args (remove-if #'cl-const-expr-p (cdr form)))))
3131 #'(lambda (x)
3132 (and (not (cl-const-expr-p x))
3133 x))
3134 (cdr form))))))
3135 (list 'progn 3131 (list 'progn
3136 (list 'or form 3132 (list 'or form
3137 (if string 3133 (if string
3138 (list* 'error string (append sargs args)) 3134 (list* 'error string (append sargs args))
3139 (list 'signal '(quote cl-assertion-failed) 3135 (list 'signal '(quote cl-assertion-failed)
3224 (list* 'defun* name arglist docstring body)))) 3220 (list* 'defun* name arglist docstring body))))
3225 3221
3226 (defun cl-defsubst-expand (argns body simple whole unsafe &rest argvs) 3222 (defun cl-defsubst-expand (argns body simple whole unsafe &rest argvs)
3227 (if (and whole (not (cl-safe-expr-p (cons 'progn argvs)))) whole 3223 (if (and whole (not (cl-safe-expr-p (cons 'progn argvs)))) whole
3228 (if (cl-simple-exprs-p argvs) (setq simple t)) 3224 (if (cl-simple-exprs-p argvs) (setq simple t))
3229 (let ((lets (delq nil 3225 (let ((lets (mapcan #'(lambda (argn argv)
3230 (mapcar* #'(lambda (argn argv) 3226 (if (or simple (cl-const-expr-p argv))
3231 (if (or simple (cl-const-expr-p argv)) 3227 (progn (setq body (subst argv argn body))
3232 (progn (setq body (subst argv argn body)) 3228 (and unsafe (list (list argn argv))))
3233 (and unsafe (list argn argv))) 3229 (list (list argn argv))))
3234 (list argn argv))) 3230 argns argvs)))
3235 argns argvs))))
3236 (if lets (list 'let lets body) body)))) 3231 (if lets (list 'let lets body) body))))
3237 3232
3238 3233
3239 ;;; Compile-time optimizations for some functions defined in this package. 3234 ;;; Compile-time optimizations for some functions defined in this package.
3240 ;;; Note that cl.el arranges to force cl-macs to be loaded at compile-time, 3235 ;;; Note that cl.el arranges to force cl-macs to be loaded at compile-time,