pcs/edwin/allcoms1.scm

;;;
;;;     Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;;     This material was developed by the Scheme project at the
;;;     Massachusetts Institute of Technology, Department of
;;;     Electrical Engineering and Computer Science.  Permission to
;;;     copy this software, to redistribute it, and to use it for any
;;;     purpose is granted, subject to the following restrictions and
;;;     understandings.
;;;
;;;     1. Any copy made of this software must include this copyright
;;;     notice in full.
;;;
;;;     2. Users of this software agree to make their best efforts (a)
;;;     to return to the MIT Scheme project any improvements or
;;;     extensions that they make, so that these may be included in
;;;     future releases; and (b) to inform MIT of noteworthy uses of
;;;     this software.
;;;
;;;     3.  All materials developed as a consequence of the use of
;;;     this software shall duly acknowledge such use, in accordance
;;;     with the usual standards of acknowledging credit in academic
;;;     research.
;;;
;;;     4. MIT has made no warrantee or representation that the
;;;     operation of this software will be error-free, and MIT is
;;;     under no obligation to provide any services, by way of
;;;     maintenance, update, or otherwise.
;;;
;;;     5.  In conjunction with products arising from the use of this
;;;     material, there shall be no use of the name of the
;;;     Massachusetts Institute of Technology nor of any adaptation
;;;     thereof in any advertising, promotional, or sales literature
;;;     without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;     Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;; This has been done to do most of the stuff at compile time rather
;;; than at load time. The commands and key definition are combined into
;;; one.
;;;
;;; The default key needs to be the first thing defined.
;;; With the current state of edwin (with the absence of extended
;;; commands) we do not need the following files comman.scm strtab.scm
;;; nvector.scm. Some of these may be needed with extended commands.
;;; All the initial commands assume that they are first ones of their
;;; name being defined. No checks are made

;;; instead of flooding the name space with all possible commands
;;; we define only those which are explicitly needed.

(define ^r-insert-self-command '())
(define ^r-argument-digit-command '())
(define ^r-forward-character-command '())
(define ^r-backward-character-command '())
(define ^r-negative-argument-command '())
(define ^r-bad-command '())
;;;

(define alt-char (integer->char 0))
(define meta-char (integer->char 27))
(define ctrl-x-char (integer->char 24))
(define ctrl-z-char (integer->char 26))

;;;

(define *split-screen-mode?* #!false)

;;;

;;;; Basic Commands

(define-initial-command-key ("^R Bad Command" argument)
  "This command is used to capture undefined keys."
(
(define-initial-default-key  procedure)
(set! ^r-bad-command procedure)
)
  (editor-error (string-append "Undefined command: "
                                (obj->string (current-command-char)))))

(define-initial-command-key ("^R Insert Self" (argument 1))
  "Insert the character used to invoke this."
(
(define add-insert-self
  (lambda (lower upper)
    ((rec loop
       (lambda (n)
         (if (> n upper)
             #!false
             (begin
               (define-initial-key (integer->char n) procedure)
               (loop (1+ n))))))
     lower)))

(add-insert-self 32 40)
(add-insert-self 42 47)
(add-insert-self 58 64)
(add-insert-self 91 127)
(add-insert-self 128 254)         ;;; add new code for internationalize
(set! ^r-insert-self-command procedure)
)
  (insert-chars (current-command-char) argument (current-point)))

(define-initial-command-key ("^R Quoted Insert" (argument 1))
  "Insert the next character typed"
  ((define-initial-key (integer->char 17) procedure))        ;;; C-Q
  (insert-chars (editor-read-char buffer-screen) argument (current-point)))

(define (insert-newlines n)
  (let ((point (current-point)))
    (cond ((= n 1) (region-insert-newline! point))
        ((> n 1) (region-insert-string! point (make-string n #\Newline))))))

(define (insert-chars char n point)
  (cond ((= n 1) (region-insert-char! point char))
        ((> n 1) (region-insert-string! point (make-string n char)))))


(define execute-extended-chars?
  #!TRUE)

(define (set-command-prompt-prefix! prefix-string)
  (set-command-prompt!
   (string-append-with-blanks (command-argument-prompt)
                            prefix-string)))

(define-initial-command-key ("^R Prefix Character" argument)
  "This is a prefix for more commands."
(
(define-initial-prefix-key  meta-char procedure)
(define-initial-prefix-key alt-char procedure)
(define-initial-prefix-key  ctrl-x-char procedure)
(define-initial-prefix-key (list meta-char alt-char) procedure)
)
  (let ((prefix-char (current-command-char)))
    (set-command-prompt-prefix!
         (string-append (char->name prefix-char) " "))
    (let ((char (editor-read-char (window-screen (current-window)))))
         (dispatch-on-char (if (atom? prefix-char)
                               (list prefix-char char)
                               (append prefix-char (list char)))))))

(define-initial-command-key ("^R Meta Character" argument)
  "This is a prefix for more commands."
(
(define-initial-prefix-key  ctrl-z-char procedure)
)
  (let ((prefix-char meta-char))
    (set-command-prompt-prefix!
         (string-append (char->name prefix-char) " "))
    (let ((char (editor-read-char (window-screen (current-window)))))
         (dispatch-on-char (list prefix-char char)))))


(define-initial-command-key ("^R Scheme" argument)
  "Stop Edwin and return to Scheme."
(
(define-initial-key  (list ctrl-x-char (integer->char 26)) procedure);;;C-X C-Z
)
  (save-buffer-changes (current-buffer))
  (edwin-exit))

(define-initial-command-key ("^R Exit" argument)
  "Stop Edwin, remove internal data structures, and return to scheme."
(
(define-initial-key (list ctrl-x-char (integer->char 3)) procedure) ;;;C-X C-C
)
  (%save-buffer-changes (current-buffer))

  ;;; the following five lines fix an error with vector index out of range
  ;;; in edwin using C-X ! to split screen, then using C-X C-C to exit edwin
  ;;; reenter edwin and try C-X ! then error occurs
  (if *split-screen-mode?*                                  ;;; 2/14/86
      (begin
         (set! *split-screen-mode?* #!false)
         (move-editor-to-full)
         (move-pcs-to-full)))

  (set! edwin-editor #!unassigned)
  (edwin-exit))

(define-initial-command-key ("^R Redraw Screen" argument)
  "Redraw the screen."
(
(define-initial-key (integer->char 12) procedure)      ;;; C-L
)
 (window-redraw! (current-window))
 (reset-modeline-window))

(define (edwin-exit)
  (restore-console-contents)
  (make-pcs-status-visible)
  (reset-typein-window)
  (gc)
  ((fluid editor-continuation) *the-non-printing-object*))


;;;; Command Argument Reader

;;;; Commands

(define-initial-command-key ("^R Universal Argument" argument)
  "Increments the argument multiplier and enters Autoarg mode."
(
(define-initial-key  (integer->char 21) procedure)      ;;; C-U
)
  (command-argument-increment-multiplier-exponent!)
  (enter-autoargument-mode!)
  (update-argument-prompt!)
  (read-and-dispatch-on-char))

(define-initial-command-key ("^R Argument Digit" argument)
  "Sets the numeric argument for the next command."
(
 (set! ^r-argument-digit-command procedure)
)
  (command-argument-accumulate-digit! (char-base (current-command-char)))
  (update-argument-prompt!)
  (read-and-dispatch-on-char))

(define-initial-command-key ("^R Negative Argument" argument)
  "Negates the numeric argument for the next command."
(
(set! ^r-negative-argument-command procedure)
)
  (command-argument-negate!)
  (update-argument-prompt!)
  (read-and-dispatch-on-char))

(define-initial-command-key ("^R Autoargument Digit" argument)
  "In Autoargument mode, sets numeric argument to the next command."
(
(define-initial-key  #\0 procedure)
(define-initial-key  #\1 procedure)
(define-initial-key  #\2 procedure)
(define-initial-key  #\3 procedure)
(define-initial-key  #\4 procedure)
(define-initial-key  #\5 procedure)
(define-initial-key  #\6 procedure)
(define-initial-key  #\7 procedure)
(define-initial-key  #\8 procedure)
(define-initial-key  #\9 procedure)
)
  ((if (autoargument-mode?)
       ^r-argument-digit-command
       ^r-insert-self-command)
   argument))

(define-initial-command-key ("^R Auto Negative Argument" argument)
  "In Autoargument mode, sets numeric sign to the next command."
(
(define-initial-key  #\- procedure)
)
  ((if (and (autoargument-mode?) (command-argument-beginning?))
       ^r-negative-argument-command
       ^r-insert-self-command)
   argument))

;;;(define-initial-command-key ("^R Autoargument" argument)
;;;  "Used to start a command argument and enter Autoargument mode."
;;;(#!false
;;;)
;;;  (%edwin-autoargument argument))

;;;; File Commands

(define-initial-command-key ("^R Visit File" argument)
  "Visit new file in selected buffer."
(
(define-initial-key  (list ctrl-x-char (integer->char 22)) procedure)
)                                                        ;;; C-X C-V
  (let ((buffer (current-buffer)))
    (let ((pathname
           (prompt-for-pathname "Visit File :")))
      (save-buffer-changes buffer)
      (read-buffer buffer pathname)))
  (setup-current-buffer-read-only! argument))

(define-initial-command-key ("^R Save File" argument)
  "Save visited file on disk if modified."
(
(define-initial-key  (list ctrl-x-char (integer->char 19)) procedure)
)                                    ;;; C-X C-S
  (save-file (current-buffer)))

(define-initial-command-key ("Write File" argument)
  "Store buffer in specified file."
(
(define-initial-key  (list ctrl-x-char (integer->char 23)) procedure)
)                                     ;;; C-X C-W
  (let ((buffer (current-buffer)))
    (write-buffer
     buffer
     (prompt-for-pathname "Write buffer to file :"))))

(define-initial-command-key ("Insert File" argument)
  "Insert contents of file into existing text."
(
(define-initial-key (list ctrl-x-char (integer->char 9)) procedure)
)                                         ;;; C-X C-I
  (let ((pathname
         (prompt-for-pathname
          "Insert File :")))
    (set-current-region! (insert-file (current-point) pathname))))

(define-initial-command-key ("Write Region" argument)
 " Write Region to a file."
(
(define-initial-key (list ctrl-x-char (integer->char 16)) procedure)
)                                         ;;; C-X C-P

 (let ((pathname (prompt-for-pathname "Put region into file :")))
   (write-region (make-region (current-point) (current-mark)) pathname)))



(define-initial-command-key ("^R Newline" argument)
  "Insert newline, or move onto blank line."
(
(define-initial-key  #\Return procedure)
)
  (cond ((not argument)
         (if (line-end? (current-point))
             (let ((m1 (line-start (current-point) 1 #!false)))
               (if (and m1 (line-blank? m1)
                        (let ((m2 (line-start m1 1 #!false)))
                          (and m2 (line-blank? m2))))
                   (begin (set-current-point! m1)
                          (delete-horizontal-space))
                   (insert-newlines 1)))
             (insert-newlines 1)))
        (else
         (insert-newlines argument))))


;;;; Motion Commands

(define-initial-command-key ("^R Beginning of Line" (argument 1))
  "Move point to beginning of line."
(
(define-initial-key  (integer->char 1) procedure)         ;;; C-A
)
  (set-current-point! (line-start (current-point) (-1+ argument) 'LIMIT)))

(define-initial-command-key ("^R Backward Character" (argument 1))
  "Move back one character."
(
(define-initial-key  (integer->char 2) procedure)                ;;; C-B
(define-initial-key (list alt-char (integer->char 75)) procedure);;; <-
(set! ^r-backward-character-command procedure)
)
  (move-thing mark- argument))

(define-initial-command-key ("^R End of Line" (argument 1))
  "Move point to end of line."
(
(define-initial-key  (integer->char 5) procedure)    ;;; C-E
)
  (set-current-point! (line-end (current-point) (-1+ argument) 'LIMIT)))

(define-initial-command-key ("^R Forward Character" (argument 1))
  "Move forward one character."
(
(define-initial-key  (integer->char 6) procedure)                 ;;; C-F
(define-initial-key (list alt-char (integer->char 77)) procedure) ;;; ->
(set! ^r-forward-character-command procedure)
)
  (move-thing mark+ argument))

(define-initial-command-key ("^R Goto Beginning" argument)
  "Go to beginning of buffer (leaving mark behind)."
(
(define-initial-key  (list meta-char #\<) procedure)  ;;; M-<
)                                                     ;;; alt is blocked
  (cond ((not argument)
         (set-current-point! (buffer-start (current-buffer))))
        ((command-argument-multiplier-only?)
         (set-current-point! (buffer-end (current-buffer))))
        ((and (<= 0 argument) (<= argument 10))
         (set-current-point! (region-10ths (buffer-region (current-buffer))
                                           argument)))))

(define-initial-command-key ("^R Goto End" argument)
  "Go to end of buffer (leaving mark behind)."
(
(define-initial-key  (list meta-char #\>) procedure) ;;; M-> alt is blocked
)
  (cond ((not argument)
         (set-current-point! (buffer-end (current-buffer))))
        ((and (<= 0 argument) (<= argument 10)
         (set-current-point! (region-10ths (buffer-region (current-buffer))
                                           (- 10 argument)))))))

(define (region-10ths region n)
  (mark+ (region-start region)
         (quotient (* n (region-count-chars region)) 10)
         #!false))


(define goal-column #!FALSE)

(define temporary-goal-column-tag
  "Temporary Goal Column")

(define (current-goal-column)
  (or goal-column
      (command-message-receive temporary-goal-column-tag
        identity-procedure
        (lambda () (mark-column (current-point))))))

;;; this is temporary as we have not put the image stuff.
;;; this redefines mark-column and make-mark-from-column in struct

(define mark-column
  (lambda (mark)
    (char->x (line-string (mark-line mark)) (mark-position mark))))

(define make-mark-from-column
  (lambda (line column)
    (let ((mark (%make-mark line (x->char (line-string line) column) #!true))
          (group (line-group line)))
      (cond ((mark< mark (%group-start group)) (%group-start group))
            ((mark> mark (%group-end group)) (%group-end group))
            (else mark)))))

(define-initial-command-key ("^R Down Real Line" (argument 1))
  "Move down vertically to next real line."
(
(define-initial-key  (integer->char 14) procedure)    ;;; C-N
(define-initial-key (list alt-char (integer->char 80)) procedure)
)
  (let ((column (current-goal-column)))
    (line-offset (mark-line (current-point))
                 argument
                 (lambda (line)
                   (set-current-point! (make-mark-from-column line column)))
                 (lambda (line)
                   (let ((buffer (current-buffer)))
                     (region-insert-newline! (buffer-end buffer))
                     (set-current-point! (buffer-end buffer)))))
    (set-command-message! temporary-goal-column-tag column)))

(define-initial-command-key ("^R Up Real Line" (argument 1))
  "Move up vertically to next real line."
(
(define-initial-key  (integer->char 16) procedure)     ;;; C-P
(define-initial-key (list alt-char (integer->char 72)) procedure)
)
  (let ((column (current-goal-column)))
    (line-offset (mark-line (current-point))
                 (- argument)
                 (lambda (line)
                   (set-current-point! (make-mark-from-column line column)))
                 (lambda (line)
                   (set-current-point! (buffer-start (current-buffer)))))
    (set-command-message! temporary-goal-column-tag column)))