Mercurial > hg > xemacs-beta

comparison lisp/cl-macs.el @ 371:cc15677e0335 r21-2b1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2b1
author cvs
date Mon, 13 Aug 2007 11:03:08 +0200
parents a4f53d9b3154
children 6240c7796c7a
comparison
equal deleted inserted replaced
370:bd866891f083 371:cc15677e0335
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 (function (lambda (n p f) 81 (function (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)
896 (list 'function (list* 'lambda (list var other) 896 (list 'function (list* 'lambda (list var other)
897 '--cl-map)) map)))) 897 '--cl-map)) map))))
898 898
899 ((memq word '(frame frames screen screens)) 899 ((memq word '(frame frames screen screens))
900 (let ((temp (gensym))) 900 (let ((temp (gensym)))
901 (cl-push (list var (if (eq cl-emacs-type 'lucid) 901 (cl-push (list var '(selected-frame))
902 '(selected-screen) '(selected-frame)))
903 loop-for-bindings) 902 loop-for-bindings)
904 (cl-push (list temp nil) loop-for-bindings) 903 (cl-push (list temp nil) loop-for-bindings)
905 (cl-push (list 'prog1 (list 'not (list 'eq var temp)) 904 (cl-push (list 'prog1 (list 'not (list 'eq var temp))
906 (list 'or temp (list 'setq temp var))) 905 (list 'or temp (list 'setq temp var)))
907 loop-body) 906 loop-body)
908 (cl-push (list var (list (if (eq cl-emacs-type 'lucid) 907 (cl-push (list var (list 'next-frame var))
909 'next-screen 'next-frame) var))
910 loop-for-steps))) 908 loop-for-steps)))
911 909
912 ((memq word '(window windows)) 910 ((memq word '(window windows))
913 (let ((scr (and (memq (car args) '(in of)) (cl-pop2 args))) 911 (let ((scr (and (memq (car args) '(in of)) (cl-pop2 args)))
914 (temp (gensym))) 912 (temp (gensym)))
915 (cl-push (list var (if scr 913 (cl-push (list var (if scr
916 (list (if (eq cl-emacs-type 'lucid) 914 (list 'frame-selected-window scr)
917 'screen-selected-window
918 'frame-selected-window) scr)
919 '(selected-window))) 915 '(selected-window)))
920 loop-for-bindings) 916 loop-for-bindings)
921 (cl-push (list temp nil) loop-for-bindings) 917 (cl-push (list temp nil) loop-for-bindings)
922 (cl-push (list 'prog1 (list 'not (list 'eq var temp)) 918 (cl-push (list 'prog1 (list 'not (list 'eq var temp))
923 (list 'or temp (list 'setq temp var))) 919 (list 'or temp (list 'setq temp var)))
1449 (defun cl-do-proclaim (spec hist) 1445 (defun cl-do-proclaim (spec hist)
1450 (and hist (listp cl-proclaim-history) (cl-push spec cl-proclaim-history)) 1446 (and hist (listp cl-proclaim-history) (cl-push spec cl-proclaim-history))
1451 (cond ((eq (car-safe spec) 'special) 1447 (cond ((eq (car-safe spec) 'special)
1452 (if (boundp 'byte-compile-bound-variables) 1448 (if (boundp 'byte-compile-bound-variables)
1453 (setq byte-compile-bound-variables 1449 (setq byte-compile-bound-variables
1454 (append 1450 ;; todo: this should compute correct binding bits vs. 0
1455 (mapcar #'(lambda (v) (cons v byte-compile-global-bit)) 1451 (append (mapcar #'(lambda (v) (cons v 0))
1456 (cdr spec)) 1452 (cdr spec))
1457 byte-compile-bound-variables)))) 1453 byte-compile-bound-variables))))
1458 1454
1459 ((eq (car-safe spec) 'inline) 1455 ((eq (car-safe spec) 'inline)
1460 (while (setq spec (cdr spec)) 1456 (while (setq spec (cdr spec))
1461 (or (memq (get (car spec) 'byte-optimizer) 1457 (or (memq (get (car spec) 'byte-optimizer)
1462 '(nil byte-compile-inline-expand)) 1458 '(nil byte-compile-inline-expand))
1653 (defsetf current-local-map use-local-map t) 1649 (defsetf current-local-map use-local-map t)
1654 (defsetf current-window-configuration set-window-configuration t) 1650 (defsetf current-window-configuration set-window-configuration t)
1655 (defsetf default-file-modes set-default-file-modes t) 1651 (defsetf default-file-modes set-default-file-modes t)
1656 (defsetf default-value set-default) 1652 (defsetf default-value set-default)
1657 (defsetf documentation-property put) 1653 (defsetf documentation-property put)
1658 (defsetf extent-data set-extent-data) ; obsolete
1659 (defsetf extent-face set-extent-face) 1654 (defsetf extent-face set-extent-face)
1660 (defsetf extent-priority set-extent-priority) 1655 (defsetf extent-priority set-extent-priority)
1661 (defsetf extent-property (x y &optional d) (arg) 1656 (defsetf extent-property (x y &optional d) (arg)
1662 (list 'set-extent-property x y arg)) 1657 (list 'set-extent-property x y arg))
1658 (defsetf extent-end-position (ext) (store)
1659 (list 'progn (list 'set-extent-endpoints (list 'extent-start-position ext)
1660 store) store))
1663 (defsetf extent-start-position (ext) (store) 1661 (defsetf extent-start-position (ext) (store)
1664 `(progn (set-extent-endpoints ,ext ,store (extent-end-position ,ext)) 1662 (list 'progn (list 'set-extent-endpoints store
1665 ,store)) 1663 (list 'extent-end-position ext)) store))
1666 (defsetf extent-end-position (ext) (store)
1667 `(progn (set-extent-endpoints ,ext (extent-start-position ,ext) ,store)
1668 ,store))
1669 (defsetf face-background (f &optional s) (x) (list 'set-face-background f x s)) 1664 (defsetf face-background (f &optional s) (x) (list 'set-face-background f x s))
1670 (defsetf face-background-pixmap (f &optional s) (x) 1665 (defsetf face-background-pixmap (f &optional s) (x)
1671 (list 'set-face-background-pixmap f x s)) 1666 (list 'set-face-background-pixmap f x s))
1672 (defsetf face-font (f &optional s) (x) (list 'set-face-font f x s)) 1667 (defsetf face-font (f &optional s) (x) (list 'set-face-font f x s))
1673 (defsetf face-foreground (f &optional s) (x) (list 'set-face-foreground f x s)) 1668 (defsetf face-foreground (f &optional s) (x) (list 'set-face-foreground f x s))
1734 (defsetf extent-parent set-extent-parent) 1729 (defsetf extent-parent set-extent-parent)
1735 (defsetf extent-properties set-extent-properties) 1730 (defsetf extent-properties set-extent-properties)
1736 ;; Avoid adding various face and glyph functions. 1731 ;; Avoid adding various face and glyph functions.
1737 (defsetf frame-selected-window (&optional f) (v) 1732 (defsetf frame-selected-window (&optional f) (v)
1738 `(set-frame-selected-window ,f ,v)) 1733 `(set-frame-selected-window ,f ,v))
1739 (defsetf glyph-image (glyph &optional domain) (i)
1740 (list 'set-glyph-image glyph i domain))
1741 (defsetf itimer-function set-itimer-function) 1734 (defsetf itimer-function set-itimer-function)
1742 (defsetf itimer-function-arguments set-itimer-function-arguments) 1735 (defsetf itimer-function-arguments set-itimer-function-arguments)
1743 (defsetf itimer-is-idle set-itimer-is-idle) 1736 (defsetf itimer-is-idle set-itimer-is-idle)
1744 (defsetf itimer-recorded-run-time set-itimer-recorded-run-time) 1737 (defsetf itimer-recorded-run-time set-itimer-recorded-run-time)
1745 (defsetf itimer-restart set-itimer-restart) 1738 (defsetf itimer-restart set-itimer-restart)
1786 (defsetf process-buffer set-process-buffer) 1779 (defsetf process-buffer set-process-buffer)
1787 (defsetf process-filter set-process-filter) 1780 (defsetf process-filter set-process-filter)
1788 (defsetf process-sentinel set-process-sentinel) 1781 (defsetf process-sentinel set-process-sentinel)
1789 (defsetf read-mouse-position (scr) (store) 1782 (defsetf read-mouse-position (scr) (store)
1790 (list 'set-mouse-position scr (list 'car store) (list 'cdr store))) 1783 (list 'set-mouse-position scr (list 'car store) (list 'cdr store)))
1791 (defsetf screen-height set-screen-height t)
1792 (defsetf screen-width set-screen-width t)
1793 (defsetf selected-window select-window) 1784 (defsetf selected-window select-window)
1794 (defsetf selected-screen select-screen)
1795 (defsetf selected-frame select-frame) 1785 (defsetf selected-frame select-frame)
1796 (defsetf standard-case-table set-standard-case-table) 1786 (defsetf standard-case-table set-standard-case-table)
1797 (defsetf syntax-table set-syntax-table) 1787 (defsetf syntax-table set-syntax-table)
1798 (defsetf visited-file-modtime set-visited-file-modtime t) 1788 (defsetf visited-file-modtime set-visited-file-modtime t)
1799 (defsetf window-buffer set-window-buffer t) 1789 (defsetf window-buffer set-window-buffer t)