Mercurial > hg > xemacs-beta

comparison lisp/cl-macs.el @ 442:abe6d1db359e r21-2-36

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-36
author cvs
date Mon, 13 Aug 2007 11:35:02 +0200
parents 8de8e3f6228a
children 576fb035e263
comparison
equal deleted inserted replaced
441:72a7cfa4a488 442:abe6d1db359e
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 (car (or features (setq features (list 'cl-kludge)))))) 84 'xemacs))
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)))
132 107
133 108
134 ;;; Program structure. 109 ;;; Program structure.
135 110
136 ;;;###autoload 111 ;;;###autoload
1436 (defun cl-do-proclaim (spec hist) 1411 (defun cl-do-proclaim (spec hist)
1437 (and hist (listp cl-proclaim-history) (cl-push spec cl-proclaim-history)) 1412 (and hist (listp cl-proclaim-history) (cl-push spec cl-proclaim-history))
1438 (cond ((eq (car-safe spec) 'special) 1413 (cond ((eq (car-safe spec) 'special)
1439 (if (boundp 'byte-compile-bound-variables) 1414 (if (boundp 'byte-compile-bound-variables)
1440 (setq byte-compile-bound-variables 1415 (setq byte-compile-bound-variables
1441 ;; todo: this should compute correct binding bits vs. 0 1416 (append
1442 (append (mapcar #'(lambda (v) (cons v 0)) 1417 (mapcar #'(lambda (v) (cons v byte-compile-global-bit))
1443 (cdr spec)) 1418 (cdr spec))
1444 byte-compile-bound-variables)))) 1419 byte-compile-bound-variables))))
1445 1420
1446 ((eq (car-safe spec) 'inline) 1421 ((eq (car-safe spec) 'inline)
1447 (while (setq spec (cdr spec)) 1422 (while (setq spec (cdr spec))
1448 (or (memq (get (car spec) 'byte-optimizer) 1423 (or (memq (get (car spec) 'byte-optimizer)
1449 '(nil byte-compile-inline-expand)) 1424 '(nil byte-compile-inline-expand))
1792 `(progn (enlarge-window (- ,store (window-width)) t ,window) ,store)) 1767 `(progn (enlarge-window (- ,store (window-width)) t ,window) ,store))
1793 (defsetf x-get-cutbuffer x-store-cutbuffer t) 1768 (defsetf x-get-cutbuffer x-store-cutbuffer t)
1794 (defsetf x-get-cut-buffer x-store-cut-buffer t) ; groan. 1769 (defsetf x-get-cut-buffer x-store-cut-buffer t) ; groan.
1795 (defsetf x-get-secondary-selection x-own-secondary-selection t) 1770 (defsetf x-get-secondary-selection x-own-secondary-selection t)
1796 (defsetf x-get-selection x-own-selection t) 1771 (defsetf x-get-selection x-own-selection t)
1772 (defsetf get-selection own-selection t)
1797 1773
1798 ;;; More complex setf-methods. 1774 ;;; More complex setf-methods.
1799 ;;; These should take &environment arguments, but since full arglists aren't 1775 ;;; These should take &environment arguments, but since full arglists aren't
1800 ;;; available while compiling cl-macs, we fake it by referring to the global 1776 ;;; available while compiling cl-macs, we fake it by referring to the global
1801 ;;; variable cl-macro-environment directly. 1777 ;;; variable cl-macro-environment directly.
2745 form)) 2721 form))
2746 2722
2747 (define-compiler-macro get* (sym prop &optional default) 2723 (define-compiler-macro get* (sym prop &optional default)
2748 (list 'get sym prop default)) 2724 (list 'get sym prop default))
2749 2725
2726 (define-compiler-macro getf (sym prop &optional default)
2727 (list 'plist-get sym prop default))
2728
2750 (define-compiler-macro typep (&whole form val type) 2729 (define-compiler-macro typep (&whole form val type)
2751 (if (cl-const-expr-p type) 2730 (if (cl-const-expr-p type)
2752 (let ((res (cl-make-type-test val (cl-const-expr-val type)))) 2731 (let ((res (cl-make-type-test val (cl-const-expr-val type))))
2753 (if (or (memq (cl-expr-contains res val) '(nil 1)) 2732 (if (or (memq (cl-expr-contains res val) '(nil 1))
2754 (cl-simple-expr-p val)) res 2733 (cl-simple-expr-p val)) res