code.delx.au - gnu-emacs/blob - lisp/emacs-lisp/lucid.el

   1 (defun add-timeout (secs function object &optional resignal)
   2   (run-at-time secs resignal function object))
   3
   4 (defun disable-timeout (timeout)
   5   (cancel-timer timeout))
   6
   7 (defun copy-tree (tree)
   8   (if (consp tree)
   9       (cons (copy-tree (car tree))
  10             (copy-tree (cdr tree)))
  11     (if (vectorp tree)
  12         (let ((new (copy-sequence tree))
  13               (i (1- (length new))))
  14           (while (>= i 0)
  15             (aset new i (copy-tree (aref new i)))
  16             (setq i (1- i)))
  17           new)
  18       tree)))
  19
  20 (fset 'current-time-seconds 'current-time)
  21
  22 (defun keymap-parent (keymap)
  23   (let ((tail (cdr keymap)))
  24     (while (and tail (not (eq (car tail) 'keymap)))
  25       (setq tail (cdr tail)))
  26     tail))
  27
  28 (defun set-keymap-parent (keymap new-parent)
  29   (let ((tail (cdr keymap)))
  30     (while (and tail (cdr tail) (not (eq (car (cdr tail)) 'keymap)))
  31       (setq tail (cdr tail)))
  32     (if tail
  33         (setcdr tail new-parent))))
  34
  35 (defun remove-hook (hook-var function)
  36   (if (boundp 'hook-var)
  37       (set hook-var (delq function (symbol-value hook-var)))))
  38
  39 (defun remprop (symbol prop)
  40   (let ((plist (symbol-plist symbol)))
  41     (while (eq (car plist) prop)
  42       (setplist symbol (setq plist (cdr (cdr plist)))))
  43     (while plist
  44       (if (eq (nth 2 plist) prop)
  45           (setcdr (cdr plist) (nthcdr 4 plist)))
  46       (setq plist (cdr (cdr plist))))))
  47
  48 (defun map-keymap (function keymap &optional sort-first)
  49   "Call FUNCTION for every binding in KEYMAP.
  50 This includes bindings inherited from a parent keymap.
  51 FUNCTION receives two arguments each time it is called:
  52 the character (more generally, the event type) that is bound,
  53 and the binding it has."
  54   (if sort-first
  55       (let (list)
  56         (map-keymap (function (lambda (a b)
  57                                 (setq list (cons (cons a b) list))))
  58                     keymap)
  59         (setq list (sort list
  60                          (function (lambda (a b)
  61                                      (setq a (car a) b (car b))
  62                                      (if (integerp a)
  63                                          (if (integerp b) (< a b)
  64                                            t)
  65                                        (if (integerp b) t
  66                                          (string< a b)))))))
  67         (while list
  68           (funcall function (car (car list)) (cdr (car list)))
  69           (setq list (cdr list))))
  70     (while (consp keymap)
  71       (if (consp (car keymap))
  72           (funcall function (car (car keymap)) (cdr (car keymap)))
  73         (if (vectorp (car keymap))
  74             (let ((i (1- (length (car keymap))))
  75                   (vector (car keymap)))
  76               (while (>= i 0)
  77                 (funcall function i (aref vector i))
  78                 (setq i (1- i))))))
  79       (setq keymap (cdr keymap)))))
  80
  81 (defun real-path-name (name &optional default)
  82   (file-truename (expand-file-name name default)))
  83
  84 ;; It's not clear what to return if the mouse is not in FRAME.
  85 (defun read-mouse-position (frame)
  86   (let ((pos (mouse-position)))
  87     (if (eq (car pos) frame)
  88         (cdr pos))))
  89
  90 (defun switch-to-other-buffer (arg)
  91   "Switch to the previous buffer.
  92 With a numeric arg N, switch to the Nth most recent buffer.
  93 With an arg of 0, buries the current buffer at the
  94 bottom of the buffer stack."
  95   (interactive "p")
  96   (if (eq arg 0)
  97       (bury-buffer (current-buffer)))
  98   (switch-to-buffer
  99    (if (<= arg 1) (other-buffer (current-buffer))
 100      (nth (1+ arg) (buffer-list)))))
 101 \f
 102 ;; Support the Lucid names with `screen' instead of `frame'.
 103
 104 (fset 'current-screen-configuration 'current-frame-configuration)
 105 (fset 'delete-screen 'delete-frame)
 106 (fset 'find-file-new-screen 'find-file-other-frame)
 107 (fset 'find-file-read-only-new-screen 'find-file-read-only-other-frame)
 108 (fset 'find-tag-new-screen 'find-tag-other-frame)
 109 ;;(fset 'focus-screen 'focus-frame)
 110 (fset 'iconify-screen 'iconify-frame)
 111 (fset 'mail-new-screen 'mail-other-frame)
 112 (fset 'make-screen-invisible 'make-frame-invisible)
 113 (fset 'make-screen-visible 'make-frame-visible)
 114 ;; (fset 'minibuffer-screen-list 'minibuffer-frame-list)
 115 (fset 'modify-screen-parameters 'modify-frame-parameters)
 116 (fset 'next-screen 'next-frame)
 117 ;; (fset 'next-multiscreen-window 'next-multiframe-window)
 118 ;; (fset 'previous-multiscreen-window 'previous-multiframe-window)
 119 ;; (fset 'redirect-screen-focus 'redirect-frame-focus)
 120 (fset 'redraw-screen 'redraw-frame)
 121 ;; (fset 'screen-char-height 'frame-char-height)
 122 ;; (fset 'screen-char-width 'frame-char-width)
 123 ;; (fset 'screen-configuration-to-register 'frame-configuration-to-register)
 124 ;; (fset 'screen-focus 'frame-focus)
 125 (fset 'screen-height 'frame-height)
 126 (fset 'screen-list 'frame-list)
 127 ;; (fset 'screen-live-p 'frame-live-p)
 128 (fset 'screen-parameters 'frame-parameters)
 129 (fset 'screen-pixel-height 'frame-pixel-height)
 130 (fset 'screen-pixel-width 'frame-pixel-width)
 131 (fset 'screen-root-window 'frame-root-window)
 132 (fset 'screen-selected-window 'frame-selected-window)
 133 (fset 'lower-screen 'lower-frame)
 134 (fset 'raise-screen 'raise-frame)
 135 (fset 'screen-visible-p 'frame-visible-p)
 136 (fset 'screen-width 'frame-width)
 137 (fset 'screenp 'framep)
 138 (fset 'select-screen 'select-frame)
 139 (fset 'selected-screen 'selected-frame)
 140 ;; (fset 'set-screen-configuration 'set-frame-configuration)
 141 ;; (fset 'set-screen-height 'set-frame-height)
 142 (fset 'set-screen-position 'set-frame-position)
 143 (fset 'set-screen-size 'set-frame-size)
 144 ll (fset 'set-screen-width 'set-frame-width)
 145 (fset 'switch-to-buffer-new-screen 'switch-to-buffer-other-frame)
 146 ;; (fset 'unfocus-screen 'unfocus-frame)
 147 (fset 'visible-screen-list 'visible-frame-list)
 148 (fset 'window-screen 'window-frame)
 149 (fset 'x-create-screen 'x-create-frame)
 150 (fset 'x-new-screen 'new-frame)