Mercurial > hg > xemacs-beta

comparison lisp/cl-macs.el @ 412:697ef44129c6 r21-2-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-14
author cvs
date Mon, 13 Aug 2007 11:20:41 +0200
parents de805c49cfc1
children 11054d720c21
comparison
equal deleted inserted replaced
411:12e008d41344 412:697ef44129c6
79 (or (fboundp 'cl-transform-function-property) 79 (or (fboundp 'cl-transform-function-property)
80 (defalias 'cl-transform-function-property 80 (defalias 'cl-transform-function-property
81 #'(lambda (n p f) 81 #'(lambda (n p f)
82 (list 'put (list 'quote n) (list 'quote p) 82 (list 'put (list 'quote n) (list 'quote p)
83 (list 'function (cons 'lambda f)))))) 83 (list 'function (cons 'lambda f))))))
84 'xemacs)) 84 (car (or features (setq features (list 'cl-kludge))))))
85 85
86 86
87 ;;; Initialization. 87 ;;; Initialization.
88 88
89 (defvar cl-old-bc-file-form nil) 89 (defvar cl-old-bc-file-form nil)
102 (if (eq (car-safe form) 'progn) 102 (if (eq (car-safe form) 'progn)
103 (cons 'progn (mapcar 'byte-compile-file-form (cdr form))) 103 (cons 'progn (mapcar 'byte-compile-file-form (cdr form)))
104 (funcall cl-old-bc-file-form form))))) 104 (funcall cl-old-bc-file-form form)))))
105 (put 'eql 'byte-compile 'cl-byte-compile-compiler-macro) 105 (put 'eql 'byte-compile 'cl-byte-compile-compiler-macro)
106 (run-hooks 'cl-hack-bytecomp-hook)) 106 (run-hooks 'cl-hack-bytecomp-hook))
107
108
109 ;;; Symbols.
110
111 (defvar *gensym-counter*)
112
113 ;;;###autoload
114 (defun gensym (&optional arg)
115 "Generate a new uninterned symbol.
116 The name is made by appending a number to PREFIX, default \"G\"."
117 (let ((prefix (if (stringp arg) arg "G"))
118 (num (if (integerp arg) arg
119 (prog1 *gensym-counter*
120 (setq *gensym-counter* (1+ *gensym-counter*))))))
121 (make-symbol (format "%s%d" prefix num))))
122
123 ;;;###autoload
124 (defun gentemp (&optional arg)
125 "Generate a new interned symbol with a unique name.
126 The name is made by appending a number to PREFIX, default \"G\"."
127 (let ((prefix (if (stringp arg) arg "G"))
128 name)
129 (while (intern-soft (setq name (format "%s%d" prefix *gensym-counter*)))
130 (setq *gensym-counter* (1+ *gensym-counter*)))
131 (intern name)))
107 132
108 133
109 ;;; Program structure. 134 ;;; Program structure.
110 135
111 ;;;###autoload 136 ;;;###autoload
1620 (defsetf documentation-property put) 1645 (defsetf documentation-property put)
1621 (defsetf extent-face set-extent-face) 1646 (defsetf extent-face set-extent-face)
1622 (defsetf extent-priority set-extent-priority) 1647 (defsetf extent-priority set-extent-priority)
1623 (defsetf extent-property (x y &optional ignored-arg) (arg) 1648 (defsetf extent-property (x y &optional ignored-arg) (arg)
1624 (list 'set-extent-property x y arg)) 1649 (list 'set-extent-property x y arg))
1650 (defsetf extent-end-position (ext) (store)
1651 (list 'progn (list 'set-extent-endpoints (list 'extent-start-position ext)
1652 store) store))
1625 (defsetf extent-start-position (ext) (store) 1653 (defsetf extent-start-position (ext) (store)
1626 `(progn (set-extent-endpoints ,ext ,store (extent-end-position ,ext)) 1654 (list 'progn (list 'set-extent-endpoints store
1627 ,store)) 1655 (list 'extent-end-position ext)) store))
1628 (defsetf extent-end-position (ext) (store)
1629 `(progn (set-extent-endpoints ,ext (extent-start-position ,ext) ,store)
1630 ,store))
1631 (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))
1632 (defsetf face-background-pixmap (f &optional s) (x) 1657 (defsetf face-background-pixmap (f &optional s) (x)
1633 (list 'set-face-background-pixmap f x s)) 1658 (list 'set-face-background-pixmap f x s))
1634 (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))
1635 (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))
2717 (form (car args))) 2742 (form (car args)))
2718 (while (setq args (cdr args)) 2743 (while (setq args (cdr args))
2719 (setq form (list 'cons (car args) form))) 2744 (setq form (list 'cons (car args) form)))
2720 form)) 2745 form))
2721 2746
2722 (define-compiler-macro get* (sym prop &optional default) 2747 (define-compiler-macro get* (sym prop &optional def)
2723 (list 'get sym prop default)) 2748 (if def
2724 2749 (list 'getf (list 'symbol-plist sym) prop def)
2725 (define-compiler-macro getf (sym prop &optional default) 2750 (list 'get sym prop)))
2726 (list 'plist-get sym prop default))
2727 2751
2728 (define-compiler-macro typep (&whole form val type) 2752 (define-compiler-macro typep (&whole form val type)
2729 (if (cl-const-expr-p type) 2753 (if (cl-const-expr-p type)
2730 (let ((res (cl-make-type-test val (cl-const-expr-val type)))) 2754 (let ((res (cl-make-type-test val (cl-const-expr-val type))))
2731 (if (or (memq (cl-expr-contains res val) '(nil 1)) 2755 (if (or (memq (cl-expr-contains res val) '(nil 1))
2769 ;;; Things that are side-effect-free. Moved to byte-optimize.el 2793 ;;; Things that are side-effect-free. Moved to byte-optimize.el
2770 ;(dolist (fun '(oddp evenp plusp minusp 2794 ;(dolist (fun '(oddp evenp plusp minusp
2771 ; abs expt signum last butlast ldiff 2795 ; abs expt signum last butlast ldiff
2772 ; pairlis gcd lcm 2796 ; pairlis gcd lcm
2773 ; isqrt floor* ceiling* truncate* round* mod* rem* subseq 2797 ; isqrt floor* ceiling* truncate* round* mod* rem* subseq
2774 ; list-length getf)) 2798 ; list-length get* getf))
2775 ; (put fun 'side-effect-free t)) 2799 ; (put fun 'side-effect-free t))
2776 2800
2777 ;;; Things that are side-effect-and-error-free. Moved to byte-optimize.el 2801 ;;; Things that are side-effect-and-error-free. Moved to byte-optimize.el
2778 ;(dolist (fun '(eql floatp-safe list* subst acons equalp random-state-p 2802 ;(dolist (fun '(eql floatp-safe list* subst acons equalp random-state-p
2779 ; copy-tree sublis)) 2803 ; copy-tree sublis))