Mercurial > hg > xemacs-beta

comparison lisp/cl-macs.el @ 5448:89331fa1c819

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merged with trunk.
author Mats Lidell <matsl@xemacs.org>
date Thu, 06 Jan 2011 00:35:22 +0100
parents 6506fcb40fcf 7b391d07b334
children a9094f28f9a9
comparison
equal deleted inserted replaced
5447:4b08f375e2fb 5448:89331fa1c819
1675 'setq 'psetq) 1675 'setq 'psetq)
1676 (apply 'append sets))))))) 1676 (apply 'append sets)))))))
1677 (or (cdr endtest) '(nil))))) 1677 (or (cdr endtest) '(nil)))))
1678 1678
1679 ;;;###autoload 1679 ;;;###autoload
1680 (defmacro dolist (spec &rest body) 1680 (defmacro* dolist ((var list &optional result) &body body)
1681 "Loop over a list. 1681 "Loop over a list.
1682 Evaluate BODY with VAR bound to each `car' from LIST, in turn. 1682 Evaluate BODY with VAR bound to each `car' from LIST, in turn.
1683 Then evaluate RESULT to get return value, default nil. 1683 Then evaluate RESULT to get return value, default nil."
1684 1684 (let ((gensym (gensym)))
1685 arguments: ((VAR LIST &optional RESULT) &body BODY)" 1685 `(block nil
1686 (let ((temp (gensym "--dolist-temp--"))) 1686 (let ((,gensym ,list) ,var)
1687 (list 'block nil 1687 (while ,gensym
1688 (list* 'let (list (list temp (nth 1 spec)) (car spec)) 1688 (setq ,var (car ,gensym))
1689 (list* 'while temp (list 'setq (car spec) (list 'car temp)) 1689 ,@body
1690 (append body (list (list 'setq temp 1690 (setq ,gensym (cdr ,gensym)))
1691 (list 'cdr temp))))) 1691 ,@(if result `((setq ,var nil) ,result))))))
1692 (if (cdr (cdr spec)) 1692
1693 (cons (list 'setq (car spec) nil) (cdr (cdr spec))) 1693 ;;;###autoload
1694 '(nil)))))) 1694 (defmacro* dotimes ((var count &optional result) &body body)
1695
1696 ;;;###autoload
1697 (defmacro dotimes (spec &rest body)
1698 "Loop a certain number of times. 1695 "Loop a certain number of times.
1699 Evaluate BODY with VAR bound to successive integers from 0, inclusive, 1696 Evaluate BODY with VAR bound to successive integers from 0, inclusive,
1700 to COUNT, exclusive. Then evaluate RESULT to get return value, default 1697 to COUNT, exclusive. Then evaluate RESULT to get return value, default
1701 nil. 1698 nil."
1702 1699 (let* ((limit (if (cl-const-expr-p count) count (gensym)))
1703 arguments: ((VAR COUNT &optional RESULT) &body BODY)" 1700 (bind (if (cl-const-expr-p count) nil `((,limit ,count)))))
1704 (let ((temp (gensym "--dotimes-temp--"))) 1701 `(block nil
1705 (list 'block nil 1702 (let ((,var 0) ,@bind)
1706 (list* 'let (list (list temp (nth 1 spec)) (list (car spec) 0)) 1703 (while (< ,var ,limit)
1707 (list* 'while (list '< (car spec) temp) 1704 ,@body
1708 (append body (list (list 'incf (car spec))))) 1705 (setq ,var (1+ ,var)))
1709 (or (cdr (cdr spec)) '(nil)))))) 1706 ,@(if result (list result))))))
1710 1707
1711 ;;;###autoload 1708 ;;;###autoload
1712 (defmacro do-symbols (spec &rest body) 1709 (defmacro* do-symbols ((var &optional obarray result) &rest body)
1713 "Loop over all symbols. 1710 "Loop over all interned symbols.
1714 Evaluate BODY with VAR bound to each interned symbol, or to each symbol 1711 Evaluate BODY with VAR bound to each interned symbol, or to each symbol
1715 from OBARRAY. 1712 from OBARRAY."
1716 1713 `(block nil
1717 arguments: ((VAR &optional OBARRAY RESULT) &body BODY)" 1714 (mapatoms #'(lambda (,var) ,@body) ,@(and obarray (list obarray)))
1718 ;; Apparently this doesn't have an implicit block. 1715 ,@(if result `((let (,var) ,result)))))
1719 (list 'block nil
1720 (list 'let (list (car spec))
1721 (list* 'mapatoms
1722 (list 'function (list* 'lambda (list (car spec)) body))
1723 (and (cadr spec) (list (cadr spec))))
1724 (caddr spec))))
1725 1716
1726 ;;;###autoload 1717 ;;;###autoload
1727 (defmacro do-all-symbols (spec &rest body) 1718 (defmacro do-all-symbols (spec &rest body)
1728 (list* 'do-symbols (list (car spec) nil (cadr spec)) body)) 1719 (list* 'do-symbols (list (car spec) nil (cadr spec)) body))
1729 1720
1802 cl-macro-environment))) 1793 cl-macro-environment)))
1803 1794
1804 ;; The following ought to have a better definition for use with newer 1795 ;; The following ought to have a better definition for use with newer
1805 ;; byte compilers. 1796 ;; byte compilers.
1806 ;;;###autoload 1797 ;;;###autoload
1807 (defmacro macrolet (bindings &rest body) 1798 (defmacro* macrolet (((name arglist &optional docstring &body body)
1799 &rest macros) &body form)
1808 "Make temporary macro definitions. 1800 "Make temporary macro definitions.
1809 This is like `flet', but for macros instead of functions. 1801 This is like `flet', but for macros instead of functions."
1810 1802 (cl-macroexpand-all (cons 'progn form)
1811 arguments: (((NAME ARGLIST &optional DOCSTRING &body body) &rest MACROS) &body FORM)" 1803 (nconc
1812 (if (cdr bindings) 1804 (loop
1813 (list 'macrolet 1805 for (name . details)
1814 (list (car bindings)) (list* 'macrolet (cdr bindings) body)) 1806 in (cons (list* name arglist docstring body) macros)
1815 (if (null bindings) (cons 'progn body) 1807 collect
1816 (let* ((name (caar bindings)) 1808 (list* name 'lambda
1817 (res (cl-transform-lambda (cdar bindings) name))) 1809 (prog1
1818 (eval (car res)) 1810 (cdr (setq details (cl-transform-lambda
1819 (cl-macroexpand-all (cons 'progn body) 1811 details name)))
1820 (cons (list* name 'lambda (cdr res)) 1812 (eval (car details)))))
1821 cl-macro-environment)))))) 1813 cl-macro-environment)))
1822 1814
1823 ;;;###autoload 1815 ;;;###autoload
1824 (defmacro symbol-macrolet (bindings &rest body) 1816 (defmacro* symbol-macrolet (((name expansion) &rest symbol-macros) &body form)
1825 "Make symbol macro definitions. 1817 "Make symbol macro definitions.
1826 Within the body FORMs, references to the variable NAME will be replaced 1818 Within the body FORMs, references to the variable NAME will be replaced
1827 by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). 1819 by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...)."
1828 1820 (cl-macroexpand-all (cons 'progn form)
1829 arguments: (((NAME EXPANSION) &rest SYMBOL-MACROS) &body FORM)" 1821 (append (list (list (symbol-name name) expansion))
1830 (if (cdr bindings) 1822 (loop
1831 (list 'symbol-macrolet 1823 for (name expansion) in symbol-macros
1832 (list (car bindings)) (list* 'symbol-macrolet (cdr bindings) body)) 1824 collect (list (symbol-name name) expansion))
1833 (if (null bindings) (cons 'progn body) 1825 cl-macro-environment)))
1834 (cl-macroexpand-all (cons 'progn body)
1835 (cons (list (symbol-name (caar bindings))
1836 (cadar bindings))
1837 cl-macro-environment)))))
1838 1826
1839 (defvar cl-closure-vars nil) 1827 (defvar cl-closure-vars nil)
1840 ;;;###autoload 1828 ;;;###autoload
1841 (defmacro lexical-let (bindings &rest body) 1829 (defmacro lexical-let (bindings &rest body)
1842 "Like `let', but lexically scoped. 1830 "Like `let', but lexically scoped.
3291 (list* 3279 (list*
3292 'progn 3280 'progn
3293 (mapcar 3281 (mapcar
3294 (function* 3282 (function*
3295 (lambda ((star-function eq-function equal-function)) 3283 (lambda ((star-function eq-function equal-function))
3296 `(define-compiler-macro ,star-function (&whole form item list 3284 `(define-compiler-macro ,star-function (&whole form &rest keys)
3297 &rest keys) 3285 (if (< (length form) 3)
3298 (condition-case nil 3286 form
3299 (symbol-macrolet ((not-constant '#:not-constant)) 3287 (condition-case nil
3300 (let* ((test-expr (plist-get keys :test ''eql)) 3288 (symbol-macrolet ((not-constant '#:not-constant))
3301 (test (cl-const-expr-val test-expr not-constant)) 3289 (let* ((item (pop keys))
3302 (item-val (cl-const-expr-val item not-constant)) 3290 (list (pop keys))
3303 (list-val (cl-const-expr-val list not-constant))) 3291 (test-expr (plist-get keys :test ''eql))
3304 (if (and keys 3292 (test (cl-const-expr-val test-expr not-constant))
3305 (not (and (eq :test (car keys)) 3293 (item-val (cl-const-expr-val item not-constant))
3306 (eql 2 (length keys))))) 3294 (list-val (cl-const-expr-val list not-constant)))
3307 form 3295 (if (and keys (not (and (eq :test (car keys))
3308 (cond ((eq test 'eq) `(,',eq-function ,item ,list)) 3296 (eql 2 (length keys)))))
3309 ((eq test 'equal) 3297 form
3310 `(,',equal-function ,item ,list)) 3298 (cond ((eq test 'eq) `(,',eq-function ,item ,list))
3311 ((and (eq test 'eql) 3299 ((eq test 'equal)
3312 (not (eq not-constant item-val))) 3300 `(,',equal-function ,item ,list))
3313 (if (cl-non-fixnum-number-p item-val) 3301 ((and (eq test 'eql)
3314 `(,',equal-function ,item ,list) 3302 (not (eq not-constant item-val)))
3315 `(,',eq-function ,item ,list))) 3303 (if (cl-non-fixnum-number-p item-val)
3316 ((and (eq test 'eql) (not (eq not-constant 3304 `(,',equal-function ,item ,list)
3317 list-val))) 3305 `(,',eq-function ,item ,list)))
3318 (if (some 'cl-non-fixnum-number-p list-val) 3306 ((and (eq test 'eql) (not (eq not-constant
3319 `(,',equal-function ,item ,list) 3307 list-val)))
3320 ;; This compiler macro used to limit calls 3308 (if (some 'cl-non-fixnum-number-p list-val)
3321 ;; to ,,eq-function to lists where all 3309 `(,',equal-function ,item ,list)
3322 ;; elements were either fixnums or 3310 ;; This compiler macro used to limit
3323 ;; symbols. There's no 3311 ;; calls to ,,eq-function to lists where
3324 ;; reason to do this. 3312 ;; all elements were either fixnums or
3325 `(,',eq-function ,item ,list))) 3313 ;; symbols. There's no reason to do this.
3326 ;; This is a hilariously specific case; see 3314 `(,',eq-function ,item ,list)))
3327 ;; add-to-list in subr.el. 3315 ;; This is a hilariously specific case; see
3328 ((and (eq test not-constant) 3316 ;; add-to-list in subr.el.
3329 (eq 'or (car-safe test-expr)) 3317 ((and (eq test not-constant)
3330 (eql 3 (length test-expr)) 3318 (eq 'or (car-safe test-expr))
3331 (every #'cl-safe-expr-p (cdr form)) 3319 (eql 3 (length test-expr))
3332 `(if ,(second test-expr) 3320 (every #'cl-safe-expr-p (cdr form))
3333 (,',star-function ,item ,list :test 3321 `(if ,(second test-expr)
3334 ,(second test-expr)) 3322 (,',star-function ,item ,list :test
3335 (,',star-function 3323 ,(second test-expr))
3336 ,item ,list :test ,(third test-expr))))) 3324 (,',star-function
3337 (t form))))) 3325 ,item ,list :test
3338 ;; No need to warn about a malformed property list, 3326 ,(third test-expr)))))
3339 ;; #'byte-compile-normal-call will do that for us. 3327 (t form)))))
3340 (malformed-property-list form))))) 3328 ;; No need to warn about a malformed property list,
3329 ;; #'byte-compile-normal-call will do that for us.
3330 (malformed-property-list form))))))
3341 macros)))) 3331 macros))))
3342 (define-star-compiler-macros 3332 (define-star-compiler-macros
3343 (member* memq member) 3333 (member* memq member)
3344 (assoc* assq assoc) 3334 (assoc* assq assoc)
3345 (rassoc* rassq rassoc))) 3335 (rassoc* rassq rassoc)))
3744 (if (every #'cl-safe-expr-p (cdr form)) 3734 (if (every #'cl-safe-expr-p (cdr form))
3745 `(funcall (if ,inplace #'nsubstitute #'substitute) ,tochar ,fromchar 3735 `(funcall (if ,inplace #'nsubstitute #'substitute) ,tochar ,fromchar
3746 (the string ,string) :test #'eq) 3736 (the string ,string) :test #'eq)
3747 form)) 3737 form))
3748 3738
3739 (define-compiler-macro stable-union (&whole form &rest cl-keys)
3740 (if (> (length form) 2)
3741 (list* 'union (pop cl-keys) (pop cl-keys) :stable t cl-keys)
3742 form))
3743
3744 (define-compiler-macro stable-intersection (&whole form &rest cl-keys)
3745 (if (> (length form) 2)
3746 (list* 'intersection (pop cl-keys) (pop cl-keys) :stable t cl-keys)
3747 form))
3748
3749 (map nil 3749 (map nil
3750 #'(lambda (function) 3750 #'(lambda (function)
3751 ;; There are byte codes for the two-argument versions of these 3751 ;; There are byte codes for the two-argument versions of these
3752 ;; functions; if the form has more arguments and those arguments 3752 ;; functions; if the form has more arguments and those arguments
3753 ;; have no side effects, transform to a series of two-argument 3753 ;; have no side effects, transform to a series of two-argument