diff options
| author | Dan Nicolaescu | 2007-11-01 03:06:23 +0000 |
|---|---|---|
| committer | Dan Nicolaescu | 2007-11-01 03:06:23 +0000 |
| commit | 07e5c0b0b70e308b4dc4ac5b3ee832894f746a81 (patch) | |
| tree | 4749f6371c093acd662f44d98739eb8bcd10a6bc | |
| parent | 88406d6ee8a9108ae8265aac2f023e61f4bff827 (diff) | |
| download | emacs-07e5c0b0b70e308b4dc4ac5b3ee832894f746a81.tar.gz emacs-07e5c0b0b70e308b4dc4ac5b3ee832894f746a81.zip | |
* cmdargs.texi (Misc Variables): Remove Sun windows info.
* MACHINES: Remove Sun windows info.
* term/sun-mouse.el:
* obsolete/sun-fns.el:
* obsolete/sun-curs.el: Remove files.
* term/sun.el (select-previous-complex-command):
* sunfns.c: Remove file
* m/sun386.h:
* m/sun2.h:
* m/sparc.h: Remove Sun windows code.
| -rw-r--r-- | doc/emacs/ChangeLog | 4 | ||||
| -rw-r--r-- | doc/emacs/cmdargs.texi | 3 | ||||
| -rw-r--r-- | etc/ChangeLog | 4 | ||||
| -rw-r--r-- | etc/MACHINES | 11 | ||||
| -rw-r--r-- | etc/NEWS | 2 | ||||
| -rw-r--r-- | lisp/obsolete/sun-curs.el | 234 | ||||
| -rw-r--r-- | lisp/obsolete/sun-fns.el | 644 | ||||
| -rw-r--r-- | lisp/term/sun-mouse.el | 667 | ||||
| -rw-r--r-- | lisp/term/sun.el | 8 | ||||
| -rw-r--r-- | src/ChangeLog | 8 | ||||
| -rw-r--r-- | src/m/sparc.h | 12 | ||||
| -rw-r--r-- | src/m/sun2.h | 12 | ||||
| -rw-r--r-- | src/m/sun386.h | 12 | ||||
| -rw-r--r-- | src/sunfns.c | 519 |
14 files changed, 18 insertions, 2122 deletions
diff --git a/doc/emacs/ChangeLog b/doc/emacs/ChangeLog index 37ee660577a..0f36d30798b 100644 --- a/doc/emacs/ChangeLog +++ b/doc/emacs/ChangeLog | |||
| @@ -1,3 +1,7 @@ | |||
| 1 | 2007-11-01 Dan Nicolaescu <dann@ics.uci.edu> | ||
| 2 | |||
| 3 | * cmdargs.texi (Misc Variables): Remove Sun windows info. | ||
| 4 | |||
| 1 | 2007-10-27 Emanuele Giaquinta <e.giaquinta@glauco.it> (tiny change) | 5 | 2007-10-27 Emanuele Giaquinta <e.giaquinta@glauco.it> (tiny change) |
| 2 | 6 | ||
| 3 | * gnus-faq.texi ([5.12]): Remove reference to discontinued service. | 7 | * gnus-faq.texi ([5.12]): Remove reference to discontinued service. |
diff --git a/doc/emacs/cmdargs.texi b/doc/emacs/cmdargs.texi index 28bad72f0bf..f2f3a85af77 100644 --- a/doc/emacs/cmdargs.texi +++ b/doc/emacs/cmdargs.texi | |||
| @@ -635,9 +635,6 @@ Emacs switches the DOS display to a mode where all 16 colors can be used | |||
| 635 | for the background, so all four bits of the background color are | 635 | for the background, so all four bits of the background color are |
| 636 | actually used. | 636 | actually used. |
| 637 | 637 | ||
| 638 | @item WINDOW_GFX | ||
| 639 | Used when initializing the Sun windows system. | ||
| 640 | |||
| 641 | @item PRELOAD_WINSOCK | 638 | @item PRELOAD_WINSOCK |
| 642 | On MS-Windows, if you set this variable, Emacs will load and initialize | 639 | On MS-Windows, if you set this variable, Emacs will load and initialize |
| 643 | the network library at startup, instead of waiting until the first | 640 | the network library at startup, instead of waiting until the first |
diff --git a/etc/ChangeLog b/etc/ChangeLog index 017db136df7..589e5365474 100644 --- a/etc/ChangeLog +++ b/etc/ChangeLog | |||
| @@ -1,3 +1,7 @@ | |||
| 1 | 2007-11-01 Dan Nicolaescu <dann@ics.uci.edu> | ||
| 2 | |||
| 3 | * MACHINES: Remove Sun windows info. | ||
| 4 | |||
| 1 | 2007-10-30 Michael Olson <mwolson@gnu.org> | 5 | 2007-10-30 Michael Olson <mwolson@gnu.org> |
| 2 | 6 | ||
| 3 | * NEWS: Add entry for Remember Mode. | 7 | * NEWS: Add entry for Remember Mode. |
diff --git a/etc/MACHINES b/etc/MACHINES index a4db1df76c7..9f84d8ac18a 100644 --- a/etc/MACHINES +++ b/etc/MACHINES | |||
| @@ -1158,17 +1158,6 @@ Sun 3, Sun 4 (sparc), Sun 386 (m68k-sun-sunos, sparc-sun-sunos, i386-sun-sunos, | |||
| 1158 | src/s/sunos4-1.h to src/config.h. This problem is due to obsolete | 1158 | src/s/sunos4-1.h to src/config.h. This problem is due to obsolete |
| 1159 | software in the nonshared standard library. | 1159 | software in the nonshared standard library. |
| 1160 | 1160 | ||
| 1161 | If you want to use SunWindows, define HAVE_SUN_WINDOWS | ||
| 1162 | in config.h to enable a special interface called `emacstool'. | ||
| 1163 | The definition must *precede* the #include "machine.h". | ||
| 1164 | System version 3.2 is required for this facility to work. | ||
| 1165 | |||
| 1166 | We recommend that you instead use the X window system, which | ||
| 1167 | has technical advantages, is an industry standard, and is also | ||
| 1168 | free software. The FSF does not support the SunWindows code; | ||
| 1169 | we installed it only on the understanding we would not let it | ||
| 1170 | divert our efforts from what we think is important. | ||
| 1171 | |||
| 1172 | If you are compiling for X windows, and the X window library was | 1161 | If you are compiling for X windows, and the X window library was |
| 1173 | compiled to use the 68881, then you must edit config.h according | 1162 | compiled to use the 68881, then you must edit config.h according |
| 1174 | the comments at the end of `src/m/sun3.h'. | 1163 | the comments at the end of `src/m/sun3.h'. |
| @@ -33,6 +33,8 @@ a GIF library. | |||
| 33 | 33 | ||
| 34 | ** Support for systems without alloca has been removed. | 34 | ** Support for systems without alloca has been removed. |
| 35 | 35 | ||
| 36 | ** Support for Sun windows has been removed. | ||
| 37 | |||
| 36 | ** The `emacstool' utility has been removed. | 38 | ** The `emacstool' utility has been removed. |
| 37 | 39 | ||
| 38 | 40 | ||
diff --git a/lisp/obsolete/sun-curs.el b/lisp/obsolete/sun-curs.el deleted file mode 100644 index 612102159df..00000000000 --- a/lisp/obsolete/sun-curs.el +++ /dev/null | |||
| @@ -1,234 +0,0 @@ | |||
| 1 | ;;; sun-curs.el --- cursor definitions for Sun windows | ||
| 2 | |||
| 3 | ;; Copyright (C) 1987, 2001, 2002, 2003, 2004, 2005, | ||
| 4 | ;; 2006, 2007 Free Software Foundation, Inc. | ||
| 5 | |||
| 6 | ;; Author: Jeff Peck <peck@sun.com> | ||
| 7 | ;; Keywords: hardware | ||
| 8 | |||
| 9 | ;; This file is part of GNU Emacs. | ||
| 10 | |||
| 11 | ;; GNU Emacs is free software; you can redistribute it and/or modify | ||
| 12 | ;; it under the terms of the GNU General Public License as published by | ||
| 13 | ;; the Free Software Foundation; either version 3, or (at your option) | ||
| 14 | ;; any later version. | ||
| 15 | |||
| 16 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 19 | ;; GNU General Public License for more details. | ||
| 20 | |||
| 21 | ;; You should have received a copy of the GNU General Public License | ||
| 22 | ;; along with GNU Emacs; see the file COPYING. If not, write to the | ||
| 23 | ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, | ||
| 24 | ;; Boston, MA 02110-1301, USA. | ||
| 25 | |||
| 26 | ;;; Commentary: | ||
| 27 | |||
| 28 | ;;; Code: | ||
| 29 | |||
| 30 | ;;; | ||
| 31 | ;;; Added some more cursors and moved the hot spots | ||
| 32 | ;;; Cursor defined by 16 pairs of 16-bit numbers | ||
| 33 | ;;; | ||
| 34 | ;;; 9-dec-86 Jeff Peck, Sun Microsystems Inc. <peck@sun.com> | ||
| 35 | |||
| 36 | (eval-when-compile (require 'cl)) | ||
| 37 | |||
| 38 | (defvar *edit-icon*) | ||
| 39 | (defvar char) | ||
| 40 | ;; These are from term/sun-mouse.el | ||
| 41 | (defvar *mouse-window*) | ||
| 42 | (defvar *mouse-x*) | ||
| 43 | (defvar *mouse-y*) | ||
| 44 | (defvar menu) | ||
| 45 | |||
| 46 | (require 'sun-fns) | ||
| 47 | |||
| 48 | (eval-and-compile | ||
| 49 | (defvar sc::cursors nil "List of known cursors")) | ||
| 50 | |||
| 51 | (defmacro defcursor (name x y string) | ||
| 52 | (if (not (memq name sc::cursors)) | ||
| 53 | (setq sc::cursors (cons name sc::cursors))) | ||
| 54 | (list 'defconst name (list 'vector x y string))) | ||
| 55 | |||
| 56 | ;;; push should be defined in common lisp, but if not use this: | ||
| 57 | ;(defmacro push (v l) | ||
| 58 | ; "The ITEM is evaluated and consed onto LIST, a list-valued atom" | ||
| 59 | ; (list 'setq l (list 'cons v l))) | ||
| 60 | |||
| 61 | ;;; | ||
| 62 | ;;; The standard default cursor | ||
| 63 | ;;; | ||
| 64 | (defcursor sc:right-arrow 15 0 | ||
| 65 | (concat '(0 1 0 3 0 7 0 15 0 31 0 63 0 127 0 15 | ||
| 66 | 0 27 0 25 0 48 0 48 0 96 0 96 0 192 0 192))) | ||
| 67 | |||
| 68 | ;;(sc:set-cursor sc:right-arrow) | ||
| 69 | |||
| 70 | (defcursor sc:fat-left-arrow 0 8 | ||
| 71 | (concat '(1 0 3 0 7 0 15 0 31 0 63 255 127 255 255 255 | ||
| 72 | 255 255 127 255 63 255 31 0 15 0 7 0 3 0 1 0))) | ||
| 73 | |||
| 74 | (defcursor sc:box 8 8 | ||
| 75 | (concat '(15 252 8 4 8 4 8 4 8 4 8 4 8 4 8 4 | ||
| 76 | 8 132 8 4 8 4 8 4 8 4 8 4 8 4 15 252))) | ||
| 77 | |||
| 78 | (defcursor sc:hourglass 8 8 | ||
| 79 | (concat "\177\376\100\002\040\014\032\070" | ||
| 80 | "\017\360\007\340\003\300\001\200" | ||
| 81 | "\001\200\002\100\005\040\010\020" | ||
| 82 | "\021\210\043\304\107\342\177\376")) | ||
| 83 | |||
| 84 | (defun sc:set-cursor (icon) | ||
| 85 | "Change the Sun mouse cursor to ICON. | ||
| 86 | If ICON is nil, switch to the system default cursor, | ||
| 87 | Otherwise, ICON should be a vector or the name of a vector of [x y 32-chars]" | ||
| 88 | (interactive "XIcon Name: ") | ||
| 89 | (if (symbolp icon) (setq icon (symbol-value icon))) | ||
| 90 | (sun-change-cursor-icon icon)) | ||
| 91 | |||
| 92 | ;; This does not make much sense... | ||
| 93 | (make-local-variable '*edit-icon*) | ||
| 94 | |||
| 95 | (defvar icon-edit nil) | ||
| 96 | (make-variable-buffer-local 'icon-edit) | ||
| 97 | (or (assq 'icon-edit minor-mode-alist) | ||
| 98 | (push '(icon-edit " IconEdit") minor-mode-alist)) | ||
| 99 | |||
| 100 | (defun sc:edit-cursor (icon) | ||
| 101 | "convert icon to rectangle, edit, and repack" | ||
| 102 | (interactive "XIcon Name: ") | ||
| 103 | (if (not icon) (setq icon (sc::menu-choose-cursor (selected-window) 1 1))) | ||
| 104 | (if (symbolp icon) (setq icon (symbol-value icon))) | ||
| 105 | (if (get-buffer "icon-edit") (kill-buffer "icon-edit")) | ||
| 106 | (switch-to-buffer "icon-edit") | ||
| 107 | (local-set-mouse '(text right) 'sc::menu-function) | ||
| 108 | (local-set-mouse '(text left) '(sc::pic-ins-at-mouse 32)) | ||
| 109 | (local-set-mouse '(text middle) '(sc::pic-ins-at-mouse 64)) | ||
| 110 | (local-set-mouse '(text left middle) 'sc::hotspot) | ||
| 111 | (sc::display-icon icon) | ||
| 112 | (picture-mode) | ||
| 113 | (setq icon-edit t) ; for mode line display | ||
| 114 | ) | ||
| 115 | |||
| 116 | (defun sc::pic-ins-at-mouse (char) | ||
| 117 | "Picture insert char at mouse location" | ||
| 118 | (mouse-move-point *mouse-window* (min 15 *mouse-x*) (min 15 *mouse-y*)) | ||
| 119 | (move-to-column (1+ (min 15 (current-column))) t) | ||
| 120 | (delete-char -1) | ||
| 121 | (insert char) | ||
| 122 | (sc::goto-hotspot)) | ||
| 123 | |||
| 124 | (defmenu sc::menu | ||
| 125 | ("Cursor Menu") | ||
| 126 | ("Pack & Use" sc::pack-buffer-to-cursor) | ||
| 127 | ("Pack to Icon" sc::pack-buffer-to-icon | ||
| 128 | (sc::menu-choose-cursor *menu-window* *menu-x* *menu-y*)) | ||
| 129 | ("New Icon" call-interactively 'sc::make-cursor) | ||
| 130 | ("Edit Icon" sc:edit-cursor | ||
| 131 | (sc::menu-choose-cursor *menu-window* *menu-x* *menu-y*)) | ||
| 132 | ("Set Cursor" sc:set-cursor | ||
| 133 | (sc::menu-choose-cursor *menu-window* *menu-x* *menu-y*)) | ||
| 134 | ("Reset Cursor" sc:set-cursor nil) | ||
| 135 | ("Help" sc::edit-icon-help-menu) | ||
| 136 | ("Quit" sc::quit-edit) | ||
| 137 | ) | ||
| 138 | |||
| 139 | (defun sc::menu-function (window x y) | ||
| 140 | (sun-menu-evaluate window (1+ x) y sc::menu)) | ||
| 141 | |||
| 142 | (defun sc::quit-edit () | ||
| 143 | (interactive) | ||
| 144 | (bury-buffer (current-buffer)) | ||
| 145 | (switch-to-buffer (other-buffer) 'no-record)) | ||
| 146 | |||
| 147 | (defun sc::make-cursor (symbol) | ||
| 148 | (interactive "SIcon Name: ") | ||
| 149 | (eval (list 'defcursor symbol 0 0 "")) | ||
| 150 | (sc::pack-buffer-to-icon (symbol-value symbol))) | ||
| 151 | |||
| 152 | (defmenu sc::edit-icon-help-menu | ||
| 153 | ("Simple Icon Editor") | ||
| 154 | ("Left => CLEAR") | ||
| 155 | ("Middle => SET") | ||
| 156 | ("L & M => HOTSPOT") | ||
| 157 | ("Right => MENU")) | ||
| 158 | |||
| 159 | (defun sc::edit-icon-help () | ||
| 160 | (message "Left=> CLEAR Middle=> SET Left+Middle=> HOTSPOT Right=> MENU")) | ||
| 161 | |||
| 162 | (defun sc::pack-buffer-to-cursor () | ||
| 163 | (sc::pack-buffer-to-icon *edit-icon*) | ||
| 164 | (sc:set-cursor *edit-icon*)) | ||
| 165 | |||
| 166 | (defun sc::menu-choose-cursor (window x y) | ||
| 167 | "Presents a menu of cursor names, and returns one or nil" | ||
| 168 | (let ((curs sc::cursors) | ||
| 169 | (items)) | ||
| 170 | (while curs | ||
| 171 | (push (sc::menu-item-for-cursor (car curs)) items) | ||
| 172 | (setq curs (cdr curs))) | ||
| 173 | (push (list "Choose Cursor") items) | ||
| 174 | (setq menu (menu-create items)) | ||
| 175 | (sun-menu-evaluate window x y menu))) | ||
| 176 | |||
| 177 | (defun sc::menu-item-for-cursor (cursor) | ||
| 178 | "apply function to selected cursor" | ||
| 179 | (list (symbol-name cursor) 'quote cursor)) | ||
| 180 | |||
| 181 | (defun sc::hotspot (window x y) | ||
| 182 | (aset *edit-icon* 0 x) | ||
| 183 | (aset *edit-icon* 1 y) | ||
| 184 | (sc::goto-hotspot)) | ||
| 185 | |||
| 186 | (defun sc::goto-hotspot () | ||
| 187 | (goto-line (1+ (aref *edit-icon* 1))) | ||
| 188 | (move-to-column (aref *edit-icon* 0))) | ||
| 189 | |||
| 190 | (defun sc::display-icon (icon) | ||
| 191 | (setq *edit-icon* (copy-sequence icon)) | ||
| 192 | (let ((string (aref *edit-icon* 2)) | ||
| 193 | (index 0)) | ||
| 194 | (while (< index 32) | ||
| 195 | (let ((char (aref string index)) | ||
| 196 | (bit 128)) | ||
| 197 | (while (> bit 0) | ||
| 198 | (insert (sc::char-at-bit char bit)) | ||
| 199 | (setq bit (lsh bit -1)))) | ||
| 200 | (if (eq 1 (% index 2)) (newline)) | ||
| 201 | (setq index (1+ index)))) | ||
| 202 | (sc::goto-hotspot)) | ||
| 203 | |||
| 204 | (defun sc::char-at-bit (char bit) | ||
| 205 | (if (> (logand char bit) 0) "@" " ")) | ||
| 206 | |||
| 207 | (defun sc::pack-buffer-to-icon (icon) | ||
| 208 | "Pack 16 x 16 field into icon string" | ||
| 209 | (goto-char (point-min)) | ||
| 210 | (aset icon 0 (aref *edit-icon* 0)) | ||
| 211 | (aset icon 1 (aref *edit-icon* 1)) | ||
| 212 | (aset icon 2 (mapconcat 'sc::pack-one-line "1234567890123456" "")) | ||
| 213 | (sc::goto-hotspot) | ||
| 214 | ) | ||
| 215 | |||
| 216 | (defun sc::pack-one-line (dummy) | ||
| 217 | (let (char chr1 chr2) | ||
| 218 | (setq char 0 chr1 (mapconcat 'sc::pack-one-char "12345678" "") chr1 char) | ||
| 219 | (setq char 0 chr2 (mapconcat 'sc::pack-one-char "12345678" "") chr2 char) | ||
| 220 | (forward-line 1) | ||
| 221 | (concat (char-to-string chr1) (char-to-string chr2)) | ||
| 222 | )) | ||
| 223 | |||
| 224 | (defun sc::pack-one-char (dummy) | ||
| 225 | "pack following char into char, unless eolp" | ||
| 226 | (if (or (eolp) (char-equal (following-char) 32)) | ||
| 227 | (setq char (lsh char 1)) | ||
| 228 | (setq char (1+ (lsh char 1)))) | ||
| 229 | (if (not (eolp))(forward-char))) | ||
| 230 | |||
| 231 | (provide 'sun-curs) | ||
| 232 | |||
| 233 | ;;; arch-tag: 7cc861e5-e2d9-4191-b211-2baaaab54e78 | ||
| 234 | ;;; sun-curs.el ends here | ||
diff --git a/lisp/obsolete/sun-fns.el b/lisp/obsolete/sun-fns.el deleted file mode 100644 index 1b6a5d239bd..00000000000 --- a/lisp/obsolete/sun-fns.el +++ /dev/null | |||
| @@ -1,644 +0,0 @@ | |||
| 1 | ;;; sun-fns.el --- subroutines of Mouse handling for Sun windows | ||
| 2 | |||
| 3 | ;; Copyright (C) 1987, 2001, 2002, 2003, 2004, 2005, | ||
| 4 | ;; 2006, 2007 Free Software Foundation, Inc. | ||
| 5 | |||
| 6 | ;; Author: Jeff Peck <peck@sun.com> | ||
| 7 | ;; Maintainer: none | ||
| 8 | ;; Keywords: hardware | ||
| 9 | |||
| 10 | ;; This file is part of GNU Emacs. | ||
| 11 | |||
| 12 | ;; GNU Emacs is free software; you can redistribute it and/or modify | ||
| 13 | ;; it under the terms of the GNU General Public License as published by | ||
| 14 | ;; the Free Software Foundation; either version 3, or (at your option) | ||
| 15 | ;; any later version. | ||
| 16 | |||
| 17 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 20 | ;; GNU General Public License for more details. | ||
| 21 | |||
| 22 | ;; You should have received a copy of the GNU General Public License | ||
| 23 | ;; along with GNU Emacs; see the file COPYING. If not, write to the | ||
| 24 | ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, | ||
| 25 | ;; Boston, MA 02110-1301, USA. | ||
| 26 | |||
| 27 | ;;; Commentary: | ||
| 28 | |||
| 29 | ;; Submitted Mar. 1987, Jeff Peck | ||
| 30 | ;; Sun Microsystems Inc. <peck@sun.com> | ||
| 31 | ;; Conceived Nov. 1986, Stan Jefferson, | ||
| 32 | ;; Computer Science Lab, SRI International. | ||
| 33 | ;; GoodIdeas Feb. 1987, Steve Greenbaum | ||
| 34 | ;; & UpClicks Reasoning Systems, Inc. | ||
| 35 | ;; | ||
| 36 | ;; | ||
| 37 | ;; Functions for manipulating via the mouse and mouse-map definitions | ||
| 38 | ;; for accessing them. Also definitions of mouse menus. | ||
| 39 | ;; This file you should freely modify to reflect you personal tastes. | ||
| 40 | ;; | ||
| 41 | ;; First half of file defines functions to implement mouse commands, | ||
| 42 | ;; Don't delete any of those, just add what ever else you need. | ||
| 43 | ;; Second half of file defines mouse bindings, do whatever you want there. | ||
| 44 | |||
| 45 | ;; | ||
| 46 | ;; Mouse Functions. | ||
| 47 | ;; | ||
| 48 | ;; These functions follow the sun-mouse-handler convention of being called | ||
| 49 | ;; with three arguments: (window x-pos y-pos) | ||
| 50 | ;; This makes it easy for a mouse executed command to know where the mouse is. | ||
| 51 | ;; Use the macro "eval-in-window" to execute a function | ||
| 52 | ;; in a temporarily selected window. | ||
| 53 | ;; | ||
| 54 | ;; If you have a function that must be called with other arguments | ||
| 55 | ;; bind the mouse button to an s-exp that contains the necessary parameters. | ||
| 56 | ;; See "minibuffer" bindings for examples. | ||
| 57 | ;; | ||
| 58 | |||
| 59 | ;;; Code: | ||
| 60 | |||
| 61 | (require 'term/sun-mouse) | ||
| 62 | |||
| 63 | (defconst cursor-pause-milliseconds 300 | ||
| 64 | "*Number of milliseconds to display alternate cursor (usually the mark)") | ||
| 65 | |||
| 66 | (defun indicate-region (&optional pause) | ||
| 67 | "Bounce cursor to mark for cursor-pause-milliseconds and back again" | ||
| 68 | (or pause (setq pause cursor-pause-milliseconds)) | ||
| 69 | (let ((point (point))) | ||
| 70 | (goto-char (mark)) | ||
| 71 | (sit-for-millisecs pause) | ||
| 72 | ;(update-display) | ||
| 73 | ;(sleep-for-millisecs pause) | ||
| 74 | (goto-char point))) | ||
| 75 | |||
| 76 | |||
| 77 | ;;; | ||
| 78 | ;;; Text buffer operations | ||
| 79 | ;;; | ||
| 80 | (defun mouse-move-point (window x y) | ||
| 81 | "Move point to mouse cursor." | ||
| 82 | (select-window window) | ||
| 83 | (move-to-loc x y) | ||
| 84 | (if (memq last-command ; support the mouse-copy/delete/yank | ||
| 85 | '(mouse-copy mouse-delete mouse-yank-move)) | ||
| 86 | (setq this-command 'mouse-yank-move)) | ||
| 87 | ) | ||
| 88 | |||
| 89 | (defun mouse-set-mark (&optional window x y) | ||
| 90 | "Set mark at mouse cursor." | ||
| 91 | (eval-in-window window ;; use this to get the unwind protect | ||
| 92 | (let ((point (point))) | ||
| 93 | (move-to-loc x y) | ||
| 94 | (set-mark (point)) | ||
| 95 | (goto-char point) | ||
| 96 | (indicate-region))) | ||
| 97 | ) | ||
| 98 | |||
| 99 | (defun mouse-set-mark-and-select (window x y) | ||
| 100 | "Set mark at mouse cursor, and select that window." | ||
| 101 | (select-window window) | ||
| 102 | (mouse-set-mark window x y) | ||
| 103 | ) | ||
| 104 | |||
| 105 | (defun mouse-set-mark-and-stuff (w x y) | ||
| 106 | "Set mark at mouse cursor, and put region in stuff buffer." | ||
| 107 | (mouse-set-mark-and-select w x y) | ||
| 108 | (sun-select-region (region-beginning) (region-end))) | ||
| 109 | |||
| 110 | ;;; | ||
| 111 | ;;; Simple mouse dragging stuff: marking with button up | ||
| 112 | ;;; | ||
| 113 | |||
| 114 | (defvar *mouse-drag-window* nil) | ||
| 115 | (defvar *mouse-drag-x* -1) | ||
| 116 | (defvar *mouse-drag-y* -1) | ||
| 117 | |||
| 118 | (defun mouse-drag-move-point (window x y) | ||
| 119 | "Move point to mouse cursor, and allow dragging." | ||
| 120 | (mouse-move-point window x y) | ||
| 121 | (setq *mouse-drag-window* window | ||
| 122 | *mouse-drag-x* x | ||
| 123 | *mouse-drag-y* y)) | ||
| 124 | |||
| 125 | (defun mouse-drag-set-mark-stuff (window x y) | ||
| 126 | "The up click handler that goes with mouse-drag-move-point. | ||
| 127 | If mouse is in same WINDOW but at different X or Y than when | ||
| 128 | mouse-drag-move-point was last executed, set the mark at mouse | ||
| 129 | and put the region in the stuff buffer." | ||
| 130 | (if (and (eq *mouse-drag-window* window) | ||
| 131 | (not (and (equal *mouse-drag-x* x) | ||
| 132 | (equal *mouse-drag-y* y)))) | ||
| 133 | (mouse-set-mark-and-stuff window x y) | ||
| 134 | (setq this-command last-command)) ; this was just an upclick no-op. | ||
| 135 | ) | ||
| 136 | |||
| 137 | (defun mouse-select-or-drag-move-point (window x y) | ||
| 138 | "Select window if not selected, otherwise do mouse-drag-move-point." | ||
| 139 | (if (eq (selected-window) window) | ||
| 140 | (mouse-drag-move-point window x y) | ||
| 141 | (mouse-select-window window))) | ||
| 142 | |||
| 143 | ;;; | ||
| 144 | ;;; esoterica: | ||
| 145 | ;;; | ||
| 146 | (defun mouse-exch-pt-and-mark (window x y) | ||
| 147 | "Exchange point and mark." | ||
| 148 | (select-window window) | ||
| 149 | (exchange-point-and-mark) | ||
| 150 | ) | ||
| 151 | |||
| 152 | (defun mouse-call-kbd-macro (window x y) | ||
| 153 | "Invokes last keyboard macro at mouse cursor." | ||
| 154 | (mouse-move-point window x y) | ||
| 155 | (call-last-kbd-macro) | ||
| 156 | ) | ||
| 157 | |||
| 158 | (defun mouse-mark-thing (window x y) | ||
| 159 | "Set point and mark to text object using syntax table. | ||
| 160 | The resulting region is put in the sun-window stuff buffer. | ||
| 161 | Left or right Paren syntax marks an s-expression. | ||
| 162 | Clicking at the end of a line marks the line including a trailing newline. | ||
| 163 | If it doesn't recognize one of these it marks the character at point." | ||
| 164 | (mouse-move-point window x y) | ||
| 165 | (if (eobp) (open-line 1)) | ||
| 166 | (let* ((char (char-after (point))) | ||
| 167 | (syntax (char-syntax char))) | ||
| 168 | (cond | ||
| 169 | ((eq syntax ?w) ; word. | ||
| 170 | (forward-word 1) | ||
| 171 | (set-mark (point)) | ||
| 172 | (forward-word -1)) | ||
| 173 | ;; try to include a single following whitespace (is this a good idea?) | ||
| 174 | ;; No, not a good idea since inconsistent. | ||
| 175 | ;;(if (eq (char-syntax (char-after (mark))) ?\ ) | ||
| 176 | ;; (set-mark (1+ (mark)))) | ||
| 177 | ((eq syntax ?\( ) ; open paren. | ||
| 178 | (mark-sexp 1)) | ||
| 179 | ((eq syntax ?\) ) ; close paren. | ||
| 180 | (forward-char 1) | ||
| 181 | (mark-sexp -1) | ||
| 182 | (exchange-point-and-mark)) | ||
| 183 | ((eolp) ; mark line if at end. | ||
| 184 | (set-mark (1+ (point))) | ||
| 185 | (beginning-of-line 1)) | ||
| 186 | (t ; mark character | ||
| 187 | (set-mark (1+ (point))))) | ||
| 188 | (indicate-region)) ; display region boundary. | ||
| 189 | (sun-select-region (region-beginning) (region-end)) | ||
| 190 | ) | ||
| 191 | |||
| 192 | (defun mouse-kill-thing (window x y) | ||
| 193 | "Kill thing at mouse, and put point there." | ||
| 194 | (mouse-mark-thing window x y) | ||
| 195 | (kill-region-and-unmark (region-beginning) (region-end)) | ||
| 196 | ) | ||
| 197 | |||
| 198 | (defun mouse-kill-thing-there (window x y) | ||
| 199 | "Kill thing at mouse, leave point where it was. | ||
| 200 | See mouse-mark-thing for a description of the objects recognized." | ||
| 201 | (eval-in-window window | ||
| 202 | (save-excursion | ||
| 203 | (mouse-mark-thing window x y) | ||
| 204 | (kill-region (region-beginning) (region-end)))) | ||
| 205 | ) | ||
| 206 | |||
| 207 | (defun mouse-save-thing (window x y &optional quiet) | ||
| 208 | "Put thing at mouse in kill ring. | ||
| 209 | See mouse-mark-thing for a description of the objects recognized." | ||
| 210 | (mouse-mark-thing window x y) | ||
| 211 | (copy-region-as-kill (region-beginning) (region-end)) | ||
| 212 | (if (not quiet) (message "Thing saved")) | ||
| 213 | ) | ||
| 214 | |||
| 215 | (defun mouse-save-thing-there (window x y &optional quiet) | ||
| 216 | "Put thing at mouse in kill ring, leave point as is. | ||
| 217 | See mouse-mark-thing for a description of the objects recognized." | ||
| 218 | (eval-in-window window | ||
| 219 | (save-excursion | ||
| 220 | (mouse-save-thing window x y quiet)))) | ||
| 221 | |||
| 222 | ;;; | ||
| 223 | ;;; Mouse yanking... | ||
| 224 | ;;; | ||
| 225 | (defun mouse-copy-thing (window x y) | ||
| 226 | "Put thing at mouse in kill ring, yank to point. | ||
| 227 | See mouse-mark-thing for a description of the objects recognized." | ||
| 228 | (setq last-command 'not-kill) ;Avoids appending to previous kills. | ||
| 229 | (mouse-save-thing-there window x y t) | ||
| 230 | (yank) | ||
| 231 | (setq this-command 'yank)) | ||
| 232 | |||
| 233 | (defun mouse-move-thing (window x y) | ||
| 234 | "Kill thing at mouse, yank it to point. | ||
| 235 | See mouse-mark-thing for a description of the objects recognized." | ||
| 236 | (setq last-command 'not-kill) ;Avoids appending to previous kills. | ||
| 237 | (mouse-kill-thing-there window x y) | ||
| 238 | (yank) | ||
| 239 | (setq this-command 'yank)) | ||
| 240 | |||
| 241 | (defun mouse-yank-at-point (&optional window x y) | ||
| 242 | "Yank from kill-ring at point; then cycle thru kill ring." | ||
| 243 | (if (eq last-command 'yank) | ||
| 244 | (let ((before (< (point) (mark)))) | ||
| 245 | (delete-region (point) (mark)) | ||
| 246 | (insert (current-kill 1)) | ||
| 247 | (if before (exchange-point-and-mark))) | ||
| 248 | (yank)) | ||
| 249 | (setq this-command 'yank)) | ||
| 250 | |||
| 251 | (defun mouse-yank-at-mouse (window x y) | ||
| 252 | "Yank from kill-ring at mouse; then cycle thru kill ring." | ||
| 253 | (mouse-move-point window x y) | ||
| 254 | (mouse-yank-at-point window x y)) | ||
| 255 | |||
| 256 | (defun mouse-save/delete/yank (&optional window x y) | ||
| 257 | "Context sensitive save/delete/yank. | ||
| 258 | Consecutive clicks perform as follows: | ||
| 259 | * first click saves region to kill ring, | ||
| 260 | * second click kills region, | ||
| 261 | * third click yanks from kill ring, | ||
| 262 | * subsequent clicks cycle thru kill ring. | ||
| 263 | If mouse-move-point is performed after the first or second click, | ||
| 264 | the next click will do a yank, etc. Except for a possible mouse-move-point, | ||
| 265 | this command is insensitive to mouse location." | ||
| 266 | (cond | ||
| 267 | ((memq last-command '(mouse-delete yank mouse-yank-move)) ; third+ click | ||
| 268 | (mouse-yank-at-point)) | ||
| 269 | ((eq last-command 'mouse-copy) ; second click | ||
| 270 | (kill-region (region-beginning) (region-end)) | ||
| 271 | (setq this-command 'mouse-delete)) | ||
| 272 | (t ; first click | ||
| 273 | (copy-region-as-kill (region-beginning) (region-end)) | ||
| 274 | (message "Region saved") | ||
| 275 | (setq this-command 'mouse-copy)) | ||
| 276 | )) | ||
| 277 | |||
| 278 | |||
| 279 | (defun mouse-split-horizontally (window x y) | ||
| 280 | "Splits the window horizontally at mouse cursor." | ||
| 281 | (eval-in-window window (split-window-horizontally (1+ x)))) | ||
| 282 | |||
| 283 | (defun mouse-split-vertically (window x y) | ||
| 284 | "Split the window vertically at the mouse cursor." | ||
| 285 | (eval-in-window window (split-window-vertically (1+ y)))) | ||
| 286 | |||
| 287 | (defun mouse-select-window (&optional window x y) | ||
| 288 | "Selects the window, restoring point." | ||
| 289 | (select-window window)) | ||
| 290 | |||
| 291 | (defun mouse-delete-other-windows (&optional window x y) | ||
| 292 | "Deletes all windows except the one mouse is in." | ||
| 293 | (delete-other-windows window)) | ||
| 294 | |||
| 295 | (defun mouse-delete-window (window &optional x y) | ||
| 296 | "Deletes the window mouse is in." | ||
| 297 | (delete-window window)) | ||
| 298 | |||
| 299 | (defun mouse-undo (window x y) | ||
| 300 | "Invokes undo in the window mouse is in." | ||
| 301 | (eval-in-window window (undo))) | ||
| 302 | |||
| 303 | ;;; | ||
| 304 | ;;; Scroll operations | ||
| 305 | ;;; | ||
| 306 | |||
| 307 | ;;; The move-to-window-line is used below because otherwise | ||
| 308 | ;;; scrolling a non-selected process window with the mouse, after | ||
| 309 | ;;; the process has written text past the bottom of the window, | ||
| 310 | ;;; gives an "End of buffer" error, and then scrolls. The | ||
| 311 | ;;; move-to-window-line seems to force recomputing where things are. | ||
| 312 | (defun mouse-scroll-up (window x y) | ||
| 313 | "Scrolls the window upward." | ||
| 314 | (eval-in-window window (move-to-window-line 1) (scroll-up nil))) | ||
| 315 | |||
| 316 | (defun mouse-scroll-down (window x y) | ||
| 317 | "Scrolls the window downward." | ||
| 318 | (eval-in-window window (scroll-down nil))) | ||
| 319 | |||
| 320 | (defun mouse-scroll-proportional (window x y) | ||
| 321 | "Scrolls the window proportionally corresponding to window | ||
| 322 | relative X divided by window width." | ||
| 323 | (eval-in-window window | ||
| 324 | (if (>= x (1- (window-width))) | ||
| 325 | ;; When x is maximum (equal to or 1 less than window width), | ||
| 326 | ;; goto end of buffer. We check for this special case | ||
| 327 | ;; because the calculated goto-char often goes short of the | ||
| 328 | ;; end due to roundoff error, and we often really want to go | ||
| 329 | ;; to the end. | ||
| 330 | (goto-char (point-max)) | ||
| 331 | (progn | ||
| 332 | (goto-char (+ (point-min) ; For narrowed regions. | ||
| 333 | (* x (/ (- (point-max) (point-min)) | ||
| 334 | (1- (window-width)))))) | ||
| 335 | (beginning-of-line)) | ||
| 336 | ) | ||
| 337 | (what-cursor-position) ; Report position. | ||
| 338 | )) | ||
| 339 | |||
| 340 | (defun mouse-line-to-top (window x y) | ||
| 341 | "Scrolls the line at the mouse cursor up to the top." | ||
| 342 | (eval-in-window window (scroll-up y))) | ||
| 343 | |||
| 344 | (defun mouse-top-to-line (window x y) | ||
| 345 | "Scrolls the top line down to the mouse cursor." | ||
| 346 | (eval-in-window window (scroll-down y))) | ||
| 347 | |||
| 348 | (defun mouse-line-to-bottom (window x y) | ||
| 349 | "Scrolls the line at the mouse cursor to the bottom." | ||
| 350 | (eval-in-window window (scroll-up (+ y (- 2 (window-height)))))) | ||
| 351 | |||
| 352 | (defun mouse-bottom-to-line (window x y) | ||
| 353 | "Scrolls the bottom line up to the mouse cursor." | ||
| 354 | (eval-in-window window (scroll-down (+ y (- 2 (window-height)))))) | ||
| 355 | |||
| 356 | (defun mouse-line-to-middle (window x y) | ||
| 357 | "Scrolls the line at the mouse cursor to the middle." | ||
| 358 | (eval-in-window window (scroll-up (- y -1 (/ (window-height) 2))))) | ||
| 359 | |||
| 360 | (defun mouse-middle-to-line (window x y) | ||
| 361 | "Scrolls the line at the middle to the mouse cursor." | ||
| 362 | (eval-in-window window (scroll-up (- (/ (window-height) 2) y 1)))) | ||
| 363 | |||
| 364 | |||
| 365 | ;;; | ||
| 366 | ;;; main emacs menu. | ||
| 367 | ;;; | ||
| 368 | (defmenu expand-menu | ||
| 369 | ("Vertically" mouse-expand-vertically *menu-window*) | ||
| 370 | ("Horizontally" mouse-expand-horizontally *menu-window*)) | ||
| 371 | |||
| 372 | (defmenu delete-window-menu | ||
| 373 | ("This One" delete-window *menu-window*) | ||
| 374 | ("All Others" delete-other-windows *menu-window*)) | ||
| 375 | |||
| 376 | (defmenu mouse-help-menu | ||
| 377 | ("Text Region" | ||
| 378 | mouse-help-region *menu-window* *menu-x* *menu-y* 'text) | ||
| 379 | ("Scrollbar" | ||
| 380 | mouse-help-region *menu-window* *menu-x* *menu-y* 'scrollbar) | ||
| 381 | ("Modeline" | ||
| 382 | mouse-help-region *menu-window* *menu-x* *menu-y* 'modeline) | ||
| 383 | ("Minibuffer" | ||
| 384 | mouse-help-region *menu-window* *menu-x* *menu-y* 'minibuffer) | ||
| 385 | ) | ||
| 386 | |||
| 387 | (defmenu emacs-quit-menu | ||
| 388 | ("Quit" save-buffers-kill-emacs)) | ||
| 389 | |||
| 390 | (defmenu emacs-menu | ||
| 391 | ("Emacs Menu") | ||
| 392 | ("Stuff Selection" sun-yank-selection) | ||
| 393 | ("Expand" . expand-menu) | ||
| 394 | ("Delete Window" . delete-window-menu) | ||
| 395 | ("Previous Buffer" mouse-select-previous-buffer *menu-window*) | ||
| 396 | ("Save Buffers" save-some-buffers) | ||
| 397 | ("List Directory" list-directory nil) | ||
| 398 | ("Dired" dired nil) | ||
| 399 | ("Mouse Help" . mouse-help-menu) | ||
| 400 | ("Quit" . emacs-quit-menu)) | ||
| 401 | |||
| 402 | (defun emacs-menu-eval (window x y) | ||
| 403 | "Pop-up menu of editor commands." | ||
| 404 | (sun-menu-evaluate window (1+ x) (1- y) 'emacs-menu)) | ||
| 405 | |||
| 406 | (defun mouse-expand-horizontally (window) | ||
| 407 | (eval-in-window window | ||
| 408 | (enlarge-window 4 t) | ||
| 409 | (update-display) ; Try to redisplay, since can get confused. | ||
| 410 | )) | ||
| 411 | |||
| 412 | (defun mouse-expand-vertically (window) | ||
| 413 | (eval-in-window window (enlarge-window 4))) | ||
| 414 | |||
| 415 | (defun mouse-select-previous-buffer (window) | ||
| 416 | "Switch buffer in mouse window to most recently selected buffer." | ||
| 417 | (eval-in-window window (switch-to-buffer (other-buffer)))) | ||
| 418 | |||
| 419 | ;;; | ||
| 420 | ;;; minibuffer menu | ||
| 421 | ;;; | ||
| 422 | (defmenu minibuffer-menu | ||
| 423 | ("Minibuffer" message "Just some miscellaneous minibuffer commands") | ||
| 424 | ("Stuff" sun-yank-selection) | ||
| 425 | ("Do-It" exit-minibuffer) | ||
| 426 | ("Abort" abort-recursive-edit) | ||
| 427 | ("Suspend" suspend-emacs)) | ||
| 428 | |||
| 429 | (defun minibuffer-menu-eval (window x y) | ||
| 430 | "Pop-up menu of commands." | ||
| 431 | (sun-menu-evaluate window x (1- y) 'minibuffer-menu)) | ||
| 432 | |||
| 433 | (defun mini-move-point (window x y) | ||
| 434 | ;; -6 is good for most common cases | ||
| 435 | (mouse-move-point window (- x 6) 0)) | ||
| 436 | |||
| 437 | (defun mini-set-mark-and-stuff (window x y) | ||
| 438 | ;; -6 is good for most common cases | ||
| 439 | (mouse-set-mark-and-stuff window (- x 6) 0)) | ||
| 440 | |||
| 441 | |||
| 442 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | ||
| 443 | ;;; Buffer-mode Mouse commands | ||
| 444 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | ||
| 445 | |||
| 446 | (defun Buffer-at-mouse (w x y) | ||
| 447 | "Calls Buffer-menu-buffer from mouse click." | ||
| 448 | (save-window-excursion | ||
| 449 | (mouse-move-point w x y) | ||
| 450 | (beginning-of-line) | ||
| 451 | (Buffer-menu-buffer t))) | ||
| 452 | |||
| 453 | (defun mouse-buffer-bury (w x y) | ||
| 454 | "Bury the indicated buffer." | ||
| 455 | (bury-buffer (Buffer-at-mouse w x y)) | ||
| 456 | ) | ||
| 457 | |||
| 458 | (defun mouse-buffer-select (w x y) | ||
| 459 | "Put the indicated buffer in selected window." | ||
| 460 | (switch-to-buffer (Buffer-at-mouse w x y)) | ||
| 461 | (list-buffers) | ||
| 462 | ) | ||
| 463 | |||
| 464 | (defun mouse-buffer-delete (w x y) | ||
| 465 | "mark indicated buffer for delete" | ||
| 466 | (save-window-excursion | ||
| 467 | (mouse-move-point w x y) | ||
| 468 | (Buffer-menu-delete) | ||
| 469 | )) | ||
| 470 | |||
| 471 | (defun mouse-buffer-execute (w x y) | ||
| 472 | "execute buffer-menu selections" | ||
| 473 | (save-window-excursion | ||
| 474 | (mouse-move-point w x y) | ||
| 475 | (Buffer-menu-execute) | ||
| 476 | )) | ||
| 477 | |||
| 478 | (defun enable-mouse-in-buffer-list () | ||
| 479 | "Call this to enable mouse selections in *Buffer List* | ||
| 480 | LEFT puts the indicated buffer in the selected window. | ||
| 481 | MIDDLE buries the indicated buffer. | ||
| 482 | RIGHT marks the indicated buffer for deletion. | ||
| 483 | MIDDLE-RIGHT deletes the marked buffers. | ||
| 484 | To unmark a buffer marked for deletion, select it with LEFT." | ||
| 485 | (save-window-excursion | ||
| 486 | (list-buffers) ; Initialize *Buffer List* | ||
| 487 | (set-buffer "*Buffer List*") | ||
| 488 | (local-set-mouse '(text middle) 'mouse-buffer-bury) | ||
| 489 | (local-set-mouse '(text left) 'mouse-buffer-select) | ||
| 490 | (local-set-mouse '(text right) 'mouse-buffer-delete) | ||
| 491 | (local-set-mouse '(text middle right) 'mouse-buffer-execute) | ||
| 492 | ) | ||
| 493 | ) | ||
| 494 | |||
| 495 | |||
| 496 | ;;;******************************************************************* | ||
| 497 | ;;; | ||
| 498 | ;;; Global Mouse Bindings. | ||
| 499 | ;;; | ||
| 500 | ;;; There is some sense to this mouse binding madness: | ||
| 501 | ;;; LEFT and RIGHT scrolls are inverses. | ||
| 502 | ;;; SHIFT makes an opposite meaning in the scroll bar. | ||
| 503 | ;;; SHIFT is an alternative to DOUBLE (but double chords do not exist). | ||
| 504 | ;;; META makes the scrollbar functions work in the text region. | ||
| 505 | ;;; MIDDLE operates the mark | ||
| 506 | ;;; LEFT operates at point | ||
| 507 | |||
| 508 | ;;; META commands are generally non-destructive, | ||
| 509 | ;;; SHIFT is a little more dangerous. | ||
| 510 | ;;; CONTROL is for the really complicated ones. | ||
| 511 | |||
| 512 | ;;; CONTROL-META-SHIFT-RIGHT gives help on that region. | ||
| 513 | |||
| 514 | ;;; | ||
| 515 | ;;; Text Region mousemap | ||
| 516 | ;;; | ||
| 517 | ;; The basics: Point, Mark, Menu, Sun-Select: | ||
| 518 | (global-set-mouse '(text left) 'mouse-drag-move-point) | ||
| 519 | (global-set-mouse '(text up left) 'mouse-drag-set-mark-stuff) | ||
| 520 | (global-set-mouse '(text shift left) 'mouse-exch-pt-and-mark) | ||
| 521 | (global-set-mouse '(text double left) 'mouse-exch-pt-and-mark) | ||
| 522 | |||
| 523 | (global-set-mouse '(text middle) 'mouse-set-mark-and-stuff) | ||
| 524 | |||
| 525 | (global-set-mouse '(text right) 'emacs-menu-eval) | ||
| 526 | (global-set-mouse '(text shift right) '(sun-yank-selection)) | ||
| 527 | (global-set-mouse '(text double right) '(sun-yank-selection)) | ||
| 528 | |||
| 529 | ;; The Slymoblics multi-command for Save, Kill, Copy, Move: | ||
| 530 | (global-set-mouse '(text shift middle) 'mouse-save/delete/yank) | ||
| 531 | (global-set-mouse '(text double middle) 'mouse-save/delete/yank) | ||
| 532 | |||
| 533 | ;; Save, Kill, Copy, Move Things: | ||
| 534 | ;; control-left composes with control middle/right to produce copy/move | ||
| 535 | (global-set-mouse '(text control middle ) 'mouse-save-thing-there) | ||
| 536 | (global-set-mouse '(text control right ) 'mouse-kill-thing-there) | ||
| 537 | (global-set-mouse '(text control left) 'mouse-yank-at-point) | ||
| 538 | (global-set-mouse '(text control middle left) 'mouse-copy-thing) | ||
| 539 | (global-set-mouse '(text control right left) 'mouse-move-thing) | ||
| 540 | (global-set-mouse '(text control right middle) 'mouse-mark-thing) | ||
| 541 | |||
| 542 | ;; The Universal mouse help command (press all buttons): | ||
| 543 | (global-set-mouse '(text shift control meta right) 'mouse-help-region) | ||
| 544 | (global-set-mouse '(text double control meta right) 'mouse-help-region) | ||
| 545 | |||
| 546 | ;;; Meta in Text Region is like meta version in scrollbar: | ||
| 547 | (global-set-mouse '(text meta left) 'mouse-line-to-top) | ||
| 548 | (global-set-mouse '(text meta shift left) 'mouse-line-to-bottom) | ||
| 549 | (global-set-mouse '(text meta double left) 'mouse-line-to-bottom) | ||
| 550 | (global-set-mouse '(text meta middle) 'mouse-line-to-middle) | ||
| 551 | (global-set-mouse '(text meta shift middle) 'mouse-middle-to-line) | ||
| 552 | (global-set-mouse '(text meta double middle) 'mouse-middle-to-line) | ||
| 553 | (global-set-mouse '(text meta control middle) 'mouse-split-vertically) | ||
| 554 | (global-set-mouse '(text meta right) 'mouse-top-to-line) | ||
| 555 | (global-set-mouse '(text meta shift right) 'mouse-bottom-to-line) | ||
| 556 | (global-set-mouse '(text meta double right) 'mouse-bottom-to-line) | ||
| 557 | |||
| 558 | ;; Miscellaneous: | ||
| 559 | (global-set-mouse '(text meta control left) 'mouse-call-kbd-macro) | ||
| 560 | (global-set-mouse '(text meta control right) 'mouse-undo) | ||
| 561 | |||
| 562 | ;;; | ||
| 563 | ;;; Scrollbar mousemap. | ||
| 564 | ;;; Are available in the Scrollbar Region, or with Meta Text (or Meta Scrollbar) | ||
| 565 | ;;; | ||
| 566 | (global-set-mouse '(scrollbar left) 'mouse-line-to-top) | ||
| 567 | (global-set-mouse '(scrollbar shift left) 'mouse-line-to-bottom) | ||
| 568 | (global-set-mouse '(scrollbar double left) 'mouse-line-to-bottom) | ||
| 569 | |||
| 570 | (global-set-mouse '(scrollbar middle) 'mouse-line-to-middle) | ||
| 571 | (global-set-mouse '(scrollbar shift middle) 'mouse-middle-to-line) | ||
| 572 | (global-set-mouse '(scrollbar double middle) 'mouse-middle-to-line) | ||
| 573 | (global-set-mouse '(scrollbar control middle) 'mouse-split-vertically) | ||
| 574 | |||
| 575 | (global-set-mouse '(scrollbar right) 'mouse-top-to-line) | ||
| 576 | (global-set-mouse '(scrollbar shift right) 'mouse-bottom-to-line) | ||
| 577 | (global-set-mouse '(scrollbar double right) 'mouse-bottom-to-line) | ||
| 578 | |||
| 579 | (global-set-mouse '(scrollbar meta left) 'mouse-line-to-top) | ||
| 580 | (global-set-mouse '(scrollbar meta shift left) 'mouse-line-to-bottom) | ||
| 581 | (global-set-mouse '(scrollbar meta double left) 'mouse-line-to-bottom) | ||
| 582 | (global-set-mouse '(scrollbar meta middle) 'mouse-line-to-middle) | ||
| 583 | (global-set-mouse '(scrollbar meta shift middle) 'mouse-middle-to-line) | ||
| 584 | (global-set-mouse '(scrollbar meta double middle) 'mouse-middle-to-line) | ||
| 585 | (global-set-mouse '(scrollbar meta control middle) 'mouse-split-vertically) | ||
| 586 | (global-set-mouse '(scrollbar meta right) 'mouse-top-to-line) | ||
| 587 | (global-set-mouse '(scrollbar meta shift right) 'mouse-bottom-to-line) | ||
| 588 | (global-set-mouse '(scrollbar meta double right) 'mouse-bottom-to-line) | ||
| 589 | |||
| 590 | ;; And the help menu: | ||
| 591 | (global-set-mouse '(scrollbar shift control meta right) 'mouse-help-region) | ||
| 592 | (global-set-mouse '(scrollbar double control meta right) 'mouse-help-region) | ||
| 593 | |||
| 594 | ;;; | ||
| 595 | ;;; Modeline mousemap. | ||
| 596 | ;;; | ||
| 597 | ;;; Note: meta of any single button selects window. | ||
| 598 | |||
| 599 | (global-set-mouse '(modeline left) 'mouse-scroll-up) | ||
| 600 | (global-set-mouse '(modeline meta left) 'mouse-select-window) | ||
| 601 | |||
| 602 | (global-set-mouse '(modeline middle) 'mouse-scroll-proportional) | ||
| 603 | (global-set-mouse '(modeline meta middle) 'mouse-select-window) | ||
| 604 | (global-set-mouse '(modeline control middle) 'mouse-split-horizontally) | ||
| 605 | |||
| 606 | (global-set-mouse '(modeline right) 'mouse-scroll-down) | ||
| 607 | (global-set-mouse '(modeline meta right) 'mouse-select-window) | ||
| 608 | |||
| 609 | ;;; control-left selects this window, control-right deletes it. | ||
| 610 | (global-set-mouse '(modeline control left) 'mouse-delete-other-windows) | ||
| 611 | (global-set-mouse '(modeline control right) 'mouse-delete-window) | ||
| 612 | |||
| 613 | ;; in case of confusion, just select it: | ||
| 614 | (global-set-mouse '(modeline control left right)'mouse-select-window) | ||
| 615 | |||
| 616 | ;; even without confusion (and without the keyboard) select it: | ||
| 617 | (global-set-mouse '(modeline left right) 'mouse-select-window) | ||
| 618 | |||
| 619 | ;; And the help menu: | ||
| 620 | (global-set-mouse '(modeline shift control meta right) 'mouse-help-region) | ||
| 621 | (global-set-mouse '(modeline double control meta right) 'mouse-help-region) | ||
| 622 | |||
| 623 | ;;; | ||
| 624 | ;;; Minibuffer Mousemap | ||
| 625 | ;;; Demonstrating some variety: | ||
| 626 | ;;; | ||
| 627 | (global-set-mouse '(minibuffer left) 'mini-move-point) | ||
| 628 | |||
| 629 | (global-set-mouse '(minibuffer middle) 'mini-set-mark-and-stuff) | ||
| 630 | |||
| 631 | (global-set-mouse '(minibuffer shift middle) '(select-previous-complex-command)) | ||
| 632 | (global-set-mouse '(minibuffer double middle) '(select-previous-complex-command)) | ||
| 633 | (global-set-mouse '(minibuffer control middle) '(next-complex-command 1)) | ||
| 634 | (global-set-mouse '(minibuffer meta middle) '(previous-complex-command 1)) | ||
| 635 | |||
| 636 | (global-set-mouse '(minibuffer right) 'minibuffer-menu-eval) | ||
| 637 | |||
| 638 | (global-set-mouse '(minibuffer shift control meta right) 'mouse-help-region) | ||
| 639 | (global-set-mouse '(minibuffer double control meta right) 'mouse-help-region) | ||
| 640 | |||
| 641 | (provide 'sun-fns) | ||
| 642 | |||
| 643 | ;;; arch-tag: 1c4c1192-f71d-4d5f-b883-ae659c28e132 | ||
| 644 | ;;; sun-fns.el ends here | ||
diff --git a/lisp/term/sun-mouse.el b/lisp/term/sun-mouse.el deleted file mode 100644 index d3e85508b03..00000000000 --- a/lisp/term/sun-mouse.el +++ /dev/null | |||
| @@ -1,667 +0,0 @@ | |||
| 1 | ;;; sun-mouse.el --- mouse handling for Sun windows | ||
| 2 | |||
| 3 | ;; Copyright (C) 1987, 2001, 2002, 2003, 2004, 2005, | ||
| 4 | ;; 2006, 2007 Free Software Foundation, Inc. | ||
| 5 | |||
| 6 | ;; Author: Jeff Peck | ||
| 7 | ;; Maintainer: FSF | ||
| 8 | ;; Keywords: hardware | ||
| 9 | |||
| 10 | ;; This file is part of GNU Emacs. | ||
| 11 | |||
| 12 | ;; GNU Emacs is free software; you can redistribute it and/or modify | ||
| 13 | ;; it under the terms of the GNU General Public License as published by | ||
| 14 | ;; the Free Software Foundation; either version 3, or (at your option) | ||
| 15 | ;; any later version. | ||
| 16 | |||
| 17 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 20 | ;; GNU General Public License for more details. | ||
| 21 | |||
| 22 | ;; You should have received a copy of the GNU General Public License | ||
| 23 | ;; along with GNU Emacs; see the file COPYING. If not, write to the | ||
| 24 | ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, | ||
| 25 | ;; Boston, MA 02110-1301, USA. | ||
| 26 | |||
| 27 | ;;; Commentary: | ||
| 28 | |||
| 29 | ;; Jeff Peck, Sun Microsystems, Jan 1987. | ||
| 30 | ;; Original idea by Stan Jefferson | ||
| 31 | |||
| 32 | ;; Modeled after the GNUEMACS keymap interface. | ||
| 33 | ;; | ||
| 34 | ;; User Functions: | ||
| 35 | ;; make-mousemap, copy-mousemap, | ||
| 36 | ;; define-mouse, global-set-mouse, local-set-mouse, | ||
| 37 | ;; use-global-mousemap, use-local-mousemap, | ||
| 38 | ;; mouse-lookup, describe-mouse-bindings | ||
| 39 | ;; | ||
| 40 | ;; Options: | ||
| 41 | ;; extra-click-wait, scrollbar-width | ||
| 42 | |||
| 43 | ;;; Code: | ||
| 44 | |||
| 45 | (defvar extra-click-wait 150 | ||
| 46 | "*Number of milliseconds to wait for an extra click. | ||
| 47 | Set this to zero if you don't want chords or double clicks.") | ||
| 48 | |||
| 49 | (defvar scrollbar-width 5 | ||
| 50 | "*The character width of the scrollbar. | ||
| 51 | The cursor is deemed to be in the right edge scrollbar if it is this near the | ||
| 52 | right edge, and more than two chars past the end of the indicated line. | ||
| 53 | Setting to nil limits the scrollbar to the edge or vertical dividing bar.") | ||
| 54 | |||
| 55 | ;;; | ||
| 56 | ;;; Mousemaps | ||
| 57 | ;;; | ||
| 58 | (defun make-mousemap () | ||
| 59 | "Returns a new mousemap." | ||
| 60 | (cons 'mousemap nil)) | ||
| 61 | |||
| 62 | ;;; initialize mouse maps | ||
| 63 | (defvar current-global-mousemap (make-mousemap)) | ||
| 64 | (defvar current-local-mousemap nil) | ||
| 65 | (make-variable-buffer-local 'current-local-mousemap) | ||
| 66 | |||
| 67 | (defun copy-mousemap (mousemap) | ||
| 68 | "Return a copy of mousemap." | ||
| 69 | (copy-alist mousemap)) | ||
| 70 | |||
| 71 | (defun define-mouse (mousemap mouse-list def) | ||
| 72 | "Args MOUSEMAP, MOUSE-LIST, DEF. Define MOUSE-LIST in MOUSEMAP as DEF. | ||
| 73 | MOUSE-LIST is a list of atoms specifying a mouse hit according to these rules: | ||
| 74 | * One of these atoms specifies the active region of the definition. | ||
| 75 | text, scrollbar, modeline, minibuffer | ||
| 76 | * One or two or these atoms specify the button or button combination. | ||
| 77 | left, middle, right, double | ||
| 78 | * Any combination of these atoms specify the active shift keys. | ||
| 79 | control, shift, meta | ||
| 80 | * With a single unshifted button, you can add | ||
| 81 | up | ||
| 82 | to indicate an up-click. | ||
| 83 | The atom `double' is used with a button designator to denote a double click. | ||
| 84 | Two button chords are denoted by listing the two buttons. | ||
| 85 | See sun-mouse-handler for the treatment of the form DEF." | ||
| 86 | (mousemap-set (mouse-list-to-mouse-code mouse-list) mousemap def)) | ||
| 87 | |||
| 88 | (defun global-set-mouse (mouse-list def) | ||
| 89 | "Give MOUSE-EVENT-LIST a local definition of DEF. | ||
| 90 | See define-mouse for a description of MOUSE-EVENT-LIST and DEF. | ||
| 91 | Note that if MOUSE-EVENT-LIST has a local definition in the current buffer, | ||
| 92 | that local definition will continue to shadow any global definition." | ||
| 93 | (interactive "xMouse event: \nxDefinition: ") | ||
| 94 | (define-mouse current-global-mousemap mouse-list def)) | ||
| 95 | |||
| 96 | (defun local-set-mouse (mouse-list def) | ||
| 97 | "Give MOUSE-EVENT-LIST a local definition of DEF. | ||
| 98 | See define-mouse for a description of the arguments. | ||
| 99 | The definition goes in the current buffer's local mousemap. | ||
| 100 | Normally buffers in the same major mode share a local mousemap." | ||
| 101 | (interactive "xMouse event: \nxDefinition: ") | ||
| 102 | (if (null current-local-mousemap) | ||
| 103 | (setq current-local-mousemap (make-mousemap))) | ||
| 104 | (define-mouse current-local-mousemap mouse-list def)) | ||
| 105 | |||
| 106 | (defun use-global-mousemap (mousemap) | ||
| 107 | "Selects MOUSEMAP as the global mousemap." | ||
| 108 | (setq current-global-mousemap mousemap)) | ||
| 109 | |||
| 110 | (defun use-local-mousemap (mousemap) | ||
| 111 | "Selects MOUSEMAP as the local mousemap. | ||
| 112 | nil for MOUSEMAP means no local mousemap." | ||
| 113 | (setq current-local-mousemap mousemap)) | ||
| 114 | |||
| 115 | |||
| 116 | ;;; | ||
| 117 | ;;; Interface to the Mouse encoding defined in Emacstool.c | ||
| 118 | ;;; | ||
| 119 | ;;; Called when mouse-prefix is sent to emacs, additional | ||
| 120 | ;;; information is read in as a list (button x y time-delta) | ||
| 121 | ;;; | ||
| 122 | ;;; First, some generally useful functions: | ||
| 123 | ;;; | ||
| 124 | |||
| 125 | (defun logtest (x y) | ||
| 126 | "True if any bits set in X are also set in Y. | ||
| 127 | Just like the Common Lisp function of the same name." | ||
| 128 | (not (zerop (logand x y)))) | ||
| 129 | |||
| 130 | |||
| 131 | ;;; | ||
| 132 | ;;; Hit accessors. | ||
| 133 | ;;; | ||
| 134 | |||
| 135 | (defconst sm::ButtonBits 7) ; Lowest 3 bits. | ||
| 136 | (defconst sm::ShiftmaskBits 56) ; Second lowest 3 bits (56 = 63 - 7). | ||
| 137 | (defconst sm::DoubleBits 64) ; Bit 7. | ||
| 138 | (defconst sm::UpBits 128) ; Bit 8. | ||
| 139 | |||
| 140 | ;;; All the useful code bits | ||
| 141 | (defmacro sm::hit-code (hit) | ||
| 142 | `(nth 0 ,hit)) | ||
| 143 | ;;; The button, or buttons if a chord. | ||
| 144 | (defmacro sm::hit-button (hit) | ||
| 145 | `(logand sm::ButtonBits (nth 0 ,hit))) | ||
| 146 | ;;; The shift, control, and meta flags. | ||
| 147 | (defmacro sm::hit-shiftmask (hit) | ||
| 148 | `(logand sm::ShiftmaskBits (nth 0 ,hit))) | ||
| 149 | ;;; Set if a double click (but not a chord). | ||
| 150 | (defmacro sm::hit-double (hit) | ||
| 151 | `(logand sm::DoubleBits (nth 0 ,hit))) | ||
| 152 | ;;; Set on button release (as opposed to button press). | ||
| 153 | (defmacro sm::hit-up (hit) | ||
| 154 | `(logand sm::UpBits (nth 0 ,hit))) | ||
| 155 | ;;; Screen x position. | ||
| 156 | (defmacro sm::hit-x (hit) (list 'nth 1 hit)) | ||
| 157 | ;;; Screen y position. | ||
| 158 | (defmacro sm::hit-y (hit) (list 'nth 2 hit)) | ||
| 159 | ;;; Milliseconds since last hit. | ||
| 160 | (defmacro sm::hit-delta (hit) (list 'nth 3 hit)) | ||
| 161 | |||
| 162 | (defmacro sm::hit-up-p (hit) ; A predicate. | ||
| 163 | `(not (zerop (sm::hit-up ,hit)))) | ||
| 164 | |||
| 165 | ;;; | ||
| 166 | ;;; Loc accessors. for sm::window-xy | ||
| 167 | ;;; | ||
| 168 | (defmacro sm::loc-w (loc) (list 'nth 0 loc)) | ||
| 169 | (defmacro sm::loc-x (loc) (list 'nth 1 loc)) | ||
| 170 | (defmacro sm::loc-y (loc) (list 'nth 2 loc)) | ||
| 171 | |||
| 172 | (defmacro eval-in-buffer (buffer &rest forms) | ||
| 173 | "Macro to switches to BUFFER, evaluates FORMS, returns to original buffer." | ||
| 174 | ;; When you don't need the complete window context of eval-in-window | ||
| 175 | `(let ((StartBuffer (current-buffer))) | ||
| 176 | (unwind-protect | ||
| 177 | (progn | ||
| 178 | (set-buffer ,buffer) | ||
| 179 | ,@forms) | ||
| 180 | (set-buffer StartBuffer)))) | ||
| 181 | |||
| 182 | (put 'eval-in-buffer 'lisp-indent-function 1) | ||
| 183 | |||
| 184 | ;;; this is used extensively by sun-fns.el | ||
| 185 | ;;; | ||
| 186 | (defmacro eval-in-window (window &rest forms) | ||
| 187 | "Switch to WINDOW, evaluate FORMS, return to original window." | ||
| 188 | `(let ((OriginallySelectedWindow (selected-window))) | ||
| 189 | (unwind-protect | ||
| 190 | (progn | ||
| 191 | (select-window ,window) | ||
| 192 | ,@forms) | ||
| 193 | (select-window OriginallySelectedWindow)))) | ||
| 194 | (put 'eval-in-window 'lisp-indent-function 1) | ||
| 195 | |||
| 196 | ;;; | ||
| 197 | ;;; handy utility, generalizes window_loop | ||
| 198 | ;;; | ||
| 199 | |||
| 200 | ;;; It's a macro (and does not evaluate its arguments). | ||
| 201 | (defmacro eval-in-windows (form &optional yesmini) | ||
| 202 | "Switches to each window and evaluates FORM. Optional argument | ||
| 203 | YESMINI says to include the minibuffer as a window. | ||
| 204 | This is a macro, and does not evaluate its arguments." | ||
| 205 | `(let ((OriginallySelectedWindow (selected-window))) | ||
| 206 | (unwind-protect | ||
| 207 | (while (progn | ||
| 208 | ,form | ||
| 209 | (not (eq OriginallySelectedWindow | ||
| 210 | (select-window | ||
| 211 | (next-window nil ,yesmini)))))) | ||
| 212 | (select-window OriginallySelectedWindow)))) | ||
| 213 | (put 'eval-in-window 'lisp-indent-function 0) | ||
| 214 | |||
| 215 | (defun move-to-loc (x y) | ||
| 216 | "Move cursor to window location X, Y. | ||
| 217 | Handles wrapped and horizontally scrolled lines correctly." | ||
| 218 | (move-to-window-line y) | ||
| 219 | ;; window-line-end expects this to return the window column it moved to. | ||
| 220 | (let ((cc (current-column)) | ||
| 221 | (nc (move-to-column | ||
| 222 | (if (zerop (window-hscroll)) | ||
| 223 | (+ (current-column) | ||
| 224 | (min (- (window-width) 2) ; To stay on the line. | ||
| 225 | x)) | ||
| 226 | (+ (window-hscroll) -1 | ||
| 227 | (min (1- (window-width)) ; To stay on the line. | ||
| 228 | x)))))) | ||
| 229 | (- nc cc))) | ||
| 230 | |||
| 231 | |||
| 232 | (defun minibuffer-window-p (window) | ||
| 233 | "True if this WINDOW is minibuffer." | ||
| 234 | (= (frame-height) | ||
| 235 | (nth 3 (window-edges window)) ; The bottom edge. | ||
| 236 | )) | ||
| 237 | |||
| 238 | |||
| 239 | (defun sun-mouse-handler (&optional hit) | ||
| 240 | "Evaluates the function or list associated with a mouse hit. | ||
| 241 | Expecting to read a hit, which is a list: (button x y delta). | ||
| 242 | A form bound to button by define-mouse is found by mouse-lookup. | ||
| 243 | The variables: *mouse-window*, *mouse-x*, *mouse-y* are bound. | ||
| 244 | If the form is a symbol (symbolp), it is funcall'ed with *mouse-window*, | ||
| 245 | *mouse-x*, and *mouse-y* as arguments; if the form is a list (listp), | ||
| 246 | the form is eval'ed; if the form is neither of these, it is an error. | ||
| 247 | Returns nil." | ||
| 248 | (interactive) | ||
| 249 | (if (null hit) (setq hit (sm::combined-hits))) | ||
| 250 | (let ((loc (sm::window-xy (sm::hit-x hit) (sm::hit-y hit)))) | ||
| 251 | (let ((*mouse-window* (sm::loc-w loc)) | ||
| 252 | (*mouse-x* (sm::loc-x loc)) | ||
| 253 | (*mouse-y* (sm::loc-y loc)) | ||
| 254 | (mouse-code (mouse-event-code hit loc))) | ||
| 255 | (let ((form (eval-in-buffer (window-buffer *mouse-window*) | ||
| 256 | (mouse-lookup mouse-code)))) | ||
| 257 | (cond ((null form) | ||
| 258 | (if (not (sm::hit-up-p hit)) ; undefined up hits are ok. | ||
| 259 | (error "Undefined mouse event: %s" | ||
| 260 | (prin1-to-string | ||
| 261 | (mouse-code-to-mouse-list mouse-code))))) | ||
| 262 | ((symbolp form) | ||
| 263 | (setq this-command form) | ||
| 264 | (funcall form *mouse-window* *mouse-x* *mouse-y*)) | ||
| 265 | ((listp form) | ||
| 266 | (setq this-command (car form)) | ||
| 267 | (eval form)) | ||
| 268 | (t | ||
| 269 | (error "Mouse action must be symbol or list, but was: %s" | ||
| 270 | form)))))) | ||
| 271 | ;; Don't let 'sun-mouse-handler get on last-command, | ||
| 272 | ;; since this function should be transparent. | ||
| 273 | (if (eq this-command 'sun-mouse-handler) | ||
| 274 | (setq this-command last-command)) | ||
| 275 | ;; (message (prin1-to-string this-command)) ; to see what your buttons did | ||
| 276 | nil) | ||
| 277 | |||
| 278 | (defun sm::combined-hits () | ||
| 279 | "Read and return next mouse-hit, include possible double click" | ||
| 280 | (let ((hit1 (mouse-hit-read))) | ||
| 281 | (if (not (sm::hit-up-p hit1)) ; Up hits don't start doubles or chords. | ||
| 282 | (let ((hit2 (mouse-second-hit extra-click-wait))) | ||
| 283 | (if hit2 ; we cons'd it, we can smash it. | ||
| 284 | ; (setf (sm::hit-code hit1) (logior (sm::hit-code hit1) ...)) | ||
| 285 | (setcar hit1 (logior (sm::hit-code hit1) | ||
| 286 | (sm::hit-code hit2) | ||
| 287 | (if (= (sm::hit-button hit1) | ||
| 288 | (sm::hit-button hit2)) | ||
| 289 | sm::DoubleBits 0)))))) | ||
| 290 | hit1)) | ||
| 291 | |||
| 292 | (defun mouse-hit-read () | ||
| 293 | "Read mouse-hit list from keyboard. Like (read 'read-char), | ||
| 294 | but that uses minibuffer, and mucks up last-command." | ||
| 295 | (let ((char-list nil) (char nil)) | ||
| 296 | (while (not (equal 13 ; Carriage return. | ||
| 297 | (prog1 (setq char (read-char)) | ||
| 298 | (setq char-list (cons char char-list)))))) | ||
| 299 | (read (mapconcat 'char-to-string (nreverse char-list) "")) | ||
| 300 | )) | ||
| 301 | |||
| 302 | ;;; Second Click Hackery.... | ||
| 303 | ;;; if prefix is not mouse-prefix, need a way to unread the char... | ||
| 304 | ;;; or else have mouse flush input queue, or else need a peek at next char. | ||
| 305 | |||
| 306 | ;;; There is no peek, but since one character can be unread, we only | ||
| 307 | ;;; have to flush the queue when the command after a mouse click | ||
| 308 | ;;; starts with mouse-prefix1 (see below). | ||
| 309 | ;;; Something to do later: We could buffer the read commands and | ||
| 310 | ;;; execute them ourselves after doing the mouse command (using | ||
| 311 | ;;; lookup-key ??). | ||
| 312 | |||
| 313 | (defvar mouse-prefix1 24 ; C-x | ||
| 314 | "First char of mouse-prefix. Used to detect double clicks and chords.") | ||
| 315 | |||
| 316 | (defvar mouse-prefix2 0 ; C-@ | ||
| 317 | "Second char of mouse-prefix. Used to detect double clicks and chords.") | ||
| 318 | |||
| 319 | |||
| 320 | (defun mouse-second-hit (hit-wait) | ||
| 321 | "Returns the next mouse hit occurring within HIT-WAIT milliseconds." | ||
| 322 | (if (sit-for-millisecs hit-wait) nil ; No input within hit-wait millisecs. | ||
| 323 | (let ((pc1 (read-char))) | ||
| 324 | (if (or (not (equal pc1 mouse-prefix1)) | ||
| 325 | (sit-for-millisecs 3)) ; a mouse prefix will have second char | ||
| 326 | ;; Can get away with one unread. | ||
| 327 | (progn (setq unread-command-events (list pc1)) | ||
| 328 | nil) ; Next input not mouse event. | ||
| 329 | (let ((pc2 (read-char))) | ||
| 330 | (if (not (equal pc2 mouse-prefix2)) | ||
| 331 | (progn (setq unread-command-events (list pc1)) ; put back the ^X | ||
| 332 | ;;; Too bad can't do two: (setq unread-command-event (list pc1 pc2)) | ||
| 333 | ;;; Well, now we can, but I don't understand this code well enough to fix it... | ||
| 334 | (ding) ; user will have to retype that pc2. | ||
| 335 | nil) ; This input is not a mouse event. | ||
| 336 | ;; Next input has mouse prefix and is within time limit. | ||
| 337 | (let ((new-hit (mouse-hit-read))) ; Read the new hit. | ||
| 338 | (if (sm::hit-up-p new-hit) ; Ignore up events when timing. | ||
| 339 | (mouse-second-hit (- hit-wait (sm::hit-delta new-hit))) | ||
| 340 | new-hit ; New down hit within limit, return it. | ||
| 341 | )))))))) | ||
| 342 | |||
| 343 | (defun sm::window-xy (x y) | ||
| 344 | "Find window containing screen coordinates X and Y. | ||
| 345 | Returns list (window x y) where x and y are relative to window." | ||
| 346 | (or | ||
| 347 | (catch 'found | ||
| 348 | (eval-in-windows | ||
| 349 | (let ((we (window-edges (selected-window)))) | ||
| 350 | (let ((le (nth 0 we)) | ||
| 351 | (te (nth 1 we)) | ||
| 352 | (re (nth 2 we)) | ||
| 353 | (be (nth 3 we))) | ||
| 354 | (if (= re (frame-width)) | ||
| 355 | ;; include the continuation column with this window | ||
| 356 | (setq re (1+ re))) | ||
| 357 | (if (= be (frame-height)) | ||
| 358 | ;; include partial line at bottom of frame with this window | ||
| 359 | ;; id est, if window is not multiple of char size. | ||
| 360 | (setq be (1+ be))) | ||
| 361 | |||
| 362 | (if (and (>= x le) (< x re) | ||
| 363 | (>= y te) (< y be)) | ||
| 364 | (throw 'found | ||
| 365 | (list (selected-window) (- x le) (- y te)))))) | ||
| 366 | t)) ; include minibuffer in eval-in-windows | ||
| 367 | ;;If x,y from a real mouse click, we shouldn't get here. | ||
| 368 | (list nil x y) | ||
| 369 | )) | ||
| 370 | |||
| 371 | (defun sm::window-region (loc) | ||
| 372 | "Parse LOC into a region symbol. | ||
| 373 | Returns one of (text scrollbar modeline minibuffer)" | ||
| 374 | (let ((w (sm::loc-w loc)) | ||
| 375 | (x (sm::loc-x loc)) | ||
| 376 | (y (sm::loc-y loc))) | ||
| 377 | (let ((right (1- (window-width w))) | ||
| 378 | (bottom (1- (window-height w)))) | ||
| 379 | (cond ((minibuffer-window-p w) 'minibuffer) | ||
| 380 | ((>= y bottom) 'modeline) | ||
| 381 | ((>= x right) 'scrollbar) | ||
| 382 | ;; far right column (window separator) is always a scrollbar | ||
| 383 | ((and scrollbar-width | ||
| 384 | ;; mouse within scrollbar-width of edge. | ||
| 385 | (>= x (- right scrollbar-width)) | ||
| 386 | ;; mouse a few chars past the end of line. | ||
| 387 | (>= x (+ 2 (window-line-end w x y)))) | ||
| 388 | 'scrollbar) | ||
| 389 | (t 'text))))) | ||
| 390 | |||
| 391 | (defun window-line-end (w x y) | ||
| 392 | "Return WINDOW column (ignore X) containing end of line Y" | ||
| 393 | (eval-in-window w (save-excursion (move-to-loc (frame-width) y)))) | ||
| 394 | |||
| 395 | ;;; | ||
| 396 | ;;; The encoding of mouse events into a mousemap. | ||
| 397 | ;;; These values must agree with coding in emacstool: | ||
| 398 | ;;; | ||
| 399 | (defconst sm::keyword-alist | ||
| 400 | '((left . 1) (middle . 2) (right . 4) | ||
| 401 | (shift . 8) (control . 16) (meta . 32) (double . 64) (up . 128) | ||
| 402 | (text . 256) (scrollbar . 512) (modeline . 1024) (minibuffer . 2048) | ||
| 403 | )) | ||
| 404 | |||
| 405 | (defun mouse-event-code (hit loc) | ||
| 406 | "Maps MOUSE-HIT and LOC into a mouse-code." | ||
| 407 | ;;;Region is a code for one of text, modeline, scrollbar, or minibuffer. | ||
| 408 | (logior (sm::hit-code hit) | ||
| 409 | (mouse-region-to-code (sm::window-region loc)))) | ||
| 410 | |||
| 411 | (defun mouse-region-to-code (region) | ||
| 412 | "Returns partial mouse-code for specified REGION." | ||
| 413 | (cdr (assq region sm::keyword-alist))) | ||
| 414 | |||
| 415 | (defun mouse-list-to-mouse-code (mouse-list) | ||
| 416 | "Map a MOUSE-LIST to a mouse-code." | ||
| 417 | (apply 'logior | ||
| 418 | (mapcar (function (lambda (x) | ||
| 419 | (cdr (assq x sm::keyword-alist)))) | ||
| 420 | mouse-list))) | ||
| 421 | |||
| 422 | (defun mouse-code-to-mouse-list (mouse-code) | ||
| 423 | "Map a MOUSE-CODE to a mouse-list." | ||
| 424 | (apply 'nconc (mapcar | ||
| 425 | (function (lambda (x) | ||
| 426 | (if (logtest mouse-code (cdr x)) | ||
| 427 | (list (car x))))) | ||
| 428 | sm::keyword-alist))) | ||
| 429 | |||
| 430 | (defun mousemap-set (code mousemap value) | ||
| 431 | (let* ((alist (cdr mousemap)) | ||
| 432 | (assq-result (assq code alist))) | ||
| 433 | (if assq-result | ||
| 434 | (setcdr assq-result value) | ||
| 435 | (setcdr mousemap (cons (cons code value) alist))))) | ||
| 436 | |||
| 437 | (defun mousemap-get (code mousemap) | ||
| 438 | (cdr (assq code (cdr mousemap)))) | ||
| 439 | |||
| 440 | (defun mouse-lookup (mouse-code) | ||
| 441 | "Look up MOUSE-EVENT and return the definition. nil means undefined." | ||
| 442 | (or (mousemap-get mouse-code current-local-mousemap) | ||
| 443 | (mousemap-get mouse-code current-global-mousemap))) | ||
| 444 | |||
| 445 | ;;; | ||
| 446 | ;;; I (jpeck) don't understand the utility of the next four functions | ||
| 447 | ;;; ask Steven Greenbaum <froud@kestrel> | ||
| 448 | ;;; | ||
| 449 | (defun mouse-mask-lookup (mask list) | ||
| 450 | "Args MASK (a bit mask) and LIST (a list of (code . form) pairs). | ||
| 451 | Returns a list of elements of LIST whose code or'ed with MASK is non-zero." | ||
| 452 | (let ((result nil)) | ||
| 453 | (while list | ||
| 454 | (if (logtest mask (car (car list))) | ||
| 455 | (setq result (cons (car list) result))) | ||
| 456 | (setq list (cdr list))) | ||
| 457 | result)) | ||
| 458 | |||
| 459 | (defun mouse-union (l l-unique) | ||
| 460 | "Return the union of list of mouse (code . form) pairs L and L-UNIQUE, | ||
| 461 | where L-UNIQUE is considered to be union'ized already." | ||
| 462 | (let ((result l-unique)) | ||
| 463 | (while l | ||
| 464 | (let ((code-form-pair (car l))) | ||
| 465 | (if (not (assq (car code-form-pair) result)) | ||
| 466 | (setq result (cons code-form-pair result)))) | ||
| 467 | (setq l (cdr l))) | ||
| 468 | result)) | ||
| 469 | |||
| 470 | (defun mouse-union-first-preferred (l1 l2) | ||
| 471 | "Return the union of lists of mouse (code . form) pairs L1 and L2, | ||
| 472 | based on the code's, with preference going to elements in L1." | ||
| 473 | (mouse-union l2 (mouse-union l1 nil))) | ||
| 474 | |||
| 475 | (defun mouse-code-function-pairs-of-region (region) | ||
| 476 | "Return a list of (code . function) pairs, where each code is | ||
| 477 | currently set in the REGION." | ||
| 478 | (let ((mask (mouse-region-to-code region))) | ||
| 479 | (mouse-union-first-preferred | ||
| 480 | (mouse-mask-lookup mask (cdr current-local-mousemap)) | ||
| 481 | (mouse-mask-lookup mask (cdr current-global-mousemap)) | ||
| 482 | ))) | ||
| 483 | |||
| 484 | ;;; | ||
| 485 | ;;; Functions for DESCRIBE-MOUSE-BINDINGS | ||
| 486 | ;;; And other mouse documentation functions | ||
| 487 | ;;; Still need a good procedure to print out a help sheet in readable format. | ||
| 488 | ;;; | ||
| 489 | |||
| 490 | (defun one-line-doc-string (function) | ||
| 491 | "Returns first line of documentation string for FUNCTION. | ||
| 492 | If there is no documentation string, then the string | ||
| 493 | \"No documentation\" is returned." | ||
| 494 | (while (consp function) (setq function (car function))) | ||
| 495 | (let ((doc (documentation function))) | ||
| 496 | (if (null doc) | ||
| 497 | "No documentation." | ||
| 498 | (string-match "^.*$" doc) | ||
| 499 | (substring doc 0 (match-end 0))))) | ||
| 500 | |||
| 501 | (defun print-mouse-format (binding) | ||
| 502 | (princ (car binding)) | ||
| 503 | (princ ": ") | ||
| 504 | (mapc (function | ||
| 505 | (lambda (mouse-list) | ||
| 506 | (princ mouse-list) | ||
| 507 | (princ " "))) | ||
| 508 | (cdr binding)) | ||
| 509 | (terpri) | ||
| 510 | (princ " ") | ||
| 511 | (princ (one-line-doc-string (car binding))) | ||
| 512 | (terpri) | ||
| 513 | ) | ||
| 514 | |||
| 515 | (defun print-mouse-bindings (region) | ||
| 516 | "Prints mouse-event bindings for REGION." | ||
| 517 | (mapcar 'print-mouse-format (sm::event-bindings region))) | ||
| 518 | |||
| 519 | (defun sm::event-bindings (region) | ||
| 520 | "Returns an alist of (function . (mouse-list1 ... mouse-listN)) for REGION, | ||
| 521 | where each mouse-list is bound to the function in REGION." | ||
| 522 | (let ((mouse-bindings (mouse-code-function-pairs-of-region region)) | ||
| 523 | (result nil)) | ||
| 524 | (while mouse-bindings | ||
| 525 | (let* ((code-function-pair (car mouse-bindings)) | ||
| 526 | (current-entry (assoc (cdr code-function-pair) result))) | ||
| 527 | (if current-entry | ||
| 528 | (setcdr current-entry | ||
| 529 | (cons (mouse-code-to-mouse-list (car code-function-pair)) | ||
| 530 | (cdr current-entry))) | ||
| 531 | (setq result (cons (cons (cdr code-function-pair) | ||
| 532 | (list (mouse-code-to-mouse-list | ||
| 533 | (car code-function-pair)))) | ||
| 534 | result)))) | ||
| 535 | (setq mouse-bindings (cdr mouse-bindings)) | ||
| 536 | ) | ||
| 537 | result)) | ||
| 538 | |||
| 539 | (defun describe-mouse-bindings () | ||
| 540 | "Lists all current mouse-event bindings." | ||
| 541 | (interactive) | ||
| 542 | (with-output-to-temp-buffer "*Help*" | ||
| 543 | (princ "Text Region") (terpri) | ||
| 544 | (princ "---- ------") (terpri) | ||
| 545 | (print-mouse-bindings 'text) (terpri) | ||
| 546 | (princ "Modeline Region") (terpri) | ||
| 547 | (princ "-------- ------") (terpri) | ||
| 548 | (print-mouse-bindings 'modeline) (terpri) | ||
| 549 | (princ "Scrollbar Region") (terpri) | ||
| 550 | (princ "--------- ------") (terpri) | ||
| 551 | (print-mouse-bindings 'scrollbar))) | ||
| 552 | |||
| 553 | (defun describe-mouse-briefly (mouse-list) | ||
| 554 | "Print a short description of the function bound to MOUSE-LIST." | ||
| 555 | (interactive "xDescribe mouse list briefly: ") | ||
| 556 | (let ((function (mouse-lookup (mouse-list-to-mouse-code mouse-list)))) | ||
| 557 | (if function | ||
| 558 | (message "%s runs the command %s" mouse-list function) | ||
| 559 | (message "%s is undefined" mouse-list)))) | ||
| 560 | |||
| 561 | (defun mouse-help-menu (function-and-binding) | ||
| 562 | (cons (prin1-to-string (car function-and-binding)) | ||
| 563 | (menu-create ; Two sub-menu items of form ("String" . nil) | ||
| 564 | (list (list (one-line-doc-string (car function-and-binding))) | ||
| 565 | (list (prin1-to-string (cdr function-and-binding))))))) | ||
| 566 | |||
| 567 | (defun mouse-help-region (w x y &optional region) | ||
| 568 | "Displays a menu of mouse functions callable in this region." | ||
| 569 | (let* ((region (or region (sm::window-region (list w x y)))) | ||
| 570 | (mlist (mapcar (function mouse-help-menu) | ||
| 571 | (sm::event-bindings region))) | ||
| 572 | (menu (menu-create (cons (list (symbol-name region)) mlist))) | ||
| 573 | (item (sun-menu-evaluate w 0 y menu)) | ||
| 574 | ))) | ||
| 575 | |||
| 576 | ;;; | ||
| 577 | ;;; Menu interface functions | ||
| 578 | ;;; | ||
| 579 | ;;; use defmenu, because this interface is subject to change | ||
| 580 | ;;; really need a menu-p, but we use vectorp and the context... | ||
| 581 | ;;; | ||
| 582 | (defun menu-create (items) | ||
| 583 | "Functional form for defmenu, given a list of ITEMS returns a menu. | ||
| 584 | Each ITEM is a (STRING . VALUE) pair." | ||
| 585 | (apply 'vector items) | ||
| 586 | ) | ||
| 587 | |||
| 588 | (defmacro defmenu (menu &rest itemlist) | ||
| 589 | "Defines MENU to be a menu, the ITEMS are (STRING . VALUE) pairs. | ||
| 590 | See sun-menu-evaluate for interpretation of ITEMS." | ||
| 591 | (list 'defconst menu (funcall 'menu-create itemlist)) | ||
| 592 | ) | ||
| 593 | |||
| 594 | (defun sun-menu-evaluate (*menu-window* *menu-x* *menu-y* menu) | ||
| 595 | "Display a pop-up menu in WINDOW at X Y and evaluate selected item | ||
| 596 | of MENU. MENU (or its symbol-value) should be a menu defined by defmenu. | ||
| 597 | A menu ITEM is a (STRING . FORM) pair; | ||
| 598 | the FORM associated with the selected STRING is evaluated, | ||
| 599 | and the resulting value is returned. Generally these FORMs are | ||
| 600 | evaluated for their side-effects rather than their values. | ||
| 601 | If the selected form is a menu or a symbol whose value is a menu, | ||
| 602 | then it is displayed and evaluated as a pullright menu item. | ||
| 603 | If the FORM of the first ITEM is nil, the STRING of the item | ||
| 604 | is used as a label for the menu, i.e. it's inverted and not selectable." | ||
| 605 | |||
| 606 | (if (symbolp menu) (setq menu (symbol-value menu))) | ||
| 607 | (eval (sun-menu-internal *menu-window* *menu-x* *menu-y* 4 menu))) | ||
| 608 | |||
| 609 | (defun sun-get-frame-data (code) | ||
| 610 | "Sends the tty-sub-window escape sequence CODE to terminal, | ||
| 611 | and returns a cons of the two numbers in returned escape sequence. | ||
| 612 | That is it returns (cons <car> <cdr>) from \"\\E[n;<car>;<cdr>t\". | ||
| 613 | CODE values: 13 = Tool-Position, 14 = Size-in-Pixels, 18 = Size-in-Chars." | ||
| 614 | (send-string-to-terminal (concat "\033[" (int-to-string code) "t")) | ||
| 615 | (let (char str x y) | ||
| 616 | (while (not (equal 116 (setq char (read-char)))) ; #\t = 116 | ||
| 617 | (setq str (cons char str))) | ||
| 618 | (setq str (mapconcat 'char-to-string (nreverse str) "")) | ||
| 619 | (string-match ";[0-9]*" str) | ||
| 620 | (setq y (substring str (1+ (match-beginning 0)) (match-end 0))) | ||
| 621 | (setq str (substring str (match-end 0))) | ||
| 622 | (string-match ";[0-9]*" str) | ||
| 623 | (setq x (substring str (1+ (match-beginning 0)) (match-end 0))) | ||
| 624 | (cons (string-to-number y) (string-to-number x)))) | ||
| 625 | |||
| 626 | (defun sm::font-size () | ||
| 627 | "Returns font size in pixels: (cons Ysize Xsize)" | ||
| 628 | (let ((pix (sun-get-frame-data 14)) ; returns size in pixels | ||
| 629 | (chr (sun-get-frame-data 18))) ; returns size in chars | ||
| 630 | (cons (/ (car pix) (car chr)) (/ (cdr pix) (cdr chr))))) | ||
| 631 | |||
| 632 | (defvar sm::menu-kludge-x nil | ||
| 633 | "Cached frame-to-window X-Offset for sm::menu-kludge") | ||
| 634 | (defvar sm::menu-kludge-y nil | ||
| 635 | "Cached frame-to-window Y-Offset for sm::menu-kludge") | ||
| 636 | |||
| 637 | (defun sm::menu-kludge () | ||
| 638 | "If sunfns.c uses <Menu_Base_Kludge> this function must be here!" | ||
| 639 | (or sm::menu-kludge-y | ||
| 640 | (let ((fs (sm::font-size))) | ||
| 641 | (setq sm::menu-kludge-y (+ 8 (car fs)) ; a title line and borders | ||
| 642 | sm::menu-kludge-x 4))) ; best values depend on .defaults/Menu | ||
| 643 | (let ((wl (sun-get-frame-data 13))) ; returns frame location | ||
| 644 | (cons (+ (car wl) sm::menu-kludge-y) | ||
| 645 | (+ (cdr wl) sm::menu-kludge-x)))) | ||
| 646 | |||
| 647 | ;;; | ||
| 648 | ;;; Function interface to selection/region | ||
| 649 | ;;; primitive functions are defined in sunfns.c | ||
| 650 | ;;; | ||
| 651 | (defun sun-yank-selection () | ||
| 652 | "Set mark and yank the contents of the current sunwindows selection. | ||
| 653 | Insert contents into the current buffer at point." | ||
| 654 | (interactive "*") | ||
| 655 | (set-mark-command nil) | ||
| 656 | (insert (sun-get-selection))) | ||
| 657 | |||
| 658 | (defun sun-select-region (beg end) | ||
| 659 | "Set the sunwindows selection to the region in the current buffer." | ||
| 660 | (interactive "r") | ||
| 661 | (sun-set-selection (buffer-substring beg end))) | ||
| 662 | |||
| 663 | (provide 'sun-mouse) | ||
| 664 | (provide 'term/sun-mouse) ; have to (require 'term/sun-mouse) | ||
| 665 | |||
| 666 | ;;; arch-tag: 6e879372-b899-4509-833f-d7f6250e309a | ||
| 667 | ;;; sun-mouse.el ends here | ||
diff --git a/lisp/term/sun.el b/lisp/term/sun.el index 4736e57340c..22b29c92790 100644 --- a/lisp/term/sun.el +++ b/lisp/term/sun.el | |||
| @@ -47,14 +47,6 @@ | |||
| 47 | (setq this-command 'kill-region-and-unmark) | 47 | (setq this-command 'kill-region-and-unmark) |
| 48 | (set-mark-command t)) | 48 | (set-mark-command t)) |
| 49 | 49 | ||
| 50 | (defun select-previous-complex-command () | ||
| 51 | "Select Previous-complex-command" | ||
| 52 | (interactive) | ||
| 53 | (if (zerop (minibuffer-depth)) | ||
| 54 | (repeat-complex-command 1) | ||
| 55 | ;; FIXME: this function does not seem to exist. -stef'01 | ||
| 56 | (previous-complex-command 1))) | ||
| 57 | |||
| 58 | (defun rerun-prev-command () | 50 | (defun rerun-prev-command () |
| 59 | "Repeat Previous-complex-command." | 51 | "Repeat Previous-complex-command." |
| 60 | (interactive) | 52 | (interactive) |
diff --git a/src/ChangeLog b/src/ChangeLog index 638ca30e047..4e93e3937f6 100644 --- a/src/ChangeLog +++ b/src/ChangeLog | |||
| @@ -1,3 +1,11 @@ | |||
| 1 | 2007-11-01 Dan Nicolaescu <dann@ics.uci.edu> | ||
| 2 | |||
| 3 | * sunfns.c: Remove file | ||
| 4 | |||
| 5 | * m/sun386.h: | ||
| 6 | * m/sun2.h: | ||
| 7 | * m/sparc.h: Remove Sun windows code. | ||
| 8 | |||
| 1 | 2007-10-31 Stefan Monnier <monnier@iro.umontreal.ca> | 9 | 2007-10-31 Stefan Monnier <monnier@iro.umontreal.ca> |
| 2 | 10 | ||
| 3 | * keyboard.c (syms_of_keyboard): Initialize the initial_kboard. | 11 | * keyboard.c (syms_of_keyboard): Initialize the initial_kboard. |
diff --git a/src/m/sparc.h b/src/m/sparc.h index 8df81ee91aa..bf122d857cc 100644 --- a/src/m/sparc.h +++ b/src/m/sparc.h | |||
| @@ -64,18 +64,6 @@ NOTE-END */ | |||
| 64 | 64 | ||
| 65 | #define SEGMENT_MASK (SEGSIZ - 1) | 65 | #define SEGMENT_MASK (SEGSIZ - 1) |
| 66 | 66 | ||
| 67 | /* Arrange to link with sun windows, if requested. */ | ||
| 68 | /* For details on emacstool and sunfns, see etc/SUN-SUPPORT */ | ||
| 69 | /* These programs require Sun UNIX 4.2 Release 3.2 or greater */ | ||
| 70 | |||
| 71 | #ifdef HAVE_SUN_WINDOWS | ||
| 72 | #define OTHER_FILES ${etcdir}emacstool | ||
| 73 | #define LIBS_MACHINE -lsuntool -lsunwindow -lpixrect | ||
| 74 | #define OBJECTS_MACHINE sunfns.o | ||
| 75 | #define SYMS_MACHINE syms_of_sunfns () | ||
| 76 | #define PURESIZE 130000 | ||
| 77 | #endif | ||
| 78 | |||
| 79 | #if !defined (__NetBSD__) && !defined (__linux__) && !defined (__OpenBSD__) | 67 | #if !defined (__NetBSD__) && !defined (__linux__) && !defined (__OpenBSD__) |
| 80 | /* This really belongs in s/sun.h. */ | 68 | /* This really belongs in s/sun.h. */ |
| 81 | 69 | ||
diff --git a/src/m/sun2.h b/src/m/sun2.h index e764ded3ce7..a872bf6f3bb 100644 --- a/src/m/sun2.h +++ b/src/m/sun2.h | |||
| @@ -85,17 +85,5 @@ NOTE-END */ | |||
| 85 | 85 | ||
| 86 | #define SEGMENT_MASK (SEGSIZ - 1) | 86 | #define SEGMENT_MASK (SEGSIZ - 1) |
| 87 | 87 | ||
| 88 | /* Arrange to link with sun windows, if requested. */ | ||
| 89 | /* For details on emacstool and sunfns, see etc/SUN-SUPPORT */ | ||
| 90 | /* These programs require Sun UNIX 4.2 Release 3.2 or greater */ | ||
| 91 | |||
| 92 | #ifdef HAVE_SUN_WINDOWS | ||
| 93 | #define OTHER_FILES ${libsrc}emacstool | ||
| 94 | #define LIBS_MACHINE -lsuntool -lsunwindow -lpixrect | ||
| 95 | #define OBJECTS_MACHINE sunfns.o | ||
| 96 | #define SYMS_MACHINE syms_of_sunfns () | ||
| 97 | #define PURESIZE 132000 | ||
| 98 | #endif | ||
| 99 | |||
| 100 | /* arch-tag: 543c3570-74ca-4099-aa47-db7c7b691c8e | 88 | /* arch-tag: 543c3570-74ca-4099-aa47-db7c7b691c8e |
| 101 | (do not change this comment) */ | 89 | (do not change this comment) */ |
diff --git a/src/m/sun386.h b/src/m/sun386.h index a3eedbe755e..ed98960c809 100644 --- a/src/m/sun386.h +++ b/src/m/sun386.h | |||
| @@ -56,18 +56,6 @@ NOTE-END */ | |||
| 56 | 56 | ||
| 57 | #define LIBS_TERMCAP -ltermcap | 57 | #define LIBS_TERMCAP -ltermcap |
| 58 | 58 | ||
| 59 | /* Arrange to link with sun windows, if requested. */ | ||
| 60 | /* For details on emacstool and sunfns, see etc/SUN-SUPPORT */ | ||
| 61 | /* These programs require Sun UNIX 4.2 Release 3.2 or greater */ | ||
| 62 | |||
| 63 | #ifdef HAVE_SUN_WINDOWS | ||
| 64 | #define OTHER_FILES ${etcdir}emacstool | ||
| 65 | #define LIBS_MACHINE -lsuntool -lsunwindow -lpixrect | ||
| 66 | #define OBJECTS_MACHINE sunfns.o | ||
| 67 | #define SYMS_MACHINE syms_of_sunfns () | ||
| 68 | #define PURESIZE 132000 | ||
| 69 | #endif | ||
| 70 | |||
| 71 | /* Roadrunner uses 'COFF' format */ | 59 | /* Roadrunner uses 'COFF' format */ |
| 72 | #define COFF | 60 | #define COFF |
| 73 | 61 | ||
diff --git a/src/sunfns.c b/src/sunfns.c deleted file mode 100644 index 86e64cbcdcc..00000000000 --- a/src/sunfns.c +++ /dev/null | |||
| @@ -1,519 +0,0 @@ | |||
| 1 | /* Functions for Sun Windows menus and selection buffer. | ||
| 2 | Copyright (C) 1987, 1999, 2001, 2002, 2003, 2004, | ||
| 3 | 2005, 2006, 2007 Free Software Foundation, Inc. | ||
| 4 | |||
| 5 | This file is probably totally obsolete. In any case, the FSF is | ||
| 6 | unwilling to support it. We agreed to include it in our distribution | ||
| 7 | only on the understanding that we would spend no time at all on it. | ||
| 8 | |||
| 9 | If you have complaints about this file, send them to peck@sun.com. | ||
| 10 | If no one at Sun wants to maintain this, then consider it not | ||
| 11 | maintained at all. It would be a bad thing for the GNU project if | ||
| 12 | this file took our effort away from higher-priority things. | ||
| 13 | |||
| 14 | |||
| 15 | This file is part of GNU Emacs. | ||
| 16 | |||
| 17 | GNU Emacs is free software; you can redistribute it and/or modify | ||
| 18 | it under the terms of the GNU General Public License as published by | ||
| 19 | the Free Software Foundation; either version 3, or (at your option) | ||
| 20 | any later version. | ||
| 21 | |||
| 22 | GNU Emacs is distributed in the hope that it will be useful, | ||
| 23 | but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 24 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 25 | GNU General Public License for more details. | ||
| 26 | |||
| 27 | You should have received a copy of the GNU General Public License | ||
| 28 | along with GNU Emacs; see the file COPYING. If not, write to | ||
| 29 | the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, | ||
| 30 | Boston, MA 02110-1301, USA. */ | ||
| 31 | |||
| 32 | /* Author: Jeff Peck, Sun Microsystems, Inc. <peck@sun.com> | ||
| 33 | Original ideas by David Kastan and Eric Negaard, SRI International | ||
| 34 | Major help from: Steve Greenbaum, Reasoning Systems, Inc. | ||
| 35 | <froud@kestrel.arpa> | ||
| 36 | who first discovered the Menu_Base_Kludge. | ||
| 37 | */ | ||
| 38 | |||
| 39 | /* | ||
| 40 | * Emacs Lisp-Callable functions for sunwindows | ||
| 41 | */ | ||
| 42 | #include <config.h> | ||
| 43 | |||
| 44 | #include <stdio.h> | ||
| 45 | #include <errno.h> | ||
| 46 | #include <signal.h> | ||
| 47 | #include <sunwindow/window_hs.h> | ||
| 48 | #include <suntool/selection.h> | ||
| 49 | #include <suntool/menu.h> | ||
| 50 | #include <suntool/walkmenu.h> | ||
| 51 | #include <suntool/frame.h> | ||
| 52 | #include <suntool/window.h> | ||
| 53 | |||
| 54 | #include <fcntl.h> | ||
| 55 | #undef NULL /* We don't need sunview's idea of NULL */ | ||
| 56 | #include "lisp.h" | ||
| 57 | #include "window.h" | ||
| 58 | #include "buffer.h" | ||
| 59 | #include "termhooks.h" | ||
| 60 | |||
| 61 | /* conversion to/from character & frame coordinates */ | ||
| 62 | /* From Gosling Emacs SunWindow driver by Chris Torek */ | ||
| 63 | |||
| 64 | /* Chars to frame coords. Note that we speak in zero origin. */ | ||
| 65 | #define CtoSX(cx) ((cx) * Sun_Font_Xsize) | ||
| 66 | #define CtoSY(cy) ((cy) * Sun_Font_Ysize) | ||
| 67 | |||
| 68 | /* Frame coords to chars */ | ||
| 69 | #define StoCX(sx) ((sx) / Sun_Font_Xsize) | ||
| 70 | #define StoCY(sy) ((sy) / Sun_Font_Ysize) | ||
| 71 | |||
| 72 | #define CHECK_GFX(x) if((win_fd<0)&&(Fsun_window_init(),(win_fd<0)))return(x) | ||
| 73 | int win_fd = -1; | ||
| 74 | struct pixfont *Sun_Font; /* The font */ | ||
| 75 | int Sun_Font_Xsize; /* Width of font */ | ||
| 76 | int Sun_Font_Ysize; /* Height of font */ | ||
| 77 | |||
| 78 | #define Menu_Base_Kludge /* until menu_show_using_fd gets fixed */ | ||
| 79 | #ifdef Menu_Base_Kludge | ||
| 80 | static Frame Menu_Base_Frame; | ||
| 81 | static int Menu_Base_fd; | ||
| 82 | static Lisp_Object sm_kludge_string; | ||
| 83 | #endif | ||
| 84 | struct cursor CurrentCursor; /* The current cursor */ | ||
| 85 | |||
| 86 | static short CursorData[16]; /* Build cursor here */ | ||
| 87 | static mpr_static(CursorMpr, 16, 16, 1, CursorData); | ||
| 88 | static struct cursor NewCursor = {0, 0, PIX_SRC ^ PIX_DST, &CursorMpr}; | ||
| 89 | |||
| 90 | #define RIGHT_ARROW_CURSOR /* if you want the right arrow */ | ||
| 91 | #ifdef RIGHT_ARROW_CURSOR | ||
| 92 | /* The default right-arrow cursor, with XOR drawing. */ | ||
| 93 | static short ArrowCursorData[16] = { | ||
| 94 | 0x0001,0x0003,0x0007,0x000F,0x001F,0x003F,0x007F,0x000F, | ||
| 95 | 0x001B,0x0019,0x0030,0x0030,0x0060,0x0060,0x00C0,0x00C0}; | ||
| 96 | static mpr_static(ArrowCursorMpr, 16, 16, 1, ArrowCursorData); | ||
| 97 | struct cursor DefaultCursor = {15, 0, PIX_SRC ^ PIX_DST, &ArrowCursorMpr}; | ||
| 98 | |||
| 99 | #else | ||
| 100 | /* The default left-arrow cursor, with XOR drawing. */ | ||
| 101 | static short ArrowCursorData[16] = { | ||
| 102 | 0x8000,0xC000,0xE000,0xF000,0xF800,0xFC00,0xFE00,0xF000, | ||
| 103 | 0xD800,0x9800,0x0C00,0x0C00,0x0600,0x0600,0x0300,0x0300}; | ||
| 104 | static mpr_static(ArrowCursorMpr, 16, 16, 1, ArrowCursorData); | ||
| 105 | struct cursor DefaultCursor = {0, 0, PIX_SRC ^ PIX_DST, &ArrowCursorMpr}; | ||
| 106 | #endif | ||
| 107 | |||
| 108 | /* | ||
| 109 | * Initialize window | ||
| 110 | */ | ||
| 111 | DEFUN ("sun-window-init", Fsun_window_init, Ssun_window_init, 0, 1, 0, | ||
| 112 | doc: /* One time setup for using Sun Windows with mouse. | ||
| 113 | Unless optional argument FORCE is non-nil, is a noop after its first call. | ||
| 114 | Returns a number representing the file descriptor of the open Sun Window, | ||
| 115 | or -1 if can not open it. */) | ||
| 116 | (force) | ||
| 117 | Lisp_Object force; | ||
| 118 | { | ||
| 119 | char *cp; | ||
| 120 | static int already_initialized = 0; | ||
| 121 | |||
| 122 | if ((! already_initialized) || (!NILP(force))) { | ||
| 123 | cp = getenv("WINDOW_GFX"); | ||
| 124 | if (cp != 0) win_fd = emacs_open (cp, O_RDWR, 0); | ||
| 125 | if (win_fd > 0) | ||
| 126 | { | ||
| 127 | Sun_Font = pf_default(); | ||
| 128 | Sun_Font_Xsize = Sun_Font->pf_defaultsize.x; | ||
| 129 | Sun_Font_Ysize = Sun_Font->pf_defaultsize.y; | ||
| 130 | Fsun_change_cursor_icon (Qnil); /* set up the default cursor */ | ||
| 131 | already_initialized = 1; | ||
| 132 | #ifdef Menu_Base_Kludge | ||
| 133 | |||
| 134 | /* Make a frame to use for putting the menu on, and get its fd. */ | ||
| 135 | Menu_Base_Frame = window_create(0, FRAME, | ||
| 136 | WIN_X, 0, WIN_Y, 0, | ||
| 137 | WIN_ROWS, 1, WIN_COLUMNS, 1, | ||
| 138 | WIN_SHOW, FALSE, | ||
| 139 | FRAME_NO_CONFIRM, 1, | ||
| 140 | 0); | ||
| 141 | Menu_Base_fd = (int) window_get(Menu_Base_Frame, WIN_FD); | ||
| 142 | #endif | ||
| 143 | } | ||
| 144 | } | ||
| 145 | return(make_number(win_fd)); | ||
| 146 | } | ||
| 147 | |||
| 148 | /* | ||
| 149 | * Mouse sit-for (allows a shorter interval than the regular sit-for | ||
| 150 | * and can be interrupted by the mouse) | ||
| 151 | */ | ||
| 152 | DEFUN ("sit-for-millisecs", Fsit_for_millisecs, Ssit_for_millisecs, 1, 1, 0, | ||
| 153 | doc: /* Like sit-for, but ARG is milliseconds. | ||
| 154 | Perform redisplay, then wait for ARG milliseconds or until | ||
| 155 | input is available. Returns t if wait completed with no input. | ||
| 156 | Redisplay does not happen if input is available before it starts. */) | ||
| 157 | (n) | ||
| 158 | Lisp_Object n; | ||
| 159 | { | ||
| 160 | struct timeval Timeout; | ||
| 161 | int waitmask = 1; | ||
| 162 | |||
| 163 | CHECK_NUMBER (n); | ||
| 164 | Timeout.tv_sec = XINT(n) / 1000; | ||
| 165 | Timeout.tv_usec = (XINT(n) - (Timeout.tv_sec * 1000)) * 1000; | ||
| 166 | |||
| 167 | if (detect_input_pending()) return(Qnil); | ||
| 168 | redisplay_preserve_echo_area (16); | ||
| 169 | /* | ||
| 170 | * Check for queued keyboard input/mouse hits again | ||
| 171 | * (A bit screen update can take some time!) | ||
| 172 | */ | ||
| 173 | if (detect_input_pending()) return(Qnil); | ||
| 174 | select(1,&waitmask,0,0,&Timeout); | ||
| 175 | if (detect_input_pending()) return(Qnil); | ||
| 176 | return(Qt); | ||
| 177 | } | ||
| 178 | |||
| 179 | /* | ||
| 180 | * Sun sleep-for (allows a shorter interval than the regular sleep-for) | ||
| 181 | */ | ||
| 182 | DEFUN ("sleep-for-millisecs", | ||
| 183 | Fsleep_for_millisecs, | ||
| 184 | Ssleep_for_millisecs, 1, 1, 0, | ||
| 185 | doc: /* Pause, without updating display, for ARG milliseconds. */) | ||
| 186 | (n) | ||
| 187 | Lisp_Object n; | ||
| 188 | { | ||
| 189 | unsigned useconds; | ||
| 190 | |||
| 191 | CHECK_NUMBER (n); | ||
| 192 | useconds = XINT(n) * 1000; | ||
| 193 | usleep(useconds); | ||
| 194 | return(Qt); | ||
| 195 | } | ||
| 196 | |||
| 197 | DEFUN ("update-display", Fupdate_display, Supdate_display, 0, 0, 0, | ||
| 198 | doc: /* Perform redisplay. */) | ||
| 199 | () | ||
| 200 | { | ||
| 201 | redisplay_preserve_echo_area (17); | ||
| 202 | return(Qt); | ||
| 203 | } | ||
| 204 | |||
| 205 | |||
| 206 | /* | ||
| 207 | * Change the Sun mouse icon | ||
| 208 | */ | ||
| 209 | DEFUN ("sun-change-cursor-icon", | ||
| 210 | Fsun_change_cursor_icon, | ||
| 211 | Ssun_change_cursor_icon, 1, 1, 0, | ||
| 212 | doc: /* Change the Sun mouse cursor icon. | ||
| 213 | ICON is a lisp vector whose 1st element | ||
| 214 | is the X offset of the cursor hot-point, whose 2nd element is the Y offset | ||
| 215 | of the cursor hot-point and whose 3rd element is the cursor pixel data | ||
| 216 | expressed as a string. If ICON is nil then the original arrow cursor is used. */) | ||
| 217 | (Icon) | ||
| 218 | Lisp_Object Icon; | ||
| 219 | { | ||
| 220 | register unsigned char *cp; | ||
| 221 | register short *p; | ||
| 222 | register int i; | ||
| 223 | Lisp_Object X_Hot, Y_Hot, Data; | ||
| 224 | |||
| 225 | CHECK_GFX (Qnil); | ||
| 226 | /* | ||
| 227 | * If the icon is null, we just restore the DefaultCursor | ||
| 228 | */ | ||
| 229 | if (NILP(Icon)) | ||
| 230 | CurrentCursor = DefaultCursor; | ||
| 231 | else { | ||
| 232 | /* | ||
| 233 | * extract the data from the vector | ||
| 234 | */ | ||
| 235 | CHECK_VECTOR (Icon); | ||
| 236 | if (XVECTOR(Icon)->size < 3) return(Qnil); | ||
| 237 | X_Hot = XVECTOR(Icon)->contents[0]; | ||
| 238 | Y_Hot = XVECTOR(Icon)->contents[1]; | ||
| 239 | Data = XVECTOR(Icon)->contents[2]; | ||
| 240 | |||
| 241 | CHECK_NUMBER (X_Hot); | ||
| 242 | CHECK_NUMBER (Y_Hot); | ||
| 243 | CHECK_STRING (Data); | ||
| 244 | if (SCHARS (Data) != 32) return(Qnil); | ||
| 245 | /* | ||
| 246 | * Setup the new cursor | ||
| 247 | */ | ||
| 248 | NewCursor.cur_xhot = X_Hot; | ||
| 249 | NewCursor.cur_yhot = Y_Hot; | ||
| 250 | cp = SDATA (Data); | ||
| 251 | p = CursorData; | ||
| 252 | i = 16; | ||
| 253 | while(--i >= 0) | ||
| 254 | *p++ = (cp[0] << 8) | cp[1], cp += 2; | ||
| 255 | CurrentCursor = NewCursor; | ||
| 256 | } | ||
| 257 | win_setcursor(win_fd, &CurrentCursor); | ||
| 258 | return(Qt); | ||
| 259 | } | ||
| 260 | |||
| 261 | /* | ||
| 262 | * Interface for sunwindows selection | ||
| 263 | */ | ||
| 264 | static Lisp_Object Current_Selection; | ||
| 265 | |||
| 266 | static | ||
| 267 | sel_write (sel, file) | ||
| 268 | struct selection *sel; | ||
| 269 | FILE *file; | ||
| 270 | { | ||
| 271 | fwrite (SDATA (Current_Selection), sizeof (char), | ||
| 272 | sel->sel_items, file); | ||
| 273 | } | ||
| 274 | |||
| 275 | static | ||
| 276 | sel_clear (sel, windowfd) | ||
| 277 | struct selection *sel; | ||
| 278 | int windowfd; | ||
| 279 | { | ||
| 280 | } | ||
| 281 | |||
| 282 | static | ||
| 283 | sel_read (sel, file) | ||
| 284 | struct selection *sel; | ||
| 285 | FILE *file; | ||
| 286 | { | ||
| 287 | register int i, n; | ||
| 288 | register char *cp; | ||
| 289 | |||
| 290 | Current_Selection = empty_unibyte_string; | ||
| 291 | if (sel->sel_items <= 0) | ||
| 292 | return (0); | ||
| 293 | cp = (char *) malloc(sel->sel_items); | ||
| 294 | if (cp == (char *)0) { | ||
| 295 | error("malloc failed in sel_read"); | ||
| 296 | return(-1); | ||
| 297 | } | ||
| 298 | n = fread(cp, sizeof(char), sel->sel_items, file); | ||
| 299 | if (n > sel->sel_items) { | ||
| 300 | error("fread botch in sel_read"); | ||
| 301 | return(-1); | ||
| 302 | } else if (n < 0) { | ||
| 303 | error("Error reading selection"); | ||
| 304 | return(-1); | ||
| 305 | } | ||
| 306 | /* | ||
| 307 | * The shelltool select saves newlines as carriage returns, | ||
| 308 | * but emacs wants newlines. | ||
| 309 | */ | ||
| 310 | for (i = 0; i < n; i++) | ||
| 311 | if (cp[i] == '\r') cp[i] = '\n'; | ||
| 312 | |||
| 313 | Current_Selection = make_string (cp, n); | ||
| 314 | free (cp); | ||
| 315 | return (0); | ||
| 316 | } | ||
| 317 | |||
| 318 | /* | ||
| 319 | * Set the window system "selection" to be the arg STRING | ||
| 320 | */ | ||
| 321 | DEFUN ("sun-set-selection", Fsun_set_selection, Ssun_set_selection, 1, 1, | ||
| 322 | "sSet selection to: ", | ||
| 323 | doc: /* Set the current sunwindow selection to STRING. */) | ||
| 324 | (str) | ||
| 325 | Lisp_Object str; | ||
| 326 | { | ||
| 327 | struct selection selection; | ||
| 328 | |||
| 329 | CHECK_STRING (str); | ||
| 330 | Current_Selection = str; | ||
| 331 | |||
| 332 | CHECK_GFX (Qnil); | ||
| 333 | selection.sel_type = SELTYPE_CHAR; | ||
| 334 | selection.sel_items = SCHARS (str); | ||
| 335 | selection.sel_itembytes = 1; | ||
| 336 | selection.sel_pubflags = 1; | ||
| 337 | selection_set(&selection, sel_write, sel_clear, win_fd); | ||
| 338 | return (Qt); | ||
| 339 | } | ||
| 340 | /* | ||
| 341 | * Stuff the current window system selection into the current buffer | ||
| 342 | */ | ||
| 343 | DEFUN ("sun-get-selection", Fsun_get_selection, Ssun_get_selection, 0, 0, 0, | ||
| 344 | doc: /* Return the current sunwindows selection as a string. */) | ||
| 345 | () | ||
| 346 | { | ||
| 347 | CHECK_GFX (Current_Selection); | ||
| 348 | selection_get (sel_read, win_fd); | ||
| 349 | return (Current_Selection); | ||
| 350 | } | ||
| 351 | |||
| 352 | Menu sun_menu_create(); | ||
| 353 | |||
| 354 | Menu_item | ||
| 355 | sun_item_create (Pair) | ||
| 356 | Lisp_Object Pair; | ||
| 357 | { | ||
| 358 | /* In here, we depend on Lisp supplying zero terminated strings in the data*/ | ||
| 359 | /* so we can just pass the pointers, and not recopy anything */ | ||
| 360 | |||
| 361 | Menu_item menu_item; | ||
| 362 | Menu submenu; | ||
| 363 | Lisp_Object String; | ||
| 364 | Lisp_Object Value; | ||
| 365 | |||
| 366 | CHECK_LIST_CONS (Pair, Pair); | ||
| 367 | String = Fcar(Pair); | ||
| 368 | CHECK_STRING(String); | ||
| 369 | Value = Fcdr(Pair); | ||
| 370 | if (SYMBOLP (Value)) | ||
| 371 | Value = SYMBOL_VALUE (Value); | ||
| 372 | if (VECTORP (Value)) { | ||
| 373 | submenu = sun_menu_create (Value); | ||
| 374 | menu_item = menu_create_item | ||
| 375 | (MENU_RELEASE, MENU_PULLRIGHT_ITEM, SDATA (String), submenu, 0); | ||
| 376 | } else { | ||
| 377 | menu_item = menu_create_item | ||
| 378 | (MENU_RELEASE, MENU_STRING_ITEM, SDATA (String), Value, 0); | ||
| 379 | } | ||
| 380 | return menu_item; | ||
| 381 | } | ||
| 382 | |||
| 383 | Menu | ||
| 384 | sun_menu_create (Vector) | ||
| 385 | Lisp_Object Vector; | ||
| 386 | { | ||
| 387 | Menu menu; | ||
| 388 | int i; | ||
| 389 | CHECK_VECTOR(Vector); | ||
| 390 | menu=menu_create(0); | ||
| 391 | for(i = 0; i < XVECTOR(Vector)->size; i++) { | ||
| 392 | menu_set (menu, MENU_APPEND_ITEM, | ||
| 393 | sun_item_create(XVECTOR(Vector)->contents[i]), 0); | ||
| 394 | } | ||
| 395 | return menu; | ||
| 396 | } | ||
| 397 | |||
| 398 | /* | ||
| 399 | * If the first item of the menu has nil as its value, then make the | ||
| 400 | * item look like a label by inverting it and making it unselectable. | ||
| 401 | * Returns 1 if the label was made, 0 otherwise. | ||
| 402 | */ | ||
| 403 | int | ||
| 404 | make_menu_label (menu) | ||
| 405 | Menu menu; | ||
| 406 | { | ||
| 407 | int made_label_p = 0; | ||
| 408 | |||
| 409 | if (( menu_get(menu, MENU_NITEMS) > 0 ) && /* At least one item */ | ||
| 410 | ((Lisp_Object) menu_get(menu_get(menu, MENU_NTH_ITEM, 1), | ||
| 411 | MENU_VALUE) == Qnil )) { | ||
| 412 | menu_set(menu_get(menu, MENU_NTH_ITEM, 1), | ||
| 413 | MENU_INVERT, TRUE, | ||
| 414 | MENU_FEEDBACK, FALSE, | ||
| 415 | 0); | ||
| 416 | made_label_p = 1; | ||
| 417 | } | ||
| 418 | return made_label_p; | ||
| 419 | } | ||
| 420 | |||
| 421 | /* | ||
| 422 | * Do a pop-up menu and return the selected value | ||
| 423 | */ | ||
| 424 | DEFUN ("sun-menu-internal", | ||
| 425 | Fsun_menu_internal, | ||
| 426 | Ssun_menu_internal, 5, 5, 0, | ||
| 427 | doc: /* Set up a SunView pop-up menu and return the user's choice. | ||
| 428 | Arguments WINDOW, X, Y, BUTTON, and MENU. | ||
| 429 | *** User code should generally use sun-menu-evaluate *** | ||
| 430 | |||
| 431 | Arguments WINDOW, X, Y, BUTTON, and MENU. | ||
| 432 | Put MENU up in WINDOW at position X, Y. | ||
| 433 | The BUTTON argument specifies the button to be released that selects an item: | ||
| 434 | 1 = LEFT BUTTON | ||
| 435 | 2 = MIDDLE BUTTON | ||
| 436 | 4 = RIGHT BUTTON | ||
| 437 | The MENU argument is a vector containing (STRING . VALUE) pairs. | ||
| 438 | The VALUE of the selected item is returned. | ||
| 439 | If the VALUE of the first pair is nil, then the first STRING will be used | ||
| 440 | as a menu label. */) | ||
| 441 | (window, X_Position, Y_Position, Button, MEnu) | ||
| 442 | Lisp_Object window, X_Position, Y_Position, Button, MEnu; | ||
| 443 | { | ||
| 444 | Menu menu; | ||
| 445 | int button, xpos, ypos; | ||
| 446 | Event event0; | ||
| 447 | Event *event = &event0; | ||
| 448 | Lisp_Object Value, Pair; | ||
| 449 | |||
| 450 | CHECK_NUMBER(X_Position); | ||
| 451 | CHECK_NUMBER(Y_Position); | ||
| 452 | CHECK_LIVE_WINDOW(window); | ||
| 453 | CHECK_NUMBER(Button); | ||
| 454 | CHECK_VECTOR(MEnu); | ||
| 455 | |||
| 456 | CHECK_GFX (Qnil); | ||
| 457 | |||
| 458 | xpos = CtoSX (WINDOW_LEFT_EDGE_COL (XWINDOW (window)) | ||
| 459 | + WINDOW_LEFT_SCROLL_BAR_COLS (XWINDOW (window)) | ||
| 460 | + XINT(X_Position)); | ||
| 461 | ypos = CtoSY (WINDOW_TOP_EDGE_LINE (XWINDOW(window)) + XINT(Y_Position)); | ||
| 462 | #ifdef Menu_Base_Kludge | ||
| 463 | {static Lisp_Object symbol[2]; | ||
| 464 | symbol[0] = Fintern (sm_kludge_string, Qnil); | ||
| 465 | Pair = Ffuncall (1, symbol); | ||
| 466 | xpos += XINT (XCDR (Pair)); | ||
| 467 | ypos += XINT (XCAR (Pair)); | ||
| 468 | } | ||
| 469 | #endif | ||
| 470 | |||
| 471 | button = XINT(Button); | ||
| 472 | if(button == 4) button = 3; | ||
| 473 | event_set_id (event, BUT(button)); | ||
| 474 | event_set_down (event); | ||
| 475 | event_set_x (event, xpos); | ||
| 476 | event_set_y (event, ypos); | ||
| 477 | |||
| 478 | menu = sun_menu_create(MEnu); | ||
| 479 | make_menu_label(menu); | ||
| 480 | |||
| 481 | #ifdef Menu_Base_Kludge | ||
| 482 | Value = (Lisp_Object) menu_show(menu, Menu_Base_Frame, event, 0); | ||
| 483 | #else | ||
| 484 | /* This confuses the notifier or something: */ | ||
| 485 | Value = (Lisp_Object) menu_show_using_fd(menu, win_fd, event, 0); | ||
| 486 | /* | ||
| 487 | * Right button gets lost, and event sequencing or delivery gets mixed up | ||
| 488 | * So, until that gets fixed, we use this <Menu_Base_Frame> kludge: | ||
| 489 | */ | ||
| 490 | #endif | ||
| 491 | menu_destroy (menu); | ||
| 492 | |||
| 493 | return ((int)Value ? Value : Qnil); | ||
| 494 | } | ||
| 495 | |||
| 496 | |||
| 497 | /* | ||
| 498 | * Define everything | ||
| 499 | */ | ||
| 500 | syms_of_sunfns() | ||
| 501 | { | ||
| 502 | #ifdef Menu_Base_Kludge | ||
| 503 | /* i'm just too lazy to re-write this into C code */ | ||
| 504 | /* so we will call this elisp function from C */ | ||
| 505 | sm_kludge_string = make_pure_string ("sm::menu-kludge", 15, 15, 0); | ||
| 506 | #endif /* Menu_Base_Kludge */ | ||
| 507 | |||
| 508 | defsubr(&Ssun_window_init); | ||
| 509 | defsubr(&Ssit_for_millisecs); | ||
| 510 | defsubr(&Ssleep_for_millisecs); | ||
| 511 | defsubr(&Supdate_display); | ||
| 512 | defsubr(&Ssun_change_cursor_icon); | ||
| 513 | defsubr(&Ssun_set_selection); | ||
| 514 | defsubr(&Ssun_get_selection); | ||
| 515 | defsubr(&Ssun_menu_internal); | ||
| 516 | } | ||
| 517 | |||
| 518 | /* arch-tag: 2d7decb7-58f6-41aa-b45b-077ccfab7158 | ||
| 519 | (do not change this comment) */ | ||