1 ;;; ***********************************************************
  2 ;;; *                                                         *
  3 ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4 ;;; *                                                         *
  5 ;;; * Copyright (c) 1978 by Massachusetts Institute of        *
  6 ;;; * Technology and Honeywell Information Systems, Inc.      *
  7 ;;; *                                                         *
  8 ;;; ***********************************************************
  9 ;;;
 10 ;;; Modified: 1 July 1981 RMSoley to use Multics rubout character
 11 ;;;                 and to add overwrite-mode-off.
 12 ;;; Modified: 3 December 1983 B. Margolin to fix overwrite-mode-off
 13 ;;;           to correctly reset ^D.
 14 ;;;
 15 
 16 (%include e-macros)
 17 
 18 (declare (special MCS-editing-characters)
 19          (*expr self-insert))
 20 
 21 (defun rubout-character macro (form) '(ItoC (cadr MCS-editing-characters)))
 22 
 23 (defun overwrite-mode ()
 24        (assert-minor-mode 'overwrite)
 25        (set-key 'esc-D 'overwrite-mode-delete-word)
 26        (set-key 'esc-# 'overwrite-mode-rubout-word)
 27        (set-key 'esc-\177 'overwrite-mode-rubout-word)
 28        (set-key (rubout-character) 'overwrite-mode-rubout-char)
 29        (set-key '\177 'overwrite-mode-rubout-char)
 30        (set-key '^D 'overwrite-mode-delete-char)
 31        (map-over-emacs-commands
 32         '(lambda (sym fun arg)
 33                  (and (eq fun 'self-insert)
 34                       (set-key sym 'overwrite-mode-self-insert))
 35                  arg)
 36          nil))
 37 
 38 (defprop overwrite-off overwrite-mode-off expr)
 39 (defprop overwriteoff overwrite-mode-off expr)
 40 
 41 (defun overwrite-mode-off ()
 42        (negate-minor-mode 'overwrite)
 43        (set-key 'esc-D 'delete-word)
 44        (set-key 'esc-# 'rubout-word)
 45        (set-key 'esc-\177 'rubout-word)
 46        (set-key (rubout-character) 'rubout-char)
 47        (set-key '\177 'rubout-char)
 48        (set-key '^D 'delete-char)
 49        (map-over-emacs-commands
 50         '(lambda (sym fun arg)
 51                  (and (eq fun 'overwrite-mode-self-insert)
 52                       (set-key sym 'self-insert))
 53                  arg)
 54          nil))
 55 
 56 (defun overwrite-mode-self-insert ()
 57        (or (eolp)(delete-char))
 58        (self-insert))
 59 
 60 (defun overwrite-mode-delete-char ()
 61        (if (not (eolp))
 62            (delete-char)
 63            (insert-char " ")))
 64 
 65 ;;; old delete-char left cursor in same place, "gobbled" chars
 66 ;;;(defun overwrite-mode-delete-char ()
 67 ;;;       (if (not (eolp))
 68 ;;;        (if (at-white-char)(forward-char)
 69 ;;;          else (delete-char)
 70 ;;;               (save-excursion
 71 ;;;                (skip-to-whitespace)
 72 ;;;                (insert-string " ")))))
 73 
 74 (defun overwrite-mode-rubout-char ()
 75        (or (bolp)(progn (backward-char)
 76                         (delete-char)
 77                         (insert-char " ")
 78                         (backward-char))))
 79 
 80 (defprop overwrite-mode-delete-word forward kills)
 81 (defun overwrite-mode-delete-word ()
 82    (with-mark m
 83       (forward-word)
 84       (let ((hp (cur-hpos)))
 85            (kill-backwards-to-mark m)
 86            (spaces-to-hpos hp)))
 87    (merge-kills-forward))
 88 
 89 (defprop overwrite-mode-rubout-word reverse kills)
 90 (defun overwrite-mode-rubout-word ()
 91        (with-mark m
 92           (let ((hpos (cur-hpos)))
 93                (backward-word)
 94                (kill-forward-to-mark m)
 95                (merge-kills-reverse)
 96                (save-excursion
 97                  (spaces-to-hpos hpos)))))
 98 
 99 (defun spaces-to-hpos (x)
100        (do ((hpdiff (- x (cur-hpos)) (1- hpdiff)))
101            ((< hpdiff 1))
102            (insert-char " ")))
103 
104 (defun overwrite-mode-insert-string (string)
105        (with-mark start
106                   (let ((start-pos curpointpos))
107                        (go-to-end-of-line)
108                        (if (< (- curpointpos start-pos) (stringlength string))
109                            (kill-backwards-to-mark start)
110                            else
111                            (go-to-mark start)
112                            (do-times (stringlength string) (delete-char)))))
113        (insert-string string))