Mercurial > hg > xemacs-beta

comparison lisp/cl-macs.el @ 398:74fd4e045ea6 r21-2-29

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-29
author cvs
date Mon, 13 Aug 2007 11:13:30 +0200
parents aabb7f5b1c81
children 2f8bb876ab1d
comparison
equal deleted inserted replaced
397:f4aeb21a5bad 398:74fd4e045ea6
1645 (defsetf documentation-property put) 1645 (defsetf documentation-property put)
1646 (defsetf extent-face set-extent-face) 1646 (defsetf extent-face set-extent-face)
1647 (defsetf extent-priority set-extent-priority) 1647 (defsetf extent-priority set-extent-priority)
1648 (defsetf extent-property (x y &optional ignored-arg) (arg) 1648 (defsetf extent-property (x y &optional ignored-arg) (arg)
1649 (list 'set-extent-property x y arg)) 1649 (list 'set-extent-property x y arg))
1650 (defsetf extent-start-position (ext) (store)
1651 `(progn (set-extent-endpoints ,ext ,store (extent-end-position ,ext))
1652 ,store))
1650 (defsetf extent-end-position (ext) (store) 1653 (defsetf extent-end-position (ext) (store)
1651 (list 'progn (list 'set-extent-endpoints (list 'extent-start-position ext) 1654 `(progn (set-extent-endpoints ,ext (extent-start-position ,ext) ,store)
1652 store) store)) 1655 ,store))
1653 (defsetf extent-start-position (ext) (store)
1654 (list 'progn (list 'set-extent-endpoints store
1655 (list 'extent-end-position ext)) store))
1656 (defsetf face-background (f &optional s) (x) (list 'set-face-background f x s)) 1656 (defsetf face-background (f &optional s) (x) (list 'set-face-background f x s))
1657 (defsetf face-background-pixmap (f &optional s) (x) 1657 (defsetf face-background-pixmap (f &optional s) (x)
1658 (list 'set-face-background-pixmap f x s)) 1658 (list 'set-face-background-pixmap f x s))
1659 (defsetf face-font (f &optional s) (x) (list 'set-face-font f x s)) 1659 (defsetf face-font (f &optional s) (x) (list 'set-face-font f x s))
1660 (defsetf face-foreground (f &optional s) (x) (list 'set-face-foreground f x s)) 1660 (defsetf face-foreground (f &optional s) (x) (list 'set-face-foreground f x s))
2742 (form (car args))) 2742 (form (car args)))
2743 (while (setq args (cdr args)) 2743 (while (setq args (cdr args))
2744 (setq form (list 'cons (car args) form))) 2744 (setq form (list 'cons (car args) form)))
2745 form)) 2745 form))
2746 2746
2747 (define-compiler-macro get* (sym prop &optional def) 2747 (define-compiler-macro get* (sym prop &optional default)
2748 (if def 2748 (list 'get sym prop default))
2749 (list 'getf (list 'symbol-plist sym) prop def) 2749
2750 (list 'get sym prop))) 2750 (define-compiler-macro getf (sym prop &optional default)
2751 (list 'plist-get sym prop default))
2751 2752
2752 (define-compiler-macro typep (&whole form val type) 2753 (define-compiler-macro typep (&whole form val type)
2753 (if (cl-const-expr-p type) 2754 (if (cl-const-expr-p type)
2754 (let ((res (cl-make-type-test val (cl-const-expr-val type)))) 2755 (let ((res (cl-make-type-test val (cl-const-expr-val type))))
2755 (if (or (memq (cl-expr-contains res val) '(nil 1)) 2756 (if (or (memq (cl-expr-contains res val) '(nil 1))
2793 ;;; Things that are side-effect-free. Moved to byte-optimize.el 2794 ;;; Things that are side-effect-free. Moved to byte-optimize.el
2794 ;(dolist (fun '(oddp evenp plusp minusp 2795 ;(dolist (fun '(oddp evenp plusp minusp
2795 ; abs expt signum last butlast ldiff 2796 ; abs expt signum last butlast ldiff
2796 ; pairlis gcd lcm 2797 ; pairlis gcd lcm
2797 ; isqrt floor* ceiling* truncate* round* mod* rem* subseq 2798 ; isqrt floor* ceiling* truncate* round* mod* rem* subseq
2798 ; list-length get* getf)) 2799 ; list-length getf))
2799 ; (put fun 'side-effect-free t)) 2800 ; (put fun 'side-effect-free t))
2800 2801
2801 ;;; Things that are side-effect-and-error-free. Moved to byte-optimize.el 2802 ;;; Things that are side-effect-and-error-free. Moved to byte-optimize.el
2802 ;(dolist (fun '(eql floatp-safe list* subst acons equalp random-state-p 2803 ;(dolist (fun '(eql floatp-safe list* subst acons equalp random-state-p
2803 ; copy-tree sublis)) 2804 ; copy-tree sublis))