diff options
| -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 37ee660577..0f36d30798 100644 --- a/doc/emacs/ChangeLog +++ b/doc/emacs/ChangeLog @@ -1,3 +1,7 @@ +2007-11-01 Dan Nicolaescu <dann@ics.uci.edu> + + * cmdargs.texi (Misc Variables): Remove Sun windows info. + 2007-10-27 Emanuele Giaquinta <e.giaquinta@glauco.it> (tiny change) * gnus-faq.texi ([5.12]): Remove reference to discontinued service. diff --git a/doc/emacs/cmdargs.texi b/doc/emacs/cmdargs.texi index 28bad72f0b..f2f3a85af7 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 for the background, so all four bits of the background color are actually used. -@item WINDOW_GFX -Used when initializing the Sun windows system. - @item PRELOAD_WINSOCK On MS-Windows, if you set this variable, Emacs will load and initialize the network library at startup, instead of waiting until the first diff --git a/etc/ChangeLog b/etc/ChangeLog index 017db136df..589e536547 100644 --- a/etc/ChangeLog +++ b/etc/ChangeLog @@ -1,3 +1,7 @@ +2007-11-01 Dan Nicolaescu <dann@ics.uci.edu> + + * MACHINES: Remove Sun windows info. + 2007-10-30 Michael Olson <mwolson@gnu.org> * NEWS: Add entry for Remember Mode. diff --git a/etc/MACHINES b/etc/MACHINES index a4db1df76c..9f84d8ac18 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, src/s/sunos4-1.h to src/config.h. This problem is due to obsolete software in the nonshared standard library. - If you want to use SunWindows, define HAVE_SUN_WINDOWS - in config.h to enable a special interface called `emacstool'. - The definition must *precede* the #include "machine.h". - System version 3.2 is required for this facility to work. - - We recommend that you instead use the X window system, which - has technical advantages, is an industry standard, and is also - free software. The FSF does not support the SunWindows code; - we installed it only on the understanding we would not let it - divert our efforts from what we think is important. - If you are compiling for X windows, and the X window library was compiled to use the 68881, then you must edit config.h according the comments at the end of `src/m/sun3.h'. @@ -33,6 +33,8 @@ a GIF library. ** Support for systems without alloca has been removed. +** Support for Sun windows has been removed. + ** The `emacstool' utility has been removed. diff --git a/lisp/obsolete/sun-curs.el b/lisp/obsolete/sun-curs.el deleted file mode 100644 index 612102159d..0000000000 --- a/lisp/obsolete/sun-curs.el +++ /dev/null @@ -1,234 +0,0 @@ -;;; sun-curs.el --- cursor definitions for Sun windows - -;; Copyright (C) 1987, 2001, 2002, 2003, 2004, 2005, -;; 2006, 2007 Free Software Foundation, Inc. - -;; Author: Jeff Peck <peck@sun.com> -;; Keywords: hardware - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;;; Code: - -;;; -;;; Added some more cursors and moved the hot spots -;;; Cursor defined by 16 pairs of 16-bit numbers -;;; -;;; 9-dec-86 Jeff Peck, Sun Microsystems Inc. <peck@sun.com> - -(eval-when-compile (require 'cl)) - -(defvar *edit-icon*) -(defvar char) -;; These are from term/sun-mouse.el -(defvar *mouse-window*) -(defvar *mouse-x*) -(defvar *mouse-y*) -(defvar menu) - -(require 'sun-fns) - -(eval-and-compile - (defvar sc::cursors nil "List of known cursors")) - -(defmacro defcursor (name x y string) - (if (not (memq name sc::cursors)) - (setq sc::cursors (cons name sc::cursors))) - (list 'defconst name (list 'vector x y string))) - -;;; push should be defined in common lisp, but if not use this: -;(defmacro push (v l) -; "The ITEM is evaluated and consed onto LIST, a list-valued atom" -; (list 'setq l (list 'cons v l))) - -;;; -;;; The standard default cursor -;;; -(defcursor sc:right-arrow 15 0 - (concat '(0 1 0 3 0 7 0 15 0 31 0 63 0 127 0 15 - 0 27 0 25 0 48 0 48 0 96 0 96 0 192 0 192))) - -;;(sc:set-cursor sc:right-arrow) - -(defcursor sc:fat-left-arrow 0 8 - (concat '(1 0 3 0 7 0 15 0 31 0 63 255 127 255 255 255 - 255 255 127 255 63 255 31 0 15 0 7 0 3 0 1 0))) - -(defcursor sc:box 8 8 - (concat '(15 252 8 4 8 4 8 4 8 4 8 4 8 4 8 4 - 8 132 8 4 8 4 8 4 8 4 8 4 8 4 15 252))) - -(defcursor sc:hourglass 8 8 - (concat "\177\376\100\002\040\014\032\070" - "\017\360\007\340\003\300\001\200" - "\001\200\002\100\005\040\010\020" - "\021\210\043\304\107\342\177\376")) - -(defun sc:set-cursor (icon) - "Change the Sun mouse cursor to ICON. -If ICON is nil, switch to the system default cursor, -Otherwise, ICON should be a vector or the name of a vector of [x y 32-chars]" - (interactive "XIcon Name: ") - (if (symbolp icon) (setq icon (symbol-value icon))) - (sun-change-cursor-icon icon)) - -;; This does not make much sense... -(make-local-variable '*edit-icon*) - -(defvar icon-edit nil) -(make-variable-buffer-local 'icon-edit) -(or (assq 'icon-edit minor-mode-alist) - (push '(icon-edit " IconEdit") minor-mode-alist)) - -(defun sc:edit-cursor (icon) - "convert icon to rectangle, edit, and repack" - (interactive "XIcon Name: ") - (if (not icon) (setq icon (sc::menu-choose-cursor (selected-window) 1 1))) - (if (symbolp icon) (setq icon (symbol-value icon))) - (if (get-buffer "icon-edit") (kill-buffer "icon-edit")) - (switch-to-buffer "icon-edit") - (local-set-mouse '(text right) 'sc::menu-function) - (local-set-mouse '(text left) '(sc::pic-ins-at-mouse 32)) - (local-set-mouse '(text middle) '(sc::pic-ins-at-mouse 64)) - (local-set-mouse '(text left middle) 'sc::hotspot) - (sc::display-icon icon) - (picture-mode) - (setq icon-edit t) ; for mode line display -) - -(defun sc::pic-ins-at-mouse (char) - "Picture insert char at mouse location" - (mouse-move-point *mouse-window* (min 15 *mouse-x*) (min 15 *mouse-y*)) - (move-to-column (1+ (min 15 (current-column))) t) - (delete-char -1) - (insert char) - (sc::goto-hotspot)) - -(defmenu sc::menu - ("Cursor Menu") - ("Pack & Use" sc::pack-buffer-to-cursor) - ("Pack to Icon" sc::pack-buffer-to-icon - (sc::menu-choose-cursor *menu-window* *menu-x* *menu-y*)) - ("New Icon" call-interactively 'sc::make-cursor) - ("Edit Icon" sc:edit-cursor - (sc::menu-choose-cursor *menu-window* *menu-x* *menu-y*)) - ("Set Cursor" sc:set-cursor - (sc::menu-choose-cursor *menu-window* *menu-x* *menu-y*)) - ("Reset Cursor" sc:set-cursor nil) - ("Help" sc::edit-icon-help-menu) - ("Quit" sc::quit-edit) - ) - -(defun sc::menu-function (window x y) - (sun-menu-evaluate window (1+ x) y sc::menu)) - -(defun sc::quit-edit () - (interactive) - (bury-buffer (current-buffer)) - (switch-to-buffer (other-buffer) 'no-record)) - -(defun sc::make-cursor (symbol) - (interactive "SIcon Name: ") - (eval (list 'defcursor symbol 0 0 "")) - (sc::pack-buffer-to-icon (symbol-value symbol))) - -(defmenu sc::edit-icon-help-menu - ("Simple Icon Editor") - ("Left => CLEAR") - ("Middle => SET") - ("L & M => HOTSPOT") - ("Right => MENU")) - -(defun sc::edit-icon-help () - (message "Left=> CLEAR Middle=> SET Left+Middle=> HOTSPOT Right=> MENU")) - -(defun sc::pack-buffer-to-cursor () - (sc::pack-buffer-to-icon *edit-icon*) - (sc:set-cursor *edit-icon*)) - -(defun sc::menu-choose-cursor (window x y) - "Presents a menu of cursor names, and returns one or nil" - (let ((curs sc::cursors) - (items)) - (while curs - (push (sc::menu-item-for-cursor (car curs)) items) - (setq curs (cdr curs))) - (push (list "Choose Cursor") items) - (setq menu (menu-create items)) - (sun-menu-evaluate window x y menu))) - -(defun sc::menu-item-for-cursor (cursor) - "apply function to selected cursor" - (list (symbol-name cursor) 'quote cursor)) - -(defun sc::hotspot (window x y) - (aset *edit-icon* 0 x) - (aset *edit-icon* 1 y) - (sc::goto-hotspot)) - -(defun sc::goto-hotspot () - (goto-line (1+ (aref *edit-icon* 1))) - (move-to-column (aref *edit-icon* 0))) - -(defun sc::display-icon (icon) - (setq *edit-icon* (copy-sequence icon)) - (let ((string (aref *edit-icon* 2)) - (index 0)) - (while (< index 32) - (let ((char (aref string index)) - (bit 128)) - (while (> bit 0) - (insert (sc::char-at-bit char bit)) - (setq bit (lsh bit -1)))) - (if (eq 1 (% index 2)) (newline)) - (setq index (1+ index)))) - (sc::goto-hotspot)) - -(defun sc::char-at-bit (char bit) - (if (> (logand char bit) 0) "@" " ")) - -(defun sc::pack-buffer-to-icon (icon) - "Pack 16 x 16 field into icon string" - (goto-char (point-min)) - (aset icon 0 (aref *edit-icon* 0)) - (aset icon 1 (aref *edit-icon* 1)) - (aset icon 2 (mapconcat 'sc::pack-one-line "1234567890123456" "")) - (sc::goto-hotspot) - ) - -(defun sc::pack-one-line (dummy) - (let (char chr1 chr2) - (setq char 0 chr1 (mapconcat 'sc::pack-one-char "12345678" "") chr1 char) - (setq char 0 chr2 (mapconcat 'sc::pack-one-char "12345678" "") chr2 char) - (forward-line 1) - (concat (char-to-string chr1) (char-to-string chr2)) - )) - -(defun sc::pack-one-char (dummy) - "pack following char into char, unless eolp" - (if (or (eolp) (char-equal (following-char) 32)) - (setq char (lsh char 1)) - (setq char (1+ (lsh char 1)))) - (if (not (eolp))(forward-char))) - -(provide 'sun-curs) - -;;; arch-tag: 7cc861e5-e2d9-4191-b211-2baaaab54e78 -;;; sun-curs.el ends here diff --git a/lisp/obsolete/sun-fns.el b/lisp/obsolete/sun-fns.el deleted file mode 100644 index 1b6a5d239b..0000000000 --- a/lisp/obsolete/sun-fns.el +++ /dev/null @@ -1,644 +0,0 @@ -;;; sun-fns.el --- subroutines of Mouse handling for Sun windows - -;; Copyright (C) 1987, 2001, 2002, 2003, 2004, 2005, -;; 2006, 2007 Free Software Foundation, Inc. - -;; Author: Jeff Peck <peck@sun.com> -;; Maintainer: none -;; Keywords: hardware - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;; Submitted Mar. 1987, Jeff Peck -;; Sun Microsystems Inc. <peck@sun.com> -;; Conceived Nov. 1986, Stan Jefferson, -;; Computer Science Lab, SRI International. -;; GoodIdeas Feb. 1987, Steve Greenbaum -;; & UpClicks Reasoning Systems, Inc. -;; -;; -;; Functions for manipulating via the mouse and mouse-map definitions -;; for accessing them. Also definitions of mouse menus. -;; This file you should freely modify to reflect you personal tastes. -;; -;; First half of file defines functions to implement mouse commands, -;; Don't delete any of those, just add what ever else you need. -;; Second half of file defines mouse bindings, do whatever you want there. - -;; -;; Mouse Functions. -;; -;; These functions follow the sun-mouse-handler convention of being called -;; with three arguments: (window x-pos y-pos) -;; This makes it easy for a mouse executed command to know where the mouse is. -;; Use the macro "eval-in-window" to execute a function -;; in a temporarily selected window. -;; -;; If you have a function that must be called with other arguments -;; bind the mouse button to an s-exp that contains the necessary parameters. -;; See "minibuffer" bindings for examples. -;; - -;;; Code: - -(require 'term/sun-mouse) - -(defconst cursor-pause-milliseconds 300 - "*Number of milliseconds to display alternate cursor (usually the mark)") - -(defun indicate-region (&optional pause) - "Bounce cursor to mark for cursor-pause-milliseconds and back again" - (or pause (setq pause cursor-pause-milliseconds)) - (let ((point (point))) - (goto-char (mark)) - (sit-for-millisecs pause) - ;(update-display) - ;(sleep-for-millisecs pause) - (goto-char point))) - - -;;; -;;; Text buffer operations -;;; -(defun mouse-move-point (window x y) - "Move point to mouse cursor." - (select-window window) - (move-to-loc x y) - (if (memq last-command ; support the mouse-copy/delete/yank - '(mouse-copy mouse-delete mouse-yank-move)) - (setq this-command 'mouse-yank-move)) - ) - -(defun mouse-set-mark (&optional window x y) - "Set mark at mouse cursor." - (eval-in-window window ;; use this to get the unwind protect - (let ((point (point))) - (move-to-loc x y) - (set-mark (point)) - (goto-char point) - (indicate-region))) - ) - -(defun mouse-set-mark-and-select (window x y) - "Set mark at mouse cursor, and select that window." - (select-window window) - (mouse-set-mark window x y) - ) - -(defun mouse-set-mark-and-stuff (w x y) - "Set mark at mouse cursor, and put region in stuff buffer." - (mouse-set-mark-and-select w x y) - (sun-select-region (region-beginning) (region-end))) - -;;; -;;; Simple mouse dragging stuff: marking with button up -;;; - -(defvar *mouse-drag-window* nil) -(defvar *mouse-drag-x* -1) -(defvar *mouse-drag-y* -1) - -(defun mouse-drag-move-point (window x y) - "Move point to mouse cursor, and allow dragging." - (mouse-move-point window x y) - (setq *mouse-drag-window* window - *mouse-drag-x* x - *mouse-drag-y* y)) - -(defun mouse-drag-set-mark-stuff (window x y) - "The up click handler that goes with mouse-drag-move-point. -If mouse is in same WINDOW but at different X or Y than when -mouse-drag-move-point was last executed, set the mark at mouse -and put the region in the stuff buffer." - (if (and (eq *mouse-drag-window* window) - (not (and (equal *mouse-drag-x* x) - (equal *mouse-drag-y* y)))) - (mouse-set-mark-and-stuff window x y) - (setq this-command last-command)) ; this was just an upclick no-op. - ) - -(defun mouse-select-or-drag-move-point (window x y) - "Select window if not selected, otherwise do mouse-drag-move-point." - (if (eq (selected-window) window) - (mouse-drag-move-point window x y) - (mouse-select-window window))) - -;;; -;;; esoterica: -;;; -(defun mouse-exch-pt-and-mark (window x y) - "Exchange point and mark." - (select-window window) - (exchange-point-and-mark) - ) - -(defun mouse-call-kbd-macro (window x y) - "Invokes last keyboard macro at mouse cursor." - (mouse-move-point window x y) - (call-last-kbd-macro) - ) - -(defun mouse-mark-thing (window x y) - "Set point and mark to text object using syntax table. -The resulting region is put in the sun-window stuff buffer. -Left or right Paren syntax marks an s-expression. -Clicking at the end of a line marks the line including a trailing newline. -If it doesn't recognize one of these it marks the character at point." - (mouse-move-point window x y) - (if (eobp) (open-line 1)) - (let* ((char (char-after (point))) - (syntax (char-syntax char))) - (cond - ((eq syntax ?w) ; word. - (forward-word 1) - (set-mark (point)) - (forward-word -1)) - ;; try to include a single following whitespace (is this a good idea?) - ;; No, not a good idea since inconsistent. - ;;(if (eq (char-syntax (char-after (mark))) ?\ ) - ;; (set-mark (1+ (mark)))) - ((eq syntax ?\( ) ; open paren. - (mark-sexp 1)) - ((eq syntax ?\) ) ; close paren. - (forward-char 1) - (mark-sexp -1) - (exchange-point-and-mark)) - ((eolp) ; mark line if at end. - (set-mark (1+ (point))) - (beginning-of-line 1)) - (t ; mark character - (set-mark (1+ (point))))) - (indicate-region)) ; display region boundary. - (sun-select-region (region-beginning) (region-end)) - ) - -(defun mouse-kill-thing (window x y) - "Kill thing at mouse, and put point there." - (mouse-mark-thing window x y) - (kill-region-and-unmark (region-beginning) (region-end)) - ) - -(defun mouse-kill-thing-there (window x y) - "Kill thing at mouse, leave point where it was. -See mouse-mark-thing for a description of the objects recognized." - (eval-in-window window - (save-excursion - (mouse-mark-thing window x y) - (kill-region (region-beginning) (region-end)))) - ) - -(defun mouse-save-thing (window x y &optional quiet) - "Put thing at mouse in kill ring. -See mouse-mark-thing for a description of the objects recognized." - (mouse-mark-thing window x y) - (copy-region-as-kill (region-beginning) (region-end)) - (if (not quiet) (message "Thing saved")) - ) - -(defun mouse-save-thing-there (window x y &optional quiet) - "Put thing at mouse in kill ring, leave point as is. -See mouse-mark-thing for a description of the objects recognized." - (eval-in-window window - (save-excursion - (mouse-save-thing window x y quiet)))) - -;;; -;;; Mouse yanking... -;;; -(defun mouse-copy-thing (window x y) - "Put thing at mouse in kill ring, yank to point. -See mouse-mark-thing for a description of the objects recognized." - (setq last-command 'not-kill) ;Avoids appending to previous kills. - (mouse-save-thing-there window x y t) - (yank) - (setq this-command 'yank)) - -(defun mouse-move-thing (window x y) - "Kill thing at mouse, yank it to point. -See mouse-mark-thing for a description of the objects recognized." - (setq last-command 'not-kill) ;Avoids appending to previous kills. - (mouse-kill-thing-there window x y) - (yank) - (setq this-command 'yank)) - -(defun mouse-yank-at-point (&optional window x y) - "Yank from kill-ring at point; then cycle thru kill ring." - (if (eq last-command 'yank) - (let ((before (< (point) (mark)))) - (delete-region (point) (mark)) - (insert (current-kill 1)) - (if before (exchange-point-and-mark))) - (yank)) - (setq this-command 'yank)) - -(defun mouse-yank-at-mouse (window x y) - "Yank from kill-ring at mouse; then cycle thru kill ring." - (mouse-move-point window x y) - (mouse-yank-at-point window x y)) - -(defun mouse-save/delete/yank (&optional window x y) - "Context sensitive save/delete/yank. -Consecutive clicks perform as follows: - * first click saves region to kill ring, - * second click kills region, - * third click yanks from kill ring, - * subsequent clicks cycle thru kill ring. -If mouse-move-point is performed after the first or second click, -the next click will do a yank, etc. Except for a possible mouse-move-point, -this command is insensitive to mouse location." - (cond - ((memq last-command '(mouse-delete yank mouse-yank-move)) ; third+ click - (mouse-yank-at-point)) - ((eq last-command 'mouse-copy) ; second click - (kill-region (region-beginning) (region-end)) - (setq this-command 'mouse-delete)) - (t ; first click - (copy-region-as-kill (region-beginning) (region-end)) - (message "Region saved") - (setq this-command 'mouse-copy)) - )) - - -(defun mouse-split-horizontally (window x y) - "Splits the window horizontally at mouse cursor." - (eval-in-window window (split-window-horizontally (1+ x)))) - -(defun mouse-split-vertically (window x y) - "Split the window vertically at the mouse cursor." - (eval-in-window window (split-window-vertically (1+ y)))) - -(defun mouse-select-window (&optional window x y) - "Selects the window, restoring point." - (select-window window)) - -(defun mouse-delete-other-windows (&optional window x y) - "Deletes all windows except the one mouse is in." - (delete-other-windows window)) - -(defun mouse-delete-window (window &optional x y) - "Deletes the window mouse is in." - (delete-window window)) - -(defun mouse-undo (window x y) - "Invokes undo in the window mouse is in." - (eval-in-window window (undo))) - -;;; -;;; Scroll operations -;;; - -;;; The move-to-window-line is used below because otherwise -;;; scrolling a non-selected process window with the mouse, after -;;; the process has written text past the bottom of the window, -;;; gives an "End of buffer" error, and then scrolls. The -;;; move-to-window-line seems to force recomputing where things are. -(defun mouse-scroll-up (window x y) - "Scrolls the window upward." - (eval-in-window window (move-to-window-line 1) (scroll-up nil))) - -(defun mouse-scroll-down (window x y) - "Scrolls the window downward." - (eval-in-window window (scroll-down nil))) - -(defun mouse-scroll-proportional (window x y) - "Scrolls the window proportionally corresponding to window -relative X divided by window width." - (eval-in-window window - (if (>= x (1- (window-width))) - ;; When x is maximum (equal to or 1 less than window width), - ;; goto end of buffer. We check for this special case - ;; because the calculated goto-char often goes short of the - ;; end due to roundoff error, and we often really want to go - ;; to the end. - (goto-char (point-max)) - (progn - (goto-char (+ (point-min) ; For narrowed regions. - (* x (/ (- (point-max) (point-min)) - (1- (window-width)))))) - (beginning-of-line)) - ) - (what-cursor-position) ; Report position. - )) - -(defun mouse-line-to-top (window x y) - "Scrolls the line at the mouse cursor up to the top." - (eval-in-window window (scroll-up y))) - -(defun mouse-top-to-line (window x y) - "Scrolls the top line down to the mouse cursor." - (eval-in-window window (scroll-down y))) - -(defun mouse-line-to-bottom (window x y) - "Scrolls the line at the mouse cursor to the bottom." - (eval-in-window window (scroll-up (+ y (- 2 (window-height)))))) - -(defun mouse-bottom-to-line (window x y) - "Scrolls the bottom line up to the mouse cursor." - (eval-in-window window (scroll-down (+ y (- 2 (window-height)))))) - -(defun mouse-line-to-middle (window x y) - "Scrolls the line at the mouse cursor to the middle." - (eval-in-window window (scroll-up (- y -1 (/ (window-height) 2))))) - -(defun mouse-middle-to-line (window x y) - "Scrolls the line at the middle to the mouse cursor." - (eval-in-window window (scroll-up (- (/ (window-height) 2) y 1)))) - - -;;; -;;; main emacs menu. -;;; -(defmenu expand-menu - ("Vertically" mouse-expand-vertically *menu-window*) - ("Horizontally" mouse-expand-horizontally *menu-window*)) - -(defmenu delete-window-menu - ("This One" delete-window *menu-window*) - ("All Others" delete-other-windows *menu-window*)) - -(defmenu mouse-help-menu - ("Text Region" - mouse-help-region *menu-window* *menu-x* *menu-y* 'text) - ("Scrollbar" - mouse-help-region *menu-window* *menu-x* *menu-y* 'scrollbar) - ("Modeline" - mouse-help-region *menu-window* *menu-x* *menu-y* 'modeline) - ("Minibuffer" - mouse-help-region *menu-window* *menu-x* *menu-y* 'minibuffer) - ) - -(defmenu emacs-quit-menu - ("Quit" save-buffers-kill-emacs)) - -(defmenu emacs-menu - ("Emacs Menu") - ("Stuff Selection" sun-yank-selection) - ("Expand" . expand-menu) - ("Delete Window" . delete-window-menu) - ("Previous Buffer" mouse-select-previous-buffer *menu-window*) - ("Save Buffers" save-some-buffers) - ("List Directory" list-directory nil) - ("Dired" dired nil) - ("Mouse Help" . mouse-help-menu) - ("Quit" . emacs-quit-menu)) - -(defun emacs-menu-eval (window x y) - "Pop-up menu of editor commands." - (sun-menu-evaluate window (1+ x) (1- y) 'emacs-menu)) - -(defun mouse-expand-horizontally (window) - (eval-in-window window - (enlarge-window 4 t) - (update-display) ; Try to redisplay, since can get confused. - )) - -(defun mouse-expand-vertically (window) - (eval-in-window window (enlarge-window 4))) - -(defun mouse-select-previous-buffer (window) - "Switch buffer in mouse window to most recently selected buffer." - (eval-in-window window (switch-to-buffer (other-buffer)))) - -;;; -;;; minibuffer menu -;;; -(defmenu minibuffer-menu - ("Minibuffer" message "Just some miscellaneous minibuffer commands") - ("Stuff" sun-yank-selection) - ("Do-It" exit-minibuffer) - ("Abort" abort-recursive-edit) - ("Suspend" suspend-emacs)) - -(defun minibuffer-menu-eval (window x y) - "Pop-up menu of commands." - (sun-menu-evaluate window x (1- y) 'minibuffer-menu)) - -(defun mini-move-point (window x y) - ;; -6 is good for most common cases - (mouse-move-point window (- x 6) 0)) - -(defun mini-set-mark-and-stuff (window x y) - ;; -6 is good for most common cases - (mouse-set-mark-and-stuff window (- x 6) 0)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Buffer-mode Mouse commands -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun Buffer-at-mouse (w x y) - "Calls Buffer-menu-buffer from mouse click." - (save-window-excursion - (mouse-move-point w x y) - (beginning-of-line) - (Buffer-menu-buffer t))) - -(defun mouse-buffer-bury (w x y) - "Bury the indicated buffer." - (bury-buffer (Buffer-at-mouse w x y)) - ) - -(defun mouse-buffer-select (w x y) - "Put the indicated buffer in selected window." - (switch-to-buffer (Buffer-at-mouse w x y)) - (list-buffers) - ) - -(defun mouse-buffer-delete (w x y) - "mark indicated buffer for delete" - (save-window-excursion - (mouse-move-point w x y) - (Buffer-menu-delete) - )) - -(defun mouse-buffer-execute (w x y) - "execute buffer-menu selections" - (save-window-excursion - (mouse-move-point w x y) - (Buffer-menu-execute) - )) - -(defun enable-mouse-in-buffer-list () - "Call this to enable mouse selections in *Buffer List* - LEFT puts the indicated buffer in the selected window. - MIDDLE buries the indicated buffer. - RIGHT marks the indicated buffer for deletion. - MIDDLE-RIGHT deletes the marked buffers. -To unmark a buffer marked for deletion, select it with LEFT." - (save-window-excursion - (list-buffers) ; Initialize *Buffer List* - (set-buffer "*Buffer List*") - (local-set-mouse '(text middle) 'mouse-buffer-bury) - (local-set-mouse '(text left) 'mouse-buffer-select) - (local-set-mouse '(text right) 'mouse-buffer-delete) - (local-set-mouse '(text middle right) 'mouse-buffer-execute) - ) - ) - - -;;;******************************************************************* -;;; -;;; Global Mouse Bindings. -;;; -;;; There is some sense to this mouse binding madness: -;;; LEFT and RIGHT scrolls are inverses. -;;; SHIFT makes an opposite meaning in the scroll bar. -;;; SHIFT is an alternative to DOUBLE (but double chords do not exist). -;;; META makes the scrollbar functions work in the text region. -;;; MIDDLE operates the mark -;;; LEFT operates at point - -;;; META commands are generally non-destructive, -;;; SHIFT is a little more dangerous. -;;; CONTROL is for the really complicated ones. - -;;; CONTROL-META-SHIFT-RIGHT gives help on that region. - -;;; -;;; Text Region mousemap -;;; -;; The basics: Point, Mark, Menu, Sun-Select: -(global-set-mouse '(text left) 'mouse-drag-move-point) -(global-set-mouse '(text up left) 'mouse-drag-set-mark-stuff) -(global-set-mouse '(text shift left) 'mouse-exch-pt-and-mark) -(global-set-mouse '(text double left) 'mouse-exch-pt-and-mark) - -(global-set-mouse '(text middle) 'mouse-set-mark-and-stuff) - -(global-set-mouse '(text right) 'emacs-menu-eval) -(global-set-mouse '(text shift right) '(sun-yank-selection)) -(global-set-mouse '(text double right) '(sun-yank-selection)) - -;; The Slymoblics multi-command for Save, Kill, Copy, Move: -(global-set-mouse '(text shift middle) 'mouse-save/delete/yank) -(global-set-mouse '(text double middle) 'mouse-save/delete/yank) - -;; Save, Kill, Copy, Move Things: -;; control-left composes with control middle/right to produce copy/move -(global-set-mouse '(text control middle ) 'mouse-save-thing-there) -(global-set-mouse '(text control right ) 'mouse-kill-thing-there) -(global-set-mouse '(text control left) 'mouse-yank-at-point) -(global-set-mouse '(text control middle left) 'mouse-copy-thing) -(global-set-mouse '(text control right left) 'mouse-move-thing) -(global-set-mouse '(text control right middle) 'mouse-mark-thing) - -;; The Universal mouse help command (press all buttons): -(global-set-mouse '(text shift control meta right) 'mouse-help-region) -(global-set-mouse '(text double control meta right) 'mouse-help-region) - -;;; Meta in Text Region is like meta version in scrollbar: -(global-set-mouse '(text meta left) 'mouse-line-to-top) -(global-set-mouse '(text meta shift left) 'mouse-line-to-bottom) -(global-set-mouse '(text meta double left) 'mouse-line-to-bottom) -(global-set-mouse '(text meta middle) 'mouse-line-to-middle) -(global-set-mouse '(text meta shift middle) 'mouse-middle-to-line) -(global-set-mouse '(text meta double middle) 'mouse-middle-to-line) -(global-set-mouse '(text meta control middle) 'mouse-split-vertically) -(global-set-mouse '(text meta right) 'mouse-top-to-line) -(global-set-mouse '(text meta shift right) 'mouse-bottom-to-line) -(global-set-mouse '(text meta double right) 'mouse-bottom-to-line) - -;; Miscellaneous: -(global-set-mouse '(text meta control left) 'mouse-call-kbd-macro) -(global-set-mouse '(text meta control right) 'mouse-undo) - -;;; -;;; Scrollbar mousemap. -;;; Are available in the Scrollbar Region, or with Meta Text (or Meta Scrollbar) -;;; -(global-set-mouse '(scrollbar left) 'mouse-line-to-top) -(global-set-mouse '(scrollbar shift left) 'mouse-line-to-bottom) -(global-set-mouse '(scrollbar double left) 'mouse-line-to-bottom) - -(global-set-mouse '(scrollbar middle) 'mouse-line-to-middle) -(global-set-mouse '(scrollbar shift middle) 'mouse-middle-to-line) -(global-set-mouse '(scrollbar double middle) 'mouse-middle-to-line) -(global-set-mouse '(scrollbar control middle) 'mouse-split-vertically) - -(global-set-mouse '(scrollbar right) 'mouse-top-to-line) -(global-set-mouse '(scrollbar shift right) 'mouse-bottom-to-line) -(global-set-mouse '(scrollbar double right) 'mouse-bottom-to-line) - -(global-set-mouse '(scrollbar meta left) 'mouse-line-to-top) -(global-set-mouse '(scrollbar meta shift left) 'mouse-line-to-bottom) -(global-set-mouse '(scrollbar meta double left) 'mouse-line-to-bottom) -(global-set-mouse '(scrollbar meta middle) 'mouse-line-to-middle) -(global-set-mouse '(scrollbar meta shift middle) 'mouse-middle-to-line) -(global-set-mouse '(scrollbar meta double middle) 'mouse-middle-to-line) -(global-set-mouse '(scrollbar meta control middle) 'mouse-split-vertically) -(global-set-mouse '(scrollbar meta right) 'mouse-top-to-line) -(global-set-mouse '(scrollbar meta shift right) 'mouse-bottom-to-line) -(global-set-mouse '(scrollbar meta double right) 'mouse-bottom-to-line) - -;; And the help menu: -(global-set-mouse '(scrollbar shift control meta right) 'mouse-help-region) -(global-set-mouse '(scrollbar double control meta right) 'mouse-help-region) - -;;; -;;; Modeline mousemap. -;;; -;;; Note: meta of any single button selects window. - -(global-set-mouse '(modeline left) 'mouse-scroll-up) -(global-set-mouse '(modeline meta left) 'mouse-select-window) - -(global-set-mouse '(modeline middle) 'mouse-scroll-proportional) -(global-set-mouse '(modeline meta middle) 'mouse-select-window) -(global-set-mouse '(modeline control middle) 'mouse-split-horizontally) - -(global-set-mouse '(modeline right) 'mouse-scroll-down) -(global-set-mouse '(modeline meta right) 'mouse-select-window) - -;;; control-left selects this window, control-right deletes it. -(global-set-mouse '(modeline control left) 'mouse-delete-other-windows) -(global-set-mouse '(modeline control right) 'mouse-delete-window) - -;; in case of confusion, just select it: -(global-set-mouse '(modeline control left right)'mouse-select-window) - -;; even without confusion (and without the keyboard) select it: -(global-set-mouse '(modeline left right) 'mouse-select-window) - -;; And the help menu: -(global-set-mouse '(modeline shift control meta right) 'mouse-help-region) -(global-set-mouse '(modeline double control meta right) 'mouse-help-region) - -;;; -;;; Minibuffer Mousemap -;;; Demonstrating some variety: -;;; -(global-set-mouse '(minibuffer left) 'mini-move-point) - -(global-set-mouse '(minibuffer middle) 'mini-set-mark-and-stuff) - -(global-set-mouse '(minibuffer shift middle) '(select-previous-complex-command)) -(global-set-mouse '(minibuffer double middle) '(select-previous-complex-command)) -(global-set-mouse '(minibuffer control middle) '(next-complex-command 1)) -(global-set-mouse '(minibuffer meta middle) '(previous-complex-command 1)) - -(global-set-mouse '(minibuffer right) 'minibuffer-menu-eval) - -(global-set-mouse '(minibuffer shift control meta right) 'mouse-help-region) -(global-set-mouse '(minibuffer double control meta right) 'mouse-help-region) - -(provide 'sun-fns) - -;;; arch-tag: 1c4c1192-f71d-4d5f-b883-ae659c28e132 -;;; sun-fns.el ends here diff --git a/lisp/term/sun-mouse.el b/lisp/term/sun-mouse.el deleted file mode 100644 index d3e85508b0..0000000000 --- a/lisp/term/sun-mouse.el +++ /dev/null @@ -1,667 +0,0 @@ -;;; sun-mouse.el --- mouse handling for Sun windows - -;; Copyright (C) 1987, 2001, 2002, 2003, 2004, 2005, -;; 2006, 2007 Free Software Foundation, Inc. - -;; Author: Jeff Peck -;; Maintainer: FSF -;; Keywords: hardware - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;; Jeff Peck, Sun Microsystems, Jan 1987. -;; Original idea by Stan Jefferson - -;; Modeled after the GNUEMACS keymap interface. -;; -;; User Functions: -;; make-mousemap, copy-mousemap, -;; define-mouse, global-set-mouse, local-set-mouse, -;; use-global-mousemap, use-local-mousemap, -;; mouse-lookup, describe-mouse-bindings -;; -;; Options: -;; extra-click-wait, scrollbar-width - -;;; Code: - -(defvar extra-click-wait 150 - "*Number of milliseconds to wait for an extra click. -Set this to zero if you don't want chords or double clicks.") - -(defvar scrollbar-width 5 - "*The character width of the scrollbar. -The cursor is deemed to be in the right edge scrollbar if it is this near the -right edge, and more than two chars past the end of the indicated line. -Setting to nil limits the scrollbar to the edge or vertical dividing bar.") - -;;; -;;; Mousemaps -;;; -(defun make-mousemap () - "Returns a new mousemap." - (cons 'mousemap nil)) - -;;; initialize mouse maps -(defvar current-global-mousemap (make-mousemap)) -(defvar current-local-mousemap nil) -(make-variable-buffer-local 'current-local-mousemap) - -(defun copy-mousemap (mousemap) - "Return a copy of mousemap." - (copy-alist mousemap)) - -(defun define-mouse (mousemap mouse-list def) - "Args MOUSEMAP, MOUSE-LIST, DEF. Define MOUSE-LIST in MOUSEMAP as DEF. -MOUSE-LIST is a list of atoms specifying a mouse hit according to these rules: - * One of these atoms specifies the active region of the definition. - text, scrollbar, modeline, minibuffer - * One or two or these atoms specify the button or button combination. - left, middle, right, double - * Any combination of these atoms specify the active shift keys. - control, shift, meta - * With a single unshifted button, you can add - up - to indicate an up-click. -The atom `double' is used with a button designator to denote a double click. -Two button chords are denoted by listing the two buttons. -See sun-mouse-handler for the treatment of the form DEF." - (mousemap-set (mouse-list-to-mouse-code mouse-list) mousemap def)) - -(defun global-set-mouse (mouse-list def) - "Give MOUSE-EVENT-LIST a local definition of DEF. -See define-mouse for a description of MOUSE-EVENT-LIST and DEF. -Note that if MOUSE-EVENT-LIST has a local definition in the current buffer, -that local definition will continue to shadow any global definition." - (interactive "xMouse event: \nxDefinition: ") - (define-mouse current-global-mousemap mouse-list def)) - -(defun local-set-mouse (mouse-list def) - "Give MOUSE-EVENT-LIST a local definition of DEF. -See define-mouse for a description of the arguments. -The definition goes in the current buffer's local mousemap. -Normally buffers in the same major mode share a local mousemap." - (interactive "xMouse event: \nxDefinition: ") - (if (null current-local-mousemap) - (setq current-local-mousemap (make-mousemap))) - (define-mouse current-local-mousemap mouse-list def)) - -(defun use-global-mousemap (mousemap) - "Selects MOUSEMAP as the global mousemap." - (setq current-global-mousemap mousemap)) - -(defun use-local-mousemap (mousemap) - "Selects MOUSEMAP as the local mousemap. -nil for MOUSEMAP means no local mousemap." - (setq current-local-mousemap mousemap)) - - -;;; -;;; Interface to the Mouse encoding defined in Emacstool.c -;;; -;;; Called when mouse-prefix is sent to emacs, additional -;;; information is read in as a list (button x y time-delta) -;;; -;;; First, some generally useful functions: -;;; - -(defun logtest (x y) - "True if any bits set in X are also set in Y. -Just like the Common Lisp function of the same name." - (not (zerop (logand x y)))) - - -;;; -;;; Hit accessors. -;;; - -(defconst sm::ButtonBits 7) ; Lowest 3 bits. -(defconst sm::ShiftmaskBits 56) ; Second lowest 3 bits (56 = 63 - 7). -(defconst sm::DoubleBits 64) ; Bit 7. -(defconst sm::UpBits 128) ; Bit 8. - -;;; All the useful code bits -(defmacro sm::hit-code (hit) - `(nth 0 ,hit)) -;;; The button, or buttons if a chord. -(defmacro sm::hit-button (hit) - `(logand sm::ButtonBits (nth 0 ,hit))) -;;; The shift, control, and meta flags. -(defmacro sm::hit-shiftmask (hit) - `(logand sm::ShiftmaskBits (nth 0 ,hit))) -;;; Set if a double click (but not a chord). -(defmacro sm::hit-double (hit) - `(logand sm::DoubleBits (nth 0 ,hit))) -;;; Set on button release (as opposed to button press). -(defmacro sm::hit-up (hit) - `(logand sm::UpBits (nth 0 ,hit))) -;;; Screen x position. -(defmacro sm::hit-x (hit) (list 'nth 1 hit)) -;;; Screen y position. -(defmacro sm::hit-y (hit) (list 'nth 2 hit)) -;;; Milliseconds since last hit. -(defmacro sm::hit-delta (hit) (list 'nth 3 hit)) - -(defmacro sm::hit-up-p (hit) ; A predicate. - `(not (zerop (sm::hit-up ,hit)))) - -;;; -;;; Loc accessors. for sm::window-xy -;;; -(defmacro sm::loc-w (loc) (list 'nth 0 loc)) -(defmacro sm::loc-x (loc) (list 'nth 1 loc)) -(defmacro sm::loc-y (loc) (list 'nth 2 loc)) - -(defmacro eval-in-buffer (buffer &rest forms) - "Macro to switches to BUFFER, evaluates FORMS, returns to original buffer." - ;; When you don't need the complete window context of eval-in-window - `(let ((StartBuffer (current-buffer))) - (unwind-protect - (progn - (set-buffer ,buffer) - ,@forms) - (set-buffer StartBuffer)))) - -(put 'eval-in-buffer 'lisp-indent-function 1) - -;;; this is used extensively by sun-fns.el -;;; -(defmacro eval-in-window (window &rest forms) - "Switch to WINDOW, evaluate FORMS, return to original window." - `(let ((OriginallySelectedWindow (selected-window))) - (unwind-protect - (progn - (select-window ,window) - ,@forms) - (select-window OriginallySelectedWindow)))) -(put 'eval-in-window 'lisp-indent-function 1) - -;;; -;;; handy utility, generalizes window_loop -;;; - -;;; It's a macro (and does not evaluate its arguments). -(defmacro eval-in-windows (form &optional yesmini) - "Switches to each window and evaluates FORM. Optional argument -YESMINI says to include the minibuffer as a window. -This is a macro, and does not evaluate its arguments." - `(let ((OriginallySelectedWindow (selected-window))) - (unwind-protect - (while (progn - ,form - (not (eq OriginallySelectedWindow - (select-window - (next-window nil ,yesmini)))))) - (select-window OriginallySelectedWindow)))) -(put 'eval-in-window 'lisp-indent-function 0) - -(defun move-to-loc (x y) - "Move cursor to window location X, Y. -Handles wrapped and horizontally scrolled lines correctly." - (move-to-window-line y) - ;; window-line-end expects this to return the window column it moved to. - (let ((cc (current-column)) - (nc (move-to-column - (if (zerop (window-hscroll)) - (+ (current-column) - (min (- (window-width) 2) ; To stay on the line. - x)) - (+ (window-hscroll) -1 - (min (1- (window-width)) ; To stay on the line. - x)))))) - (- nc cc))) - - -(defun minibuffer-window-p (window) - "True if this WINDOW is minibuffer." - (= (frame-height) - (nth 3 (window-edges window)) ; The bottom edge. - )) - - -(defun sun-mouse-handler (&optional hit) - "Evaluates the function or list associated with a mouse hit. -Expecting to read a hit, which is a list: (button x y delta). -A form bound to button by define-mouse is found by mouse-lookup. -The variables: *mouse-window*, *mouse-x*, *mouse-y* are bound. -If the form is a symbol (symbolp), it is funcall'ed with *mouse-window*, -*mouse-x*, and *mouse-y* as arguments; if the form is a list (listp), -the form is eval'ed; if the form is neither of these, it is an error. -Returns nil." - (interactive) - (if (null hit) (setq hit (sm::combined-hits))) - (let ((loc (sm::window-xy (sm::hit-x hit) (sm::hit-y hit)))) - (let ((*mouse-window* (sm::loc-w loc)) - (*mouse-x* (sm::loc-x loc)) - (*mouse-y* (sm::loc-y loc)) - (mouse-code (mouse-event-code hit loc))) - (let ((form (eval-in-buffer (window-buffer *mouse-window*) - (mouse-lookup mouse-code)))) - (cond ((null form) - (if (not (sm::hit-up-p hit)) ; undefined up hits are ok. - (error "Undefined mouse event: %s" - (prin1-to-string - (mouse-code-to-mouse-list mouse-code))))) - ((symbolp form) - (setq this-command form) - (funcall form *mouse-window* *mouse-x* *mouse-y*)) - ((listp form) - (setq this-command (car form)) - (eval form)) - (t - (error "Mouse action must be symbol or list, but was: %s" - form)))))) - ;; Don't let 'sun-mouse-handler get on last-command, - ;; since this function should be transparent. - (if (eq this-command 'sun-mouse-handler) - (setq this-command last-command)) - ;; (message (prin1-to-string this-command)) ; to see what your buttons did - nil) - -(defun sm::combined-hits () - "Read and return next mouse-hit, include possible double click" - (let ((hit1 (mouse-hit-read))) - (if (not (sm::hit-up-p hit1)) ; Up hits don't start doubles or chords. - (let ((hit2 (mouse-second-hit extra-click-wait))) - (if hit2 ; we cons'd it, we can smash it. - ; (setf (sm::hit-code hit1) (logior (sm::hit-code hit1) ...)) - (setcar hit1 (logior (sm::hit-code hit1) - (sm::hit-code hit2) - (if (= (sm::hit-button hit1) - (sm::hit-button hit2)) - sm::DoubleBits 0)))))) - hit1)) - -(defun mouse-hit-read () - "Read mouse-hit list from keyboard. Like (read 'read-char), -but that uses minibuffer, and mucks up last-command." - (let ((char-list nil) (char nil)) - (while (not (equal 13 ; Carriage return. - (prog1 (setq char (read-char)) - (setq char-list (cons char char-list)))))) - (read (mapconcat 'char-to-string (nreverse char-list) "")) - )) - -;;; Second Click Hackery.... -;;; if prefix is not mouse-prefix, need a way to unread the char... -;;; or else have mouse flush input queue, or else need a peek at next char. - -;;; There is no peek, but since one character can be unread, we only -;;; have to flush the queue when the command after a mouse click -;;; starts with mouse-prefix1 (see below). -;;; Something to do later: We could buffer the read commands and -;;; execute them ourselves after doing the mouse command (using -;;; lookup-key ??). - -(defvar mouse-prefix1 24 ; C-x - "First char of mouse-prefix. Used to detect double clicks and chords.") - -(defvar mouse-prefix2 0 ; C-@ - "Second char of mouse-prefix. Used to detect double clicks and chords.") - - -(defun mouse-second-hit (hit-wait) - "Returns the next mouse hit occurring within HIT-WAIT milliseconds." - (if (sit-for-millisecs hit-wait) nil ; No input within hit-wait millisecs. - (let ((pc1 (read-char))) - (if (or (not (equal pc1 mouse-prefix1)) - (sit-for-millisecs 3)) ; a mouse prefix will have second char - ;; Can get away with one unread. - (progn (setq unread-command-events (list pc1)) - nil) ; Next input not mouse event. - (let ((pc2 (read-char))) - (if (not (equal pc2 mouse-prefix2)) - (progn (setq unread-command-events (list pc1)) ; put back the ^X -;;; Too bad can't do two: (setq unread-command-event (list pc1 pc2)) -;;; Well, now we can, but I don't understand this code well enough to fix it... - (ding) ; user will have to retype that pc2. - nil) ; This input is not a mouse event. - ;; Next input has mouse prefix and is within time limit. - (let ((new-hit (mouse-hit-read))) ; Read the new hit. - (if (sm::hit-up-p new-hit) ; Ignore up events when timing. - (mouse-second-hit (- hit-wait (sm::hit-delta new-hit))) - new-hit ; New down hit within limit, return it. - )))))))) - -(defun sm::window-xy (x y) - "Find window containing screen coordinates X and Y. -Returns list (window x y) where x and y are relative to window." - (or - (catch 'found - (eval-in-windows - (let ((we (window-edges (selected-window)))) - (let ((le (nth 0 we)) - (te (nth 1 we)) - (re (nth 2 we)) - (be (nth 3 we))) - (if (= re (frame-width)) - ;; include the continuation column with this window - (setq re (1+ re))) - (if (= be (frame-height)) - ;; include partial line at bottom of frame with this window - ;; id est, if window is not multiple of char size. - (setq be (1+ be))) - - (if (and (>= x le) (< x re) - (>= y te) (< y be)) - (throw 'found - (list (selected-window) (- x le) (- y te)))))) - t)) ; include minibuffer in eval-in-windows - ;;If x,y from a real mouse click, we shouldn't get here. - (list nil x y) - )) - -(defun sm::window-region (loc) - "Parse LOC into a region symbol. -Returns one of (text scrollbar modeline minibuffer)" - (let ((w (sm::loc-w loc)) - (x (sm::loc-x loc)) - (y (sm::loc-y loc))) - (let ((right (1- (window-width w))) - (bottom (1- (window-height w)))) - (cond ((minibuffer-window-p w) 'minibuffer) - ((>= y bottom) 'modeline) - ((>= x right) 'scrollbar) - ;; far right column (window separator) is always a scrollbar - ((and scrollbar-width - ;; mouse within scrollbar-width of edge. - (>= x (- right scrollbar-width)) - ;; mouse a few chars past the end of line. - (>= x (+ 2 (window-line-end w x y)))) - 'scrollbar) - (t 'text))))) - -(defun window-line-end (w x y) - "Return WINDOW column (ignore X) containing end of line Y" - (eval-in-window w (save-excursion (move-to-loc (frame-width) y)))) - -;;; -;;; The encoding of mouse events into a mousemap. -;;; These values must agree with coding in emacstool: -;;; -(defconst sm::keyword-alist - '((left . 1) (middle . 2) (right . 4) - (shift . 8) (control . 16) (meta . 32) (double . 64) (up . 128) - (text . 256) (scrollbar . 512) (modeline . 1024) (minibuffer . 2048) - )) - -(defun mouse-event-code (hit loc) - "Maps MOUSE-HIT and LOC into a mouse-code." -;;;Region is a code for one of text, modeline, scrollbar, or minibuffer. - (logior (sm::hit-code hit) - (mouse-region-to-code (sm::window-region loc)))) - -(defun mouse-region-to-code (region) - "Returns partial mouse-code for specified REGION." - (cdr (assq region sm::keyword-alist))) - -(defun mouse-list-to-mouse-code (mouse-list) - "Map a MOUSE-LIST to a mouse-code." - (apply 'logior - (mapcar (function (lambda (x) - (cdr (assq x sm::keyword-alist)))) - mouse-list))) - -(defun mouse-code-to-mouse-list (mouse-code) - "Map a MOUSE-CODE to a mouse-list." - (apply 'nconc (mapcar - (function (lambda (x) - (if (logtest mouse-code (cdr x)) - (list (car x))))) - sm::keyword-alist))) - -(defun mousemap-set (code mousemap value) - (let* ((alist (cdr mousemap)) - (assq-result (assq code alist))) - (if assq-result - (setcdr assq-result value) - (setcdr mousemap (cons (cons code value) alist))))) - -(defun mousemap-get (code mousemap) - (cdr (assq code (cdr mousemap)))) - -(defun mouse-lookup (mouse-code) - "Look up MOUSE-EVENT and return the definition. nil means undefined." - (or (mousemap-get mouse-code current-local-mousemap) - (mousemap-get mouse-code current-global-mousemap))) - -;;; -;;; I (jpeck) don't understand the utility of the next four functions -;;; ask Steven Greenbaum <froud@kestrel> -;;; -(defun mouse-mask-lookup (mask list) - "Args MASK (a bit mask) and LIST (a list of (code . form) pairs). -Returns a list of elements of LIST whose code or'ed with MASK is non-zero." - (let ((result nil)) - (while list - (if (logtest mask (car (car list))) - (setq result (cons (car list) result))) - (setq list (cdr list))) - result)) - -(defun mouse-union (l l-unique) - "Return the union of list of mouse (code . form) pairs L and L-UNIQUE, -where L-UNIQUE is considered to be union'ized already." - (let ((result l-unique)) - (while l - (let ((code-form-pair (car l))) - (if (not (assq (car code-form-pair) result)) - (setq result (cons code-form-pair result)))) - (setq l (cdr l))) - result)) - -(defun mouse-union-first-preferred (l1 l2) - "Return the union of lists of mouse (code . form) pairs L1 and L2, -based on the code's, with preference going to elements in L1." - (mouse-union l2 (mouse-union l1 nil))) - -(defun mouse-code-function-pairs-of-region (region) - "Return a list of (code . function) pairs, where each code is -currently set in the REGION." - (let ((mask (mouse-region-to-code region))) - (mouse-union-first-preferred - (mouse-mask-lookup mask (cdr current-local-mousemap)) - (mouse-mask-lookup mask (cdr current-global-mousemap)) - ))) - -;;; -;;; Functions for DESCRIBE-MOUSE-BINDINGS -;;; And other mouse documentation functions -;;; Still need a good procedure to print out a help sheet in readable format. -;;; - -(defun one-line-doc-string (function) - "Returns first line of documentation string for FUNCTION. -If there is no documentation string, then the string -\"No documentation\" is returned." - (while (consp function) (setq function (car function))) - (let ((doc (documentation function))) - (if (null doc) - "No documentation." - (string-match "^.*$" doc) - (substring doc 0 (match-end 0))))) - -(defun print-mouse-format (binding) - (princ (car binding)) - (princ ": ") - (mapc (function - (lambda (mouse-list) - (princ mouse-list) - (princ " "))) - (cdr binding)) - (terpri) - (princ " ") - (princ (one-line-doc-string (car binding))) - (terpri) - ) - -(defun print-mouse-bindings (region) - "Prints mouse-event bindings for REGION." - (mapcar 'print-mouse-format (sm::event-bindings region))) - -(defun sm::event-bindings (region) - "Returns an alist of (function . (mouse-list1 ... mouse-listN)) for REGION, -where each mouse-list is bound to the function in REGION." - (let ((mouse-bindings (mouse-code-function-pairs-of-region region)) - (result nil)) - (while mouse-bindings - (let* ((code-function-pair (car mouse-bindings)) - (current-entry (assoc (cdr code-function-pair) result))) - (if current-entry - (setcdr current-entry - (cons (mouse-code-to-mouse-list (car code-function-pair)) - (cdr current-entry))) - (setq result (cons (cons (cdr code-function-pair) - (list (mouse-code-to-mouse-list - (car code-function-pair)))) - result)))) - (setq mouse-bindings (cdr mouse-bindings)) - ) - result)) - -(defun describe-mouse-bindings () - "Lists all current mouse-event bindings." - (interactive) - (with-output-to-temp-buffer "*Help*" - (princ "Text Region") (terpri) - (princ "---- ------") (terpri) - (print-mouse-bindings 'text) (terpri) - (princ "Modeline Region") (terpri) - (princ "-------- ------") (terpri) - (print-mouse-bindings 'modeline) (terpri) - (princ "Scrollbar Region") (terpri) - (princ "--------- ------") (terpri) - (print-mouse-bindings 'scrollbar))) - -(defun describe-mouse-briefly (mouse-list) - "Print a short description of the function bound to MOUSE-LIST." - (interactive "xDescribe mouse list briefly: ") - (let ((function (mouse-lookup (mouse-list-to-mouse-code mouse-list)))) - (if function - (message "%s runs the command %s" mouse-list function) - (message "%s is undefined" mouse-list)))) - -(defun mouse-help-menu (function-and-binding) - (cons (prin1-to-string (car function-and-binding)) - (menu-create ; Two sub-menu items of form ("String" . nil) - (list (list (one-line-doc-string (car function-and-binding))) - (list (prin1-to-string (cdr function-and-binding))))))) - -(defun mouse-help-region (w x y &optional region) - "Displays a menu of mouse functions callable in this region." - (let* ((region (or region (sm::window-region (list w x y)))) - (mlist (mapcar (function mouse-help-menu) - (sm::event-bindings region))) - (menu (menu-create (cons (list (symbol-name region)) mlist))) - (item (sun-menu-evaluate w 0 y menu)) - ))) - -;;; -;;; Menu interface functions -;;; -;;; use defmenu, because this interface is subject to change -;;; really need a menu-p, but we use vectorp and the context... -;;; -(defun menu-create (items) - "Functional form for defmenu, given a list of ITEMS returns a menu. -Each ITEM is a (STRING . VALUE) pair." - (apply 'vector items) - ) - -(defmacro defmenu (menu &rest itemlist) - "Defines MENU to be a menu, the ITEMS are (STRING . VALUE) pairs. -See sun-menu-evaluate for interpretation of ITEMS." - (list 'defconst menu (funcall 'menu-create itemlist)) - ) - -(defun sun-menu-evaluate (*menu-window* *menu-x* *menu-y* menu) - "Display a pop-up menu in WINDOW at X Y and evaluate selected item -of MENU. MENU (or its symbol-value) should be a menu defined by defmenu. - A menu ITEM is a (STRING . FORM) pair; -the FORM associated with the selected STRING is evaluated, -and the resulting value is returned. Generally these FORMs are -evaluated for their side-effects rather than their values. - If the selected form is a menu or a symbol whose value is a menu, -then it is displayed and evaluated as a pullright menu item. - If the FORM of the first ITEM is nil, the STRING of the item -is used as a label for the menu, i.e. it's inverted and not selectable." - - (if (symbolp menu) (setq menu (symbol-value menu))) - (eval (sun-menu-internal *menu-window* *menu-x* *menu-y* 4 menu))) - -(defun sun-get-frame-data (code) - "Sends the tty-sub-window escape sequence CODE to terminal, -and returns a cons of the two numbers in returned escape sequence. -That is it returns (cons <car> <cdr>) from \"\\E[n;<car>;<cdr>t\". -CODE values: 13 = Tool-Position, 14 = Size-in-Pixels, 18 = Size-in-Chars." - (send-string-to-terminal (concat "\033[" (int-to-string code) "t")) - (let (char str x y) - (while (not (equal 116 (setq char (read-char)))) ; #\t = 116 - (setq str (cons char str))) - (setq str (mapconcat 'char-to-string (nreverse str) "")) - (string-match ";[0-9]*" str) - (setq y (substring str (1+ (match-beginning 0)) (match-end 0))) - (setq str (substring str (match-end 0))) - (string-match ";[0-9]*" str) - (setq x (substring str (1+ (match-beginning 0)) (match-end 0))) - (cons (string-to-number y) (string-to-number x)))) - -(defun sm::font-size () - "Returns font size in pixels: (cons Ysize Xsize)" - (let ((pix (sun-get-frame-data 14)) ; returns size in pixels - (chr (sun-get-frame-data 18))) ; returns size in chars - (cons (/ (car pix) (car chr)) (/ (cdr pix) (cdr chr))))) - -(defvar sm::menu-kludge-x nil - "Cached frame-to-window X-Offset for sm::menu-kludge") -(defvar sm::menu-kludge-y nil - "Cached frame-to-window Y-Offset for sm::menu-kludge") - -(defun sm::menu-kludge () - "If sunfns.c uses <Menu_Base_Kludge> this function must be here!" - (or sm::menu-kludge-y - (let ((fs (sm::font-size))) - (setq sm::menu-kludge-y (+ 8 (car fs)) ; a title line and borders - sm::menu-kludge-x 4))) ; best values depend on .defaults/Menu - (let ((wl (sun-get-frame-data 13))) ; returns frame location - (cons (+ (car wl) sm::menu-kludge-y) - (+ (cdr wl) sm::menu-kludge-x)))) - -;;; -;;; Function interface to selection/region -;;; primitive functions are defined in sunfns.c -;;; -(defun sun-yank-selection () - "Set mark and yank the contents of the current sunwindows selection. -Insert contents into the current buffer at point." - (interactive "*") - (set-mark-command nil) - (insert (sun-get-selection))) - -(defun sun-select-region (beg end) - "Set the sunwindows selection to the region in the current buffer." - (interactive "r") - (sun-set-selection (buffer-substring beg end))) - -(provide 'sun-mouse) -(provide 'term/sun-mouse) ; have to (require 'term/sun-mouse) - -;;; arch-tag: 6e879372-b899-4509-833f-d7f6250e309a -;;; sun-mouse.el ends here diff --git a/lisp/term/sun.el b/lisp/term/sun.el index 4736e57340..22b29c9279 100644 --- a/lisp/term/sun.el +++ b/lisp/term/sun.el @@ -47,14 +47,6 @@ (setq this-command 'kill-region-and-unmark) (set-mark-command t)) -(defun select-previous-complex-command () - "Select Previous-complex-command" - (interactive) - (if (zerop (minibuffer-depth)) - (repeat-complex-command 1) - ;; FIXME: this function does not seem to exist. -stef'01 - (previous-complex-command 1))) - (defun rerun-prev-command () "Repeat Previous-complex-command." (interactive) diff --git a/src/ChangeLog b/src/ChangeLog index 638ca30e04..4e93e3937f 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,11 @@ +2007-11-01 Dan Nicolaescu <dann@ics.uci.edu> + + * sunfns.c: Remove file + + * m/sun386.h: + * m/sun2.h: + * m/sparc.h: Remove Sun windows code. + 2007-10-31 Stefan Monnier <monnier@iro.umontreal.ca> * keyboard.c (syms_of_keyboard): Initialize the initial_kboard. diff --git a/src/m/sparc.h b/src/m/sparc.h index 8df81ee91a..bf122d857c 100644 --- a/src/m/sparc.h +++ b/src/m/sparc.h @@ -64,18 +64,6 @@ NOTE-END */ #define SEGMENT_MASK (SEGSIZ - 1) -/* Arrange to link with sun windows, if requested. */ -/* For details on emacstool and sunfns, see etc/SUN-SUPPORT */ -/* These programs require Sun UNIX 4.2 Release 3.2 or greater */ - -#ifdef HAVE_SUN_WINDOWS -#define OTHER_FILES ${etcdir}emacstool -#define LIBS_MACHINE -lsuntool -lsunwindow -lpixrect -#define OBJECTS_MACHINE sunfns.o -#define SYMS_MACHINE syms_of_sunfns () -#define PURESIZE 130000 -#endif - #if !defined (__NetBSD__) && !defined (__linux__) && !defined (__OpenBSD__) /* This really belongs in s/sun.h. */ diff --git a/src/m/sun2.h b/src/m/sun2.h index e764ded3ce..a872bf6f3b 100644 --- a/src/m/sun2.h +++ b/src/m/sun2.h @@ -85,17 +85,5 @@ NOTE-END */ #define SEGMENT_MASK (SEGSIZ - 1) -/* Arrange to link with sun windows, if requested. */ -/* For details on emacstool and sunfns, see etc/SUN-SUPPORT */ -/* These programs require Sun UNIX 4.2 Release 3.2 or greater */ - -#ifdef HAVE_SUN_WINDOWS -#define OTHER_FILES ${libsrc}emacstool -#define LIBS_MACHINE -lsuntool -lsunwindow -lpixrect -#define OBJECTS_MACHINE sunfns.o -#define SYMS_MACHINE syms_of_sunfns () -#define PURESIZE 132000 -#endif - /* arch-tag: 543c3570-74ca-4099-aa47-db7c7b691c8e (do not change this comment) */ diff --git a/src/m/sun386.h b/src/m/sun386.h index a3eedbe755..ed98960c80 100644 --- a/src/m/sun386.h +++ b/src/m/sun386.h @@ -56,18 +56,6 @@ NOTE-END */ #define LIBS_TERMCAP -ltermcap -/* Arrange to link with sun windows, if requested. */ -/* For details on emacstool and sunfns, see etc/SUN-SUPPORT */ -/* These programs require Sun UNIX 4.2 Release 3.2 or greater */ - -#ifdef HAVE_SUN_WINDOWS -#define OTHER_FILES ${etcdir}emacstool -#define LIBS_MACHINE -lsuntool -lsunwindow -lpixrect -#define OBJECTS_MACHINE sunfns.o -#define SYMS_MACHINE syms_of_sunfns () -#define PURESIZE 132000 -#endif - /* Roadrunner uses 'COFF' format */ #define COFF diff --git a/src/sunfns.c b/src/sunfns.c deleted file mode 100644 index 86e64cbcdc..0000000000 --- a/src/sunfns.c +++ /dev/null @@ -1,519 +0,0 @@ -/* Functions for Sun Windows menus and selection buffer. - Copyright (C) 1987, 1999, 2001, 2002, 2003, 2004, - 2005, 2006, 2007 Free Software Foundation, Inc. - -This file is probably totally obsolete. In any case, the FSF is -unwilling to support it. We agreed to include it in our distribution -only on the understanding that we would spend no time at all on it. - -If you have complaints about this file, send them to peck@sun.com. -If no one at Sun wants to maintain this, then consider it not -maintained at all. It would be a bad thing for the GNU project if -this file took our effort away from higher-priority things. - - -This file is part of GNU Emacs. - -GNU Emacs is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 3, or (at your option) -any later version. - -GNU Emacs is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU Emacs; see the file COPYING. If not, write to -the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -Boston, MA 02110-1301, USA. */ - -/* Author: Jeff Peck, Sun Microsystems, Inc. <peck@sun.com> -Original ideas by David Kastan and Eric Negaard, SRI International -Major help from: Steve Greenbaum, Reasoning Systems, Inc. - <froud@kestrel.arpa> -who first discovered the Menu_Base_Kludge. - */ - -/* - * Emacs Lisp-Callable functions for sunwindows - */ -#include <config.h> - -#include <stdio.h> -#include <errno.h> -#include <signal.h> -#include <sunwindow/window_hs.h> -#include <suntool/selection.h> -#include <suntool/menu.h> -#include <suntool/walkmenu.h> -#include <suntool/frame.h> -#include <suntool/window.h> - -#include <fcntl.h> -#undef NULL /* We don't need sunview's idea of NULL */ -#include "lisp.h" -#include "window.h" -#include "buffer.h" -#include "termhooks.h" - -/* conversion to/from character & frame coordinates */ -/* From Gosling Emacs SunWindow driver by Chris Torek */ - -/* Chars to frame coords. Note that we speak in zero origin. */ -#define CtoSX(cx) ((cx) * Sun_Font_Xsize) -#define CtoSY(cy) ((cy) * Sun_Font_Ysize) - -/* Frame coords to chars */ -#define StoCX(sx) ((sx) / Sun_Font_Xsize) -#define StoCY(sy) ((sy) / Sun_Font_Ysize) - -#define CHECK_GFX(x) if((win_fd<0)&&(Fsun_window_init(),(win_fd<0)))return(x) -int win_fd = -1; -struct pixfont *Sun_Font; /* The font */ -int Sun_Font_Xsize; /* Width of font */ -int Sun_Font_Ysize; /* Height of font */ - -#define Menu_Base_Kludge /* until menu_show_using_fd gets fixed */ -#ifdef Menu_Base_Kludge -static Frame Menu_Base_Frame; -static int Menu_Base_fd; -static Lisp_Object sm_kludge_string; -#endif -struct cursor CurrentCursor; /* The current cursor */ - -static short CursorData[16]; /* Build cursor here */ -static mpr_static(CursorMpr, 16, 16, 1, CursorData); -static struct cursor NewCursor = {0, 0, PIX_SRC ^ PIX_DST, &CursorMpr}; - -#define RIGHT_ARROW_CURSOR /* if you want the right arrow */ -#ifdef RIGHT_ARROW_CURSOR -/* The default right-arrow cursor, with XOR drawing. */ -static short ArrowCursorData[16] = { - 0x0001,0x0003,0x0007,0x000F,0x001F,0x003F,0x007F,0x000F, - 0x001B,0x0019,0x0030,0x0030,0x0060,0x0060,0x00C0,0x00C0}; -static mpr_static(ArrowCursorMpr, 16, 16, 1, ArrowCursorData); -struct cursor DefaultCursor = {15, 0, PIX_SRC ^ PIX_DST, &ArrowCursorMpr}; - -#else -/* The default left-arrow cursor, with XOR drawing. */ -static short ArrowCursorData[16] = { - 0x8000,0xC000,0xE000,0xF000,0xF800,0xFC00,0xFE00,0xF000, - 0xD800,0x9800,0x0C00,0x0C00,0x0600,0x0600,0x0300,0x0300}; -static mpr_static(ArrowCursorMpr, 16, 16, 1, ArrowCursorData); -struct cursor DefaultCursor = {0, 0, PIX_SRC ^ PIX_DST, &ArrowCursorMpr}; -#endif - -/* - * Initialize window - */ -DEFUN ("sun-window-init", Fsun_window_init, Ssun_window_init, 0, 1, 0, - doc: /* One time setup for using Sun Windows with mouse. -Unless optional argument FORCE is non-nil, is a noop after its first call. -Returns a number representing the file descriptor of the open Sun Window, -or -1 if can not open it. */) - (force) - Lisp_Object force; -{ - char *cp; - static int already_initialized = 0; - - if ((! already_initialized) || (!NILP(force))) { - cp = getenv("WINDOW_GFX"); - if (cp != 0) win_fd = emacs_open (cp, O_RDWR, 0); - if (win_fd > 0) - { - Sun_Font = pf_default(); - Sun_Font_Xsize = Sun_Font->pf_defaultsize.x; - Sun_Font_Ysize = Sun_Font->pf_defaultsize.y; - Fsun_change_cursor_icon (Qnil); /* set up the default cursor */ - already_initialized = 1; -#ifdef Menu_Base_Kludge - - /* Make a frame to use for putting the menu on, and get its fd. */ - Menu_Base_Frame = window_create(0, FRAME, - WIN_X, 0, WIN_Y, 0, - WIN_ROWS, 1, WIN_COLUMNS, 1, - WIN_SHOW, FALSE, - FRAME_NO_CONFIRM, 1, - 0); - Menu_Base_fd = (int) window_get(Menu_Base_Frame, WIN_FD); -#endif - } - } - return(make_number(win_fd)); -} - -/* - * Mouse sit-for (allows a shorter interval than the regular sit-for - * and can be interrupted by the mouse) - */ -DEFUN ("sit-for-millisecs", Fsit_for_millisecs, Ssit_for_millisecs, 1, 1, 0, - doc: /* Like sit-for, but ARG is milliseconds. -Perform redisplay, then wait for ARG milliseconds or until -input is available. Returns t if wait completed with no input. -Redisplay does not happen if input is available before it starts. */) - (n) - Lisp_Object n; -{ - struct timeval Timeout; - int waitmask = 1; - - CHECK_NUMBER (n); - Timeout.tv_sec = XINT(n) / 1000; - Timeout.tv_usec = (XINT(n) - (Timeout.tv_sec * 1000)) * 1000; - - if (detect_input_pending()) return(Qnil); - redisplay_preserve_echo_area (16); - /* - * Check for queued keyboard input/mouse hits again - * (A bit screen update can take some time!) - */ - if (detect_input_pending()) return(Qnil); - select(1,&waitmask,0,0,&Timeout); - if (detect_input_pending()) return(Qnil); - return(Qt); -} - -/* - * Sun sleep-for (allows a shorter interval than the regular sleep-for) - */ -DEFUN ("sleep-for-millisecs", - Fsleep_for_millisecs, - Ssleep_for_millisecs, 1, 1, 0, - doc: /* Pause, without updating display, for ARG milliseconds. */) - (n) - Lisp_Object n; -{ - unsigned useconds; - - CHECK_NUMBER (n); - useconds = XINT(n) * 1000; - usleep(useconds); - return(Qt); -} - -DEFUN ("update-display", Fupdate_display, Supdate_display, 0, 0, 0, - doc: /* Perform redisplay. */) - () -{ - redisplay_preserve_echo_area (17); - return(Qt); -} - - -/* - * Change the Sun mouse icon - */ -DEFUN ("sun-change-cursor-icon", - Fsun_change_cursor_icon, - Ssun_change_cursor_icon, 1, 1, 0, - doc: /* Change the Sun mouse cursor icon. -ICON is a lisp vector whose 1st element -is the X offset of the cursor hot-point, whose 2nd element is the Y offset -of the cursor hot-point and whose 3rd element is the cursor pixel data -expressed as a string. If ICON is nil then the original arrow cursor is used. */) - (Icon) - Lisp_Object Icon; -{ - register unsigned char *cp; - register short *p; - register int i; - Lisp_Object X_Hot, Y_Hot, Data; - - CHECK_GFX (Qnil); - /* - * If the icon is null, we just restore the DefaultCursor - */ - if (NILP(Icon)) - CurrentCursor = DefaultCursor; - else { - /* - * extract the data from the vector - */ - CHECK_VECTOR (Icon); - if (XVECTOR(Icon)->size < 3) return(Qnil); - X_Hot = XVECTOR(Icon)->contents[0]; - Y_Hot = XVECTOR(Icon)->contents[1]; - Data = XVECTOR(Icon)->contents[2]; - - CHECK_NUMBER (X_Hot); - CHECK_NUMBER (Y_Hot); - CHECK_STRING (Data); - if (SCHARS (Data) != 32) return(Qnil); - /* - * Setup the new cursor - */ - NewCursor.cur_xhot = X_Hot; - NewCursor.cur_yhot = Y_Hot; - cp = SDATA (Data); - p = CursorData; - i = 16; - while(--i >= 0) - *p++ = (cp[0] << 8) | cp[1], cp += 2; - CurrentCursor = NewCursor; - } - win_setcursor(win_fd, &CurrentCursor); - return(Qt); -} - -/* - * Interface for sunwindows selection - */ -static Lisp_Object Current_Selection; - -static -sel_write (sel, file) - struct selection *sel; - FILE *file; -{ - fwrite (SDATA (Current_Selection), sizeof (char), - sel->sel_items, file); -} - -static -sel_clear (sel, windowfd) - struct selection *sel; - int windowfd; -{ -} - -static -sel_read (sel, file) - struct selection *sel; - FILE *file; -{ - register int i, n; - register char *cp; - - Current_Selection = empty_unibyte_string; - if (sel->sel_items <= 0) - return (0); - cp = (char *) malloc(sel->sel_items); - if (cp == (char *)0) { - error("malloc failed in sel_read"); - return(-1); - } - n = fread(cp, sizeof(char), sel->sel_items, file); - if (n > sel->sel_items) { - error("fread botch in sel_read"); - return(-1); - } else if (n < 0) { - error("Error reading selection"); - return(-1); - } - /* - * The shelltool select saves newlines as carriage returns, - * but emacs wants newlines. - */ - for (i = 0; i < n; i++) - if (cp[i] == '\r') cp[i] = '\n'; - - Current_Selection = make_string (cp, n); - free (cp); - return (0); -} - -/* - * Set the window system "selection" to be the arg STRING - */ -DEFUN ("sun-set-selection", Fsun_set_selection, Ssun_set_selection, 1, 1, - "sSet selection to: ", - doc: /* Set the current sunwindow selection to STRING. */) - (str) - Lisp_Object str; -{ - struct selection selection; - - CHECK_STRING (str); - Current_Selection = str; - - CHECK_GFX (Qnil); - selection.sel_type = SELTYPE_CHAR; - selection.sel_items = SCHARS (str); - selection.sel_itembytes = 1; - selection.sel_pubflags = 1; - selection_set(&selection, sel_write, sel_clear, win_fd); - return (Qt); -} -/* - * Stuff the current window system selection into the current buffer - */ -DEFUN ("sun-get-selection", Fsun_get_selection, Ssun_get_selection, 0, 0, 0, - doc: /* Return the current sunwindows selection as a string. */) - () -{ - CHECK_GFX (Current_Selection); - selection_get (sel_read, win_fd); - return (Current_Selection); -} - -Menu sun_menu_create(); - -Menu_item -sun_item_create (Pair) - Lisp_Object Pair; -{ - /* In here, we depend on Lisp supplying zero terminated strings in the data*/ - /* so we can just pass the pointers, and not recopy anything */ - - Menu_item menu_item; - Menu submenu; - Lisp_Object String; - Lisp_Object Value; - - CHECK_LIST_CONS (Pair, Pair); - String = Fcar(Pair); - CHECK_STRING(String); - Value = Fcdr(Pair); - if (SYMBOLP (Value)) - Value = SYMBOL_VALUE (Value); - if (VECTORP (Value)) { - submenu = sun_menu_create (Value); - menu_item = menu_create_item - (MENU_RELEASE, MENU_PULLRIGHT_ITEM, SDATA (String), submenu, 0); - } else { - menu_item = menu_create_item - (MENU_RELEASE, MENU_STRING_ITEM, SDATA (String), Value, 0); - } - return menu_item; -} - -Menu -sun_menu_create (Vector) - Lisp_Object Vector; -{ - Menu menu; - int i; - CHECK_VECTOR(Vector); - menu=menu_create(0); - for(i = 0; i < XVECTOR(Vector)->size; i++) { - menu_set (menu, MENU_APPEND_ITEM, - sun_item_create(XVECTOR(Vector)->contents[i]), 0); - } - return menu; -} - -/* - * If the first item of the menu has nil as its value, then make the - * item look like a label by inverting it and making it unselectable. - * Returns 1 if the label was made, 0 otherwise. - */ -int -make_menu_label (menu) - Menu menu; -{ - int made_label_p = 0; - - if (( menu_get(menu, MENU_NITEMS) > 0 ) && /* At least one item */ - ((Lisp_Object) menu_get(menu_get(menu, MENU_NTH_ITEM, 1), - MENU_VALUE) == Qnil )) { - menu_set(menu_get(menu, MENU_NTH_ITEM, 1), - MENU_INVERT, TRUE, - MENU_FEEDBACK, FALSE, - 0); - made_label_p = 1; - } - return made_label_p; -} - -/* - * Do a pop-up menu and return the selected value - */ -DEFUN ("sun-menu-internal", - Fsun_menu_internal, - Ssun_menu_internal, 5, 5, 0, - doc: /* Set up a SunView pop-up menu and return the user's choice. -Arguments WINDOW, X, Y, BUTTON, and MENU. -*** User code should generally use sun-menu-evaluate *** - -Arguments WINDOW, X, Y, BUTTON, and MENU. -Put MENU up in WINDOW at position X, Y. -The BUTTON argument specifies the button to be released that selects an item: - 1 = LEFT BUTTON - 2 = MIDDLE BUTTON - 4 = RIGHT BUTTON -The MENU argument is a vector containing (STRING . VALUE) pairs. -The VALUE of the selected item is returned. -If the VALUE of the first pair is nil, then the first STRING will be used -as a menu label. */) - (window, X_Position, Y_Position, Button, MEnu) - Lisp_Object window, X_Position, Y_Position, Button, MEnu; -{ - Menu menu; - int button, xpos, ypos; - Event event0; - Event *event = &event0; - Lisp_Object Value, Pair; - - CHECK_NUMBER(X_Position); - CHECK_NUMBER(Y_Position); - CHECK_LIVE_WINDOW(window); - CHECK_NUMBER(Button); - CHECK_VECTOR(MEnu); - - CHECK_GFX (Qnil); - - xpos = CtoSX (WINDOW_LEFT_EDGE_COL (XWINDOW (window)) - + WINDOW_LEFT_SCROLL_BAR_COLS (XWINDOW (window)) - + XINT(X_Position)); - ypos = CtoSY (WINDOW_TOP_EDGE_LINE (XWINDOW(window)) + XINT(Y_Position)); -#ifdef Menu_Base_Kludge - {static Lisp_Object symbol[2]; - symbol[0] = Fintern (sm_kludge_string, Qnil); - Pair = Ffuncall (1, symbol); - xpos += XINT (XCDR (Pair)); - ypos += XINT (XCAR (Pair)); - } -#endif - - button = XINT(Button); - if(button == 4) button = 3; - event_set_id (event, BUT(button)); - event_set_down (event); - event_set_x (event, xpos); - event_set_y (event, ypos); - - menu = sun_menu_create(MEnu); - make_menu_label(menu); - -#ifdef Menu_Base_Kludge - Value = (Lisp_Object) menu_show(menu, Menu_Base_Frame, event, 0); -#else -/* This confuses the notifier or something: */ - Value = (Lisp_Object) menu_show_using_fd(menu, win_fd, event, 0); -/* - * Right button gets lost, and event sequencing or delivery gets mixed up - * So, until that gets fixed, we use this <Menu_Base_Frame> kludge: - */ -#endif - menu_destroy (menu); - - return ((int)Value ? Value : Qnil); -} - - -/* - * Define everything - */ -syms_of_sunfns() -{ -#ifdef Menu_Base_Kludge - /* i'm just too lazy to re-write this into C code */ - /* so we will call this elisp function from C */ - sm_kludge_string = make_pure_string ("sm::menu-kludge", 15, 15, 0); -#endif /* Menu_Base_Kludge */ - - defsubr(&Ssun_window_init); - defsubr(&Ssit_for_millisecs); - defsubr(&Ssleep_for_millisecs); - defsubr(&Supdate_display); - defsubr(&Ssun_change_cursor_icon); - defsubr(&Ssun_set_selection); - defsubr(&Ssun_get_selection); - defsubr(&Ssun_menu_internal); -} - -/* arch-tag: 2d7decb7-58f6-41aa-b45b-077ccfab7158 - (do not change this comment) */ |