Mercurial > hg > xemacs-beta

comparison lisp/cl-macs.el @ 5326:60ba780f9078

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Use defmacro* when defining dolist, dotimes, do-symbols, macrolet, cl-macs.el 2011-01-01 Aidan Kehoe <kehoea@parhasard.net> * cl-macs.el (dolist, dotimes, do-symbols, macrolet) (symbol-macrolet): Define these macros with defmacro* instead of parsing the argument list by hand, for the sake of style and readability; use backquote where appropriate, instead of calling #'list and and friends, for the same reason.
author Aidan Kehoe <kehoea@parhasard.net>
date Sun, 02 Jan 2011 00:06:14 +0000
parents 8aa511adfad6
children 7b391d07b334
comparison
equal deleted inserted replaced
5325:47298dcf2e8f 5326:60ba780f9078
1677 'setq 'psetq) 1677 'setq 'psetq)
1678 (apply 'append sets))))))) 1678 (apply 'append sets)))))))
1679 (or (cdr endtest) '(nil))))) 1679 (or (cdr endtest) '(nil)))))
1680 1680
1681 ;;;###autoload 1681 ;;;###autoload
1682 (defmacro dolist (spec &rest body) 1682 (defmacro* dolist ((var list &optional result) &body body)
1683 "Loop over a list. 1683 "Loop over a list.
1684 Evaluate BODY with VAR bound to each `car' from LIST, in turn. 1684 Evaluate BODY with VAR bound to each `car' from LIST, in turn.
1685 Then evaluate RESULT to get return value, default nil. 1685 Then evaluate RESULT to get return value, default nil."
1686 1686 (let ((gensym (gensym)))
1687 arguments: ((VAR LIST &optional RESULT) &body BODY)" 1687 `(block nil
1688 (let ((temp (gensym "--dolist-temp--"))) 1688 (let ((,gensym ,list) ,var)
1689 (list 'block nil 1689 (while ,gensym
1690 (list* 'let (list (list temp (nth 1 spec)) (car spec)) 1690 (setq ,var (car ,gensym))
1691 (list* 'while temp (list 'setq (car spec) (list 'car temp)) 1691 ,@body
1692 (append body (list (list 'setq temp 1692 (setq ,gensym (cdr ,gensym)))
1693 (list 'cdr temp))))) 1693 ,@(if result `((setq ,var nil) ,result))))))
1694 (if (cdr (cdr spec)) 1694
1695 (cons (list 'setq (car spec) nil) (cdr (cdr spec))) 1695 ;;;###autoload
1696 '(nil)))))) 1696 (defmacro* dotimes ((var count &optional result) &body body)
1697
1698 ;;;###autoload
1699 (defmacro dotimes (spec &rest body)
1700 "Loop a certain number of times. 1697 "Loop a certain number of times.
1701 Evaluate BODY with VAR bound to successive integers from 0, inclusive, 1698 Evaluate BODY with VAR bound to successive integers from 0, inclusive,
1702 to COUNT, exclusive. Then evaluate RESULT to get return value, default 1699 to COUNT, exclusive. Then evaluate RESULT to get return value, default
1703 nil. 1700 nil."
1704 1701 (let* ((limit (if (cl-const-expr-p count) count (gensym)))
1705 arguments: ((VAR COUNT &optional RESULT) &body BODY)" 1702 (bind (if (cl-const-expr-p count) nil `((,limit ,count)))))
1706 (let ((temp (gensym "--dotimes-temp--"))) 1703 `(block nil
1707 (list 'block nil 1704 (let ((,var 0) ,@bind)
1708 (list* 'let (list (list temp (nth 1 spec)) (list (car spec) 0)) 1705 (while (< ,var ,limit)
1709 (list* 'while (list '< (car spec) temp) 1706 ,@body
1710 (append body (list (list 'incf (car spec))))) 1707 (setq ,var (1+ ,var)))
1711 (or (cdr (cdr spec)) '(nil)))))) 1708 ,@(if result (list result))))))
1712 1709
1713 ;;;###autoload 1710 ;;;###autoload
1714 (defmacro do-symbols (spec &rest body) 1711 (defmacro* do-symbols ((var &optional obarray result) &rest body)
1715 "Loop over all symbols. 1712 "Loop over all interned symbols.
1716 Evaluate BODY with VAR bound to each interned symbol, or to each symbol 1713 Evaluate BODY with VAR bound to each interned symbol, or to each symbol
1717 from OBARRAY. 1714 from OBARRAY."
1718 1715 `(block nil
1719 arguments: ((VAR &optional OBARRAY RESULT) &body BODY)" 1716 (mapatoms #'(lambda (,var) ,@body) ,@(and obarray (list obarray)))
1720 ;; Apparently this doesn't have an implicit block. 1717 ,@(if result `((let (,var) ,result)))))
1721 (list 'block nil
1722 (list 'let (list (car spec))
1723 (list* 'mapatoms
1724 (list 'function (list* 'lambda (list (car spec)) body))
1725 (and (cadr spec) (list (cadr spec))))
1726 (caddr spec))))
1727 1718
1728 ;;;###autoload 1719 ;;;###autoload
1729 (defmacro do-all-symbols (spec &rest body) 1720 (defmacro do-all-symbols (spec &rest body)
1730 (list* 'do-symbols (list (car spec) nil (cadr spec)) body)) 1721 (list* 'do-symbols (list (car spec) nil (cadr spec)) body))
1731 1722
1804 cl-macro-environment))) 1795 cl-macro-environment)))
1805 1796
1806 ;; The following ought to have a better definition for use with newer 1797 ;; The following ought to have a better definition for use with newer
1807 ;; byte compilers. 1798 ;; byte compilers.
1808 ;;;###autoload 1799 ;;;###autoload
1809 (defmacro macrolet (bindings &rest body) 1800 (defmacro* macrolet (((name arglist &optional docstring &body body)
1801 &rest macros) &body form)
1810 "Make temporary macro definitions. 1802 "Make temporary macro definitions.
1811 This is like `flet', but for macros instead of functions. 1803 This is like `flet', but for macros instead of functions."
1812 1804 (cl-macroexpand-all (cons 'progn form)
1813 arguments: (((NAME ARGLIST &optional DOCSTRING &body body) &rest MACROS) &body FORM)" 1805 (nconc
1814 (if (cdr bindings) 1806 (loop
1815 (list 'macrolet 1807 for (name . details)
1816 (list (car bindings)) (list* 'macrolet (cdr bindings) body)) 1808 in (cons (list* name arglist docstring body) macros)
1817 (if (null bindings) (cons 'progn body) 1809 collect
1818 (let* ((name (caar bindings)) 1810 (list* name 'lambda
1819 (res (cl-transform-lambda (cdar bindings) name))) 1811 (prog1
1820 (eval (car res)) 1812 (cdr (setq details (cl-transform-lambda
1821 (cl-macroexpand-all (cons 'progn body) 1813 details name)))
1822 (cons (list* name 'lambda (cdr res)) 1814 (eval (car details)))))
1823 cl-macro-environment)))))) 1815 cl-macro-environment)))
1824 1816
1825 ;;;###autoload 1817 ;;;###autoload
1826 (defmacro symbol-macrolet (bindings &rest body) 1818 (defmacro* symbol-macrolet (((name expansion) &rest symbol-macros) &body form)
1827 "Make symbol macro definitions. 1819 "Make symbol macro definitions.
1828 Within the body FORMs, references to the variable NAME will be replaced 1820 Within the body FORMs, references to the variable NAME will be replaced
1829 by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). 1821 by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...)."
1830 1822 (cl-macroexpand-all (cons 'progn form)
1831 arguments: (((NAME EXPANSION) &rest SYMBOL-MACROS) &body FORM)" 1823 (append (list (list (symbol-name name) expansion))
1832 (if (cdr bindings) 1824 (loop
1833 (list 'symbol-macrolet 1825 for (name expansion) in symbol-macros
1834 (list (car bindings)) (list* 'symbol-macrolet (cdr bindings) body)) 1826 collect (list (symbol-name name) expansion))
1835 (if (null bindings) (cons 'progn body) 1827 cl-macro-environment)))
1836 (cl-macroexpand-all (cons 'progn body)
1837 (cons (list (symbol-name (caar bindings))
1838 (cadar bindings))
1839 cl-macro-environment)))))
1840 1828
1841 (defvar cl-closure-vars nil) 1829 (defvar cl-closure-vars nil)
1842 ;;;###autoload 1830 ;;;###autoload
1843 (defmacro lexical-let (bindings &rest body) 1831 (defmacro lexical-let (bindings &rest body)
1844 "Like `let', but lexically scoped. 1832 "Like `let', but lexically scoped.