From: CSRG Date: Wed, 9 Jan 1991 06:56:11 +0000 (-0800) Subject: BSD 4_4_Lite1 development X-Git-Tag: BSD-4_4_Lite2^2~2741 X-Git-Url: https://git.subgeniuskitty.com/unix-history/.git/commitdiff_plain/d136ee8aa0356fb29b331ec3f7b98a57d4ba9fe4 BSD 4_4_Lite1 development Work on file usr/src/contrib/emacs-18.57/lisp/add-log.el Work on file usr/src/contrib/emacs-18.57/lisp/autoinsert.el Work on file usr/src/contrib/emacs-18.57/lisp/backquote.el Work on file usr/src/contrib/emacs-18.57/lisp/bg-mouse.el Synthesized-from: CSRG/cd2/4.4BSD-Lite1 --- diff --git a/usr/src/contrib/emacs-18.57/lisp/add-log.el b/usr/src/contrib/emacs-18.57/lisp/add-log.el new file mode 100644 index 0000000000..68181ac274 --- /dev/null +++ b/usr/src/contrib/emacs-18.57/lisp/add-log.el @@ -0,0 +1,84 @@ +;; Change log maintenance commands for Emacs +;; Copyright (C) 1985 Free Software Foundation, Inc. + +;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA. + + +(defun add-change-log-entry (whoami file-name &optional other-window) + "Find change log file and add an entry for today. +First arg (interactive prefix) non-nil means prompt for user name and site. +Second arg is file name of change log. +Optional third arg OTHER-WINDOW non-nil means visit in other window." + (interactive + (list current-prefix-arg + (let ((default + (if (eq system-type 'vax-vms) "$CHANGE_LOG$.TXT" "ChangeLog"))) + (expand-file-name + (read-file-name (format "Log file (default %s): " default) + nil default))))) + (let* ((default + (if (eq system-type 'vax-vms) "$CHANGE_LOG$.TXT" "ChangeLog")) + (full-name (if whoami + (read-input "Full name: " (user-full-name)) + (user-full-name))) + ;; Note that some sites have room and phone number fields in + ;; full name which look silly when inserted. Rather than do + ;; anything about that here, let user give prefix argument so that + ;; s/he can edit the full name field in prompter if s/he wants. + (login-name (if whoami + (read-input "Login name: " (user-login-name)) + (user-login-name))) + (site-name (if whoami + (read-input "Site name: " (system-name)) + (system-name)))) + (if (file-directory-p file-name) + (setq file-name (concat (file-name-as-directory file-name) + default))) + (if other-window (find-file-other-window file-name) (find-file file-name)) + (or (eq major-mode 'indented-text-mode) + (progn + (indented-text-mode) + (setq left-margin 8) + (setq fill-column 74))) + (auto-fill-mode 1) + (undo-boundary) + (goto-char (point-min)) + (if (not (and (looking-at (substring (current-time-string) 0 10)) + (save-excursion (re-search-forward "(.* at") + (skip-chars-backward "^(") + (looking-at login-name)))) + (progn (insert (current-time-string) + " " full-name + " (" login-name + " at " site-name ")\n\n"))) + (goto-char (point-min)) + (forward-line 1) + (while (looking-at "\\sW") + (forward-line 1)) + (delete-region (point) + (progn + (skip-chars-backward "\n") + (point))) + (open-line 3) + (forward-line 2) + (indent-to left-margin) + (insert "* "))) + +(defun add-change-log-entry-other-window () + "Find change log file in other window, and add an entry for today." + (interactive) + (add-change-log-entry nil default-directory t)) diff --git a/usr/src/contrib/emacs-18.57/lisp/autoinsert.el b/usr/src/contrib/emacs-18.57/lisp/autoinsert.el new file mode 100644 index 0000000000..a185cc077a --- /dev/null +++ b/usr/src/contrib/emacs-18.57/lisp/autoinsert.el @@ -0,0 +1,90 @@ +;; Automatic mode-dependent insertion of text into new files. +;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc. + +;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; autoinsert.el + +;;; Abstract: +;;; +;;; The following defines an association list for files to be +;;; automatically inserted when a new file is created, and a function +;;; which automatically inserts these files; the idea is to insert +;;; default files much as the mode is automatically set using +;;; auto-mode-alist. +;;; +;;; The auto-insert-alist consists of dotted pairs of +;;; ( REGEXP . FILENAME ) where REGEXP is a regular expression, and +;;; FILENAME is the file name of a file which is to be inserted into +;;; all new files matching the regular expression with which it is +;;; paired. +;;; +;;; To use: +;;; load autoinsert.el +;;; setq auto-insert-directory to an appropriate value, which +;;; must end in "/" +;;; +;;; Author: Charlie Martin +;;; Department of Computer Science and +;;; National Biomedical Simulation Resource +;;; Box 3709 +;;; Duke University Medical Center +;;; Durham, NC 27710 +;;; (crm@cs.duke.edu,mcnc!duke!crm) +;;; +;;; Date: Fri Jul 1 16:15:31 EDT 1988 + +(defvar auto-insert-alist '(("\\.tex$" . "tex-insert.tex") + ("\\.c$" . "c-insert.c") + ("\\.h$" . "h-insert.c") + ("[Mm]akefile" . "makefile.inc") + ("\\.bib$" . "tex-insert.tex")) + "Alist specifying text to insert by default into a new file. +Elements look like (REGEXP . FILENAME); if the new file's name +matches REGEXP, then the file FILENAME is inserted into the buffer. +Only the first matching element is effective.") + +;;; Establish a default value for auto-insert-directory +(defvar auto-insert-directory "~/insert/" + "Directory from which auto-inserted files are taken.") + +(defun insert-auto-insert-files () + "Insert default contents into a new file. +Matches the visited file name against the elements of `auto-insert-alist'." + (let ((alist auto-insert-alist) + ;; remove backup suffixes from file name + (name (file-name-sans-versions buffer-file-name)) + (insert-file nil)) + + ;; find first matching alist entry + (while (and (not insert-file) alist) + (if (string-match (car (car alist)) name) + (setq insert-file (cdr (car alist))) + (setq alist (cdr alist)))) + + ;; Now, if we found an appropriate insert file, insert it + (if insert-file + (let ((file (concat auto-insert-directory insert-file))) + (if (file-readable-p file) + (insert-file-contents file) + (message "Auto-insert: file %s not found" file) + (sleep-for 1)))))) + +;; Make this feature take effect when a nonexistent file is visited. +(setq find-file-not-found-hooks + (cons 'insert-auto-insert-files + find-file-not-found-hooks)) diff --git a/usr/src/contrib/emacs-18.57/lisp/backquote.el b/usr/src/contrib/emacs-18.57/lisp/backquote.el new file mode 100644 index 0000000000..fa979a5407 --- /dev/null +++ b/usr/src/contrib/emacs-18.57/lisp/backquote.el @@ -0,0 +1,322 @@ +;; Copyright (C) 1985 Free Software Foundation, Inc. +;; Written by Dick King (king@kestrel). + +;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA. + + +;;; This is a rudimentry backquote package written by D. King, + ;;; king@kestrel, on 8/31/85. (` x) is a macro + ;;; that expands to a form that produces x. (` (a b ..)) is + ;;; a macro that expands into a form that produces a list of what a b + ;;; etc. would have produced. Any element can be of the form + ;;; (,
) in which case the resulting form evaluates + ;;; before putting it into place, or (,@ ), in which + ;;; case the evaluation of is arranged for and each element + ;;; of the result (which must be a (possibly null) list) is inserted. +;;; As an example, the immediately following macro push (v l) could + ;;; have been written +;;; (defmacro push (v l) +;;; (` (setq (, l) (cons (,@ (list v l)))))) + ;;; although +;;; (defmacro push (v l) +;;; (` (setq (, l) (cons (, v) (, l))))) + ;;; is far more natural. The magic atoms , + ;;; and ,@ are user-settable and list-valued. We recommend that + ;;; things never be removed from this list lest you break something + ;;; someone else wrote in the dim past that comes to be recompiled in + ;;; the distant future. + +;;; LIMITATIONS: tail consing is not handled correctly. Do not say + ;;; (` (a . (, b))) - say (` (a (,@ b))) + ;;; which works even if b is not list-valued. +;;; No attempt is made to handle vectors. (` [a (, b) c]) doesn't work. +;;; Sorry, you must say things like + ;;; (` (a (,@ 'b))) to get (a . b) and + ;;; (` ((, ',) c)) to get (, c) - [(` (a , b)) will work but is a bad habit] +;;; I haven't taught it the joys of nconc. +;;; (` atom) dies. (` (, atom)) or anything else is okay. + +;;; BEWARE BEWARE BEWARE + ;;; inclusion of (,atom) rather than (, atom) or (,@atom) rather than + ;;; (,@ atom) will result in errors that will show up very late. + ;;; This is so crunchy that I am considering including a check for + ;;; this or changing the syntax to ... ,(). RMS: opinion? + + +(provide 'backquote) + +;;; a raft of general-purpose macros follows. See the nearest + ;;; Commonlisp manual. +(defmacro bq-push (v l) + "Pushes evaluated first form onto second unevaluated object +a list-value atom" + (list 'setq l (list 'cons v l))) + +(defmacro bq-caar (l) + (list 'car (list 'car l))) + +(defmacro bq-cadr (l) + (list 'car (list 'cdr l))) + +(defmacro bq-cdar (l) + (list 'cdr (list 'car l))) + + +;;; These two advertised variables control what characters are used to + ;;; unquote things. I have included , and ,@ as the unquote and + ;;; splice operators, respectively, to give users of MIT CADR machine + ;;; derivitive machines a warm, cosy feeling. + +(defconst backquote-unquote '(,) + "*A list of all objects that stimulate unquoting in `. Memq test.") + + +(defconst backquote-splice '(,@) + "*A list of all objects that stimulate splicing in `. Memq test.") + + +;;; This is the interface +(defmacro ` (form) + "(` FORM) Expands to a form that will generate FORM. +FORM is `almost quoted' -- see backquote.el for a description." + (bq-make-maker form)) + +;;; We develop the method for building the desired list from + ;;; the end towards the beginning. The contract is that there be a + ;;; variable called state and a list called tailmaker, and that the form + ;;; (cons state tailmaker) deliver the goods. Exception - if the + ;;; state is quote the tailmaker is the form itself. +;;; This function takes a form and returns what I will call a maker in + ;;; what follows. Evaluating the maker would produce the form, + ;;; properly evaluated according to , and ,@ rules. +;;; I work backwards - it seemed a lot easier. The reason for this is + ;;; if I'm in some sort of a routine building a maker and I switch + ;;; gears, it seemed to me easier to jump into some other state and + ;;; glue what I've already done to the end, than to to prepare that + ;;; something and go back to put things together. +(defun bq-make-maker (form) + "Given one argument, a `mostly quoted' object, produces a maker. +See backquote.el for details" + (let ((tailmaker (quote nil)) (qc 0) (ec 0) (state nil)) + (mapcar 'bq-iterative-list-builder (reverse form)) + (and state + (cond ((eq state 'quote) + (list state tailmaker)) + ((= (length tailmaker) 1) + (funcall (bq-cadr (assq state bq-singles)) tailmaker)) + (t (cons state tailmaker)))))) + +;;; There are exceptions - we wouldn't want to call append of one + ;;; argument, for example. +(defconst bq-singles '((quote bq-quotecar) + (append car) + (list bq-make-list) + (cons bq-id))) + +(defun bq-id (x) x) + +(defun bq-quotecar (x) (list 'quote (car x))) + +(defun bq-make-list (x) (cons 'list x)) + +;;; fr debugging use only +;(defun funcalll (a b) (funcall a b)) +;(defun funcalll (a b) (debug nil 'enter state tailmaker a b) +; (let ((ans (funcall a b))) (debug nil 'leave state tailmaker) +; ans)) + +;;; Given a state/tailmaker pair that already knows how to make a + ;;; partial tail of the desired form, this function knows how to add + ;;; yet another element to the burgening list. There are four cases; + ;;; the next item is an atom (which will certainly be quoted); a + ;;; (, xxx), which will be evaluated and put into the list at the top + ;;; level; a (,@ xxx), which will be evaluated and spliced in, or + ;;; some other list, in which case we first compute the form's maker, + ;;; and then we either launch into the quoted case if the maker's + ;;; top level function is quote, or into the comma case if it isn't. +;;; The fourth case reduces to one of the other three, so here we have + ;;; a choice of three ways to build tailmaker, and cit turns out we + ;;; use five possible values of state (although someday I'll add + ;;; nconcto the possible values of state). +;;; This maintains the invariant that (cons state tailmaker) is the + ;;; maker for the elements of the tail we've eaten so far. +(defun bq-iterative-list-builder (form) + "Called by bq-make-maker. Adds a new item form to tailmaker, +changing state if need be, so tailmaker and state constitute a recipie +for making the list so far." + (cond ((atom form) + (funcall (bq-cadr (assq state bq-quotefns)) form)) + ((memq (car form) backquote-unquote) + (funcall (bq-cadr (assq state bq-evalfns)) (bq-cadr form))) + ((memq (car form) backquote-splice) + (funcall (bq-cadr (assq state bq-splicefns)) (bq-cadr form))) + (t + (let ((newform (bq-make-maker form))) + (if (and (listp newform) (eq (car newform) 'quote)) + (funcall (bq-cadr (assq state bq-quotefns)) (bq-cadr newform)) + (funcall (bq-cadr (assq state bq-evalfns)) newform)))) + )) + +;;; We do a 2-d branch on the form of splicing and the old state. + ;;; Here's fifteen functions' names... +(defconst bq-splicefns '((nil bq-splicenil) + (append bq-spliceappend) + (list bq-splicelist) + (quote bq-splicequote) + (cons bq-splicecons))) + +(defconst bq-evalfns '((nil bq-evalnil) + (append bq-evalappend) + (list bq-evallist) + (quote bq-evalquote) + (cons bq-evalcons))) + +(defconst bq-quotefns '((nil bq-quotenil) + (append bq-quoteappend) + (list bq-quotelist) + (quote bq-quotequote) + (cons bq-quotecons))) + +;;; The name of each function is + ;;; (concat 'bq- ) +;;; I'll comment the non-obvious ones before the definitions... + ;;; In what follows, uppercase letters and form will always be + ;;; metavariables that don't need commas in backquotes, and I will + ;;; assume the existence of something like matches that takes a + ;;; backquote-like form and a value, binds metavariables and returns + ;;; t if the pattern match is successful, returns nil otherwise. I + ;;; will write such a goodie someday. + +;;; (setq tailmaker + ;;; (if (matches ((quote X) Y) tailmaker) + ;;; (` ((quote (form X)) Y)) + ;;; (` ((list form (quote X)) Y)))) + ;;; (setq state 'append) +(defun bq-quotecons (form) + (if (and (listp (car tailmaker)) + (eq (bq-caar tailmaker) 'quote)) + (setq tailmaker + (list (list 'quote (list form (bq-cadr (car tailmaker)))) + (bq-cadr tailmaker))) + (setq tailmaker + (list (list 'list + (list 'quote form) + (car tailmaker)) + (bq-cadr tailmaker)))) + (setq state 'append)) + +(defun bq-quotequote (form) + (bq-push form tailmaker)) + +;;; Could be improved to convert (list 'a 'b 'c .. 'w x) + ;;; to (append '(a b c .. w) x) + ;;; when there are enough elements +(defun bq-quotelist (form) + (bq-push (list 'quote form) tailmaker)) + +;;; (setq tailmaker + ;;; (if (matches ((quote X) (,@ Y))) + ;;; (` ((quote (, (cons form X))) (,@ Y))))) +(defun bq-quoteappend (form) + (cond ((and (listp tailmaker) + (listp (car tailmaker)) + (eq (bq-caar tailmaker) 'quote)) + (rplaca (bq-cdar tailmaker) + (cons form (car (bq-cdar tailmaker))))) + (t (bq-push (list 'quote (list form)) tailmaker)))) + +(defun bq-quotenil (form) + (setq tailmaker (list form)) + (setq state 'quote)) + +;;; (if (matches (X Y) tailmaker) ; it must + ;;; (` ((list form X) Y))) +(defun bq-evalcons (form) + (setq tailmaker + (list (list 'list form (car tailmaker)) + (bq-cadr tailmaker))) + (setq state 'append)) + +;;; (if (matches (X Y Z (,@ W))) + ;;; (progn (setq state 'append) + ;;; (` ((list form) (quote (X Y Z (,@ W)))))) + ;;; (progn (setq state 'list) + ;;; (list form 'X 'Y .. ))) ; quote each one there is +(defun bq-evalquote (form) + (cond ((< (length tailmaker) 3) + (setq tailmaker + (cons form + (mapcar (function (lambda (x) + (list 'quote x))) + tailmaker))) + (setq state 'list)) + (t + (setq tailmaker + (list (list 'list form) + (list 'quote tailmaker))) + (setq state 'append)))) + +(defun bq-evallist (form) + (bq-push form tailmaker)) + +;;; (cond ((matches ((list (,@ X)) (,@ Y))) + ;;; (` ((list form (,@ X)) (,@ Y)))) + ;;; ((matches (X)) + ;;; (` (form (,@ X))) (setq state 'cons)) + ;;; ((matches ((,@ X))) + ;;; (` (form (,@ X))))) +(defun bq-evalappend (form) + (cond ((and (listp tailmaker) + (listp (car tailmaker)) + (eq (bq-caar tailmaker) 'list)) + (rplacd (car tailmaker) + (cons form (bq-cdar tailmaker)))) + ((= (length tailmaker) 1) + (setq tailmaker (cons form tailmaker)) + (setq state 'cons)) + (t (bq-push (list 'list form) tailmaker)))) + +(defun bq-evalnil (form) + (setq tailmaker (list form)) + (setq state 'list)) + +;;; (if (matches (X Y)) ; it must + ;;; (progn (setq state 'append) + ;;; (` (form (cons X Y))))) ; couldn't think of anything clever +(defun bq-splicecons (form) + (setq tailmaker + (list form + (list 'cons (car tailmaker) (bq-cadr tailmaker)))) + (setq state 'append)) + +(defun bq-splicequote (form) + (setq tailmaker (list form (list 'quote (list tailmaker)))) + (setq state 'append)) + +(defun bq-splicelist (form) + (setq tailmaker (list form (cons 'list tailmaker))) + (setq state 'append)) + +(defun bq-spliceappend (form) + (bq-push form tailmaker)) + +(defun bq-splicenil (form) + (setq state 'append) + (setq tailmaker (list form))) + + + diff --git a/usr/src/contrib/emacs-18.57/lisp/bg-mouse.el b/usr/src/contrib/emacs-18.57/lisp/bg-mouse.el new file mode 100644 index 0000000000..fef1b2d56f --- /dev/null +++ b/usr/src/contrib/emacs-18.57/lisp/bg-mouse.el @@ -0,0 +1,305 @@ +;; GNU Emacs code for BBN Bitgraph mouse. +;; Copyright (C) Free Software Foundation, Inc. Oct 1985. +;; Time stamp <89/03/21 14:27:08 gildea> + +;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA. + + +;;; Original version by John Robinson (jr@bbn-unix.arpa, bbncca!jr), Oct 1985 +;;; Modularized and enhanced by gildea@bbn.com Nov 1987 + +(provide 'bg-mouse) + +;;; User customization option: + +(defvar bg-mouse-fast-select-window nil + "*Non-nil for mouse hits to select new window, then execute; else just select.") + +;;; These numbers are summed to make the index into the mouse-map. +;;; The low three bits correspond to what the mouse actually sends. +(defconst bg-button-r 1) +(defconst bg-button-m 2) +(defconst bg-button-c 2) +(defconst bg-button-l 4) +(defconst bg-in-modeline 8) +(defconst bg-in-scrollbar 16) +(defconst bg-in-minibuf 24) + +;;; semicolon screws up indenting, so use this instead +(defconst semicolon ?\;) + +;;; Defuns: + +(defun bg-mouse-report (prefix-arg) + "Read, parse, and execute a BBN BitGraph mouse click. + +L-- move point | These apply for mouse click in a window. +--R set mark | If bg-mouse-fast-select-window is nil, +L-R kill region | these commands on a nonselected window +-C- move point and yank | just select that window. +LC- yank-pop | +-CR or LCR undo | \"Scroll bar\" is right-hand window column. + +on modeline: on \"scroll bar\": in minibuffer: +L-- scroll-up line to top execute-extended-command +--R scroll-down line to bottom eval-expression +-C- proportional goto-char line to middle suspend-emacs + +To reinitialize the mouse if the terminal is reset, type ESC : RET" + (interactive "P") + (bg-get-tty-num semicolon) + (let* + ((screen-mouse-x (min (1- (screen-width)) ;don't hit column 86! + (/ (bg-get-tty-num semicolon) 9))) + (screen-mouse-y (- (1- (screen-height)) ;assume default font size. + (/ (bg-get-tty-num semicolon) 16))) + (bg-mouse-buttons (% (bg-get-tty-num ?c) 8)) + (bg-mouse-window (bg-window-from-x-y screen-mouse-x screen-mouse-y)) + (bg-cursor-window (selected-window)) + (edges (window-edges bg-mouse-window)) + (minibuf-p (= screen-mouse-y (1- (screen-height)))) + (in-modeline-p (and (not minibuf-p) + (= screen-mouse-y (1- (nth 3 edges))))) + (in-scrollbar-p (and (not minibuf-p) (not in-modeline-p) + (>= screen-mouse-x (1- (nth 2 edges))))) + (same-window-p (eq bg-mouse-window bg-cursor-window)) + (in-minibuf-p (and minibuf-p + (not bg-mouse-window))) ;minibuf must be inactive + (bg-mode-bits (+ (if in-minibuf-p bg-in-minibuf 0) + (if in-modeline-p bg-in-modeline 0) + (if in-scrollbar-p bg-in-scrollbar 0))) + (bg-command + (lookup-key mouse-map + (char-to-string (+ bg-mode-bits bg-mouse-buttons)))) + (bg-mouse-x (- screen-mouse-x (nth 0 edges))) + (bg-mouse-y (- screen-mouse-y (nth 1 edges)))) + (cond ((or in-modeline-p in-scrollbar-p) + (select-window bg-mouse-window) + (bg-command-execute bg-command) + (select-window bg-cursor-window)) + ((or same-window-p in-minibuf-p) + (bg-command-execute bg-command)) + (t ;in another window + (select-window bg-mouse-window) + (if bg-mouse-fast-select-window + (bg-command-execute bg-command))) + ))) + + +;;; Library of commands: + +(defun bg-set-point () + "Move point to location of BitGraph mouse." + (interactive) + (bg-move-point-to-x-y bg-mouse-x bg-mouse-y) + (setq this-command 'next-line) ;make subsequent line moves work + (setq temporary-goal-column bg-mouse-x)) + +(defun bg-set-mark () + "Set mark at location of BitGraph mouse." + (interactive) + (push-mark) + (bg-move-point-to-x-y bg-mouse-x bg-mouse-y) + (exchange-point-and-mark)) + +(defun bg-yank () + "Move point to location of BitGraph mouse and yank." + (interactive "*") + (bg-move-point-to-x-y bg-mouse-x bg-mouse-y) + (setq this-command 'yank) + (yank)) + +(defun yank-pop-1 () + (interactive "*") + (yank-pop 1)) + +(defun bg-yank-or-pop () + "Move point to location of BitGraph mouse and yank or yank-pop. +Do a yank unless last command was a yank, in which case do a yank-pop." + (interactive "*") + (if (eql last-command 'yank) + (yank-pop 1) + (bg-yank))) + +;;; In 18.51, Emacs Lisp doesn't provide most-positive-fixnum +(defconst bg-most-positive-fixnum 8388607) + +(defun bg-move-by-percentage () + "Go to location in buffer that is the same percentage of the +way through the buffer as the BitGraph mouse's X position in the window." + (interactive) + ;; check carefully for overflow in intermediate calculations + (goto-char + (cond ((zerop bg-mouse-x) + 0) + ((< (buffer-size) (/ bg-most-positive-fixnum bg-mouse-x)) + ;; no danger of overflow: compute it exactly + (/ (* bg-mouse-x (buffer-size)) + (1- (window-width)))) + (t + ;; overflow possible: approximate + (* (/ (buffer-size) (1- (window-width))) + bg-mouse-x)))) + (beginning-of-line) + (what-cursor-position)) + +(defun bg-mouse-line-to-top () + "Scroll the line pointed to by the BitGraph mouse to the top of the window." + (interactive) + (scroll-up bg-mouse-y)) + +(defun bg-mouse-line-to-center () + "Scroll the line pointed to by the BitGraph mouse to the center +of the window" + (interactive) + (scroll-up (/ (+ 2 bg-mouse-y bg-mouse-y (- (window-height))) 2))) + +(defun bg-mouse-line-to-bottom () + "Scroll the line pointed to by the mouse to the bottom of the window." + (interactive) + (scroll-up (+ bg-mouse-y (- 2 (window-height))))) + +(defun bg-kill-region () + (interactive "*") + (kill-region (region-beginning) (region-end))) + +(defun bg-insert-moused-sexp () + "Insert a copy of the word (actually sexp) that the mouse is pointing at. +Sexp is inserted into the buffer at point (where the text cursor is). +By gildea 7 Feb 89" + (interactive) + (let ((moused-text + (save-excursion + (bg-move-point-to-x-y bg-mouse-x bg-mouse-y) + (if (looking-at "\\s)") + (forward-char 1) + (forward-sexp 1)) + (buffer-substring (save-excursion (backward-sexp 1) (point)) + (point))))) + (select-window bg-cursor-window) + (delete-horizontal-space) + (cond + ((bolp) + (indent-according-to-mode)) + ;; In Lisp assume double-quote is closing; in Text assume opening. + ;; Why? Because it does the right thing most often. + ((save-excursion (forward-char -1) + (and (not (looking-at "\\s\"")) + (looking-at "[`'\"\\]\\|\\s("))) + nil) + (t + (insert-string " "))) + (insert-string moused-text) + (or (eolp) + (looking-at "\\s.\\|\\s)") + (and (looking-at "'") (looking-at "\\sw")) ;hack for text mode + (save-excursion (insert-string " "))))) + +;;; Utility functions: + +(defun bg-get-tty-num (term-char) + "Read from terminal until TERM-CHAR is read, and return intervening number. +If non-numeric not matching TERM-CHAR, reprogram the mouse and signal an error." + (let + ((num 0) + (char (- (read-char) 48))) + (while (and (>= char 0) + (<= char 9)) + (setq num (+ (* num 10) char)) + (setq char (- (read-char) 48))) + (or (eq term-char (+ char 48)) + (progn + (bg-program-mouse) + (error + "Invalid data format in bg-mouse command: mouse reinitialized."))) + num)) + +;;; Note that this fails in the minibuf because move-to-column doesn't +;;; allow for the width of the prompt. +(defun bg-move-point-to-x-y (x y) + "Position cursor in window coordinates. +X and Y are 0-based character positions in the window." + (move-to-window-line y) + ;; if not on a wrapped line, zero-column will be 0 + (let ((zero-column (current-column)) + (scroll-offset (window-hscroll))) + ;; scrolling takes up column 0 to display the $ + (if (> scroll-offset 0) + (setq scroll-offset (1- scroll-offset))) + (move-to-column (+ zero-column scroll-offset x)) + )) + +;;; Returns the window that screen position (x, y) is in or nil if none, +;;; meaning we are in the echo area with a non-active minibuffer. +;;; If coordinates-in-window-p were not in an X-windows-specific file +;;; we could use that. In Emacs 19 can even use locate-window-from-coordinates +(defun bg-window-from-x-y (x y) + "Find window corresponding to screen coordinates. +X and Y are 0-based character positions on the screen." + (let ((edges (window-edges)) + (window nil)) + (while (and (not (eq window (selected-window))) + (or (< y (nth 1 edges)) + (>= y (nth 3 edges)) + (< x (nth 0 edges)) + (>= x (nth 2 edges)))) + (setq window (next-window window)) + (setq edges (window-edges window))) + (cond ((eq window (selected-window)) + nil) ;we've looped: not found + ((not window) + (selected-window)) ;just starting: current window + (t + window)) + )) + +(defun bg-command-execute (bg-command) + (if (commandp bg-command) + (command-execute bg-command) + (ding))) + +(defun bg-program-mouse () + (send-string-to-terminal "\e:0;7;;;360;512;9;16;9;16c")) + +;;; Note that the doc string for mouse-map (as defined in subr.el) +;;; says it is for the X-window mouse. This is wrong; that keymap +;;; should be used for your mouse no matter what terminal you have. + +(or (keymapp mouse-map) + (setq mouse-map (make-keymap))) + +(defun bind-bg-mouse-click (click-code function) + "Bind bg-mouse CLICK-CODE to run FUNCTION." + (define-key mouse-map (char-to-string click-code) function)) + +(bind-bg-mouse-click bg-button-l 'bg-set-point) +(bind-bg-mouse-click bg-button-m 'bg-yank) +(bind-bg-mouse-click bg-button-r 'bg-set-mark) +(bind-bg-mouse-click (+ bg-button-l bg-button-m) 'yank-pop-1) +(bind-bg-mouse-click (+ bg-button-l bg-button-r) 'bg-kill-region) +(bind-bg-mouse-click (+ bg-button-m bg-button-r) 'undo) +(bind-bg-mouse-click (+ bg-button-l bg-button-m bg-button-r) 'undo) +(bind-bg-mouse-click (+ bg-in-modeline bg-button-l) 'scroll-up) +(bind-bg-mouse-click (+ bg-in-modeline bg-button-m) 'bg-move-by-percentage) +(bind-bg-mouse-click (+ bg-in-modeline bg-button-r) 'scroll-down) +(bind-bg-mouse-click (+ bg-in-scrollbar bg-button-l) 'bg-mouse-line-to-top) +(bind-bg-mouse-click (+ bg-in-scrollbar bg-button-m) 'bg-mouse-line-to-center) +(bind-bg-mouse-click (+ bg-in-scrollbar bg-button-r) 'bg-mouse-line-to-bottom) +(bind-bg-mouse-click (+ bg-in-minibuf bg-button-l) 'execute-extended-command) +(bind-bg-mouse-click (+ bg-in-minibuf bg-button-m) 'suspend-emacs) +(bind-bg-mouse-click (+ bg-in-minibuf bg-button-r) 'eval-expression) +