2021-04-26 07:53:20 -04:00
|
|
|
|
#| -*-Scheme-*-
|
|
|
|
|
|
|
|
|
|
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
|
|
|
|
|
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
|
|
|
|
|
2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
|
|
|
|
|
2017, 2018, 2019, 2020 Massachusetts Institute of Technology
|
|
|
|
|
|
|
|
|
|
This file is part of MIT/GNU Scheme.
|
|
|
|
|
|
|
|
|
|
MIT/GNU Scheme 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 2 of the License, or (at
|
|
|
|
|
your option) any later version.
|
|
|
|
|
|
|
|
|
|
MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
|
|
|
|
|
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
|
|
|
|
|
USA.
|
|
|
|
|
|
|
|
|
|
|#
|
|
|
|
|
|
|
|
|
|
;;;; Basic Commands
|
|
|
|
|
|
2021-04-26 07:57:47 -04:00
|
|
|
|
|
2021-04-26 07:53:20 -04:00
|
|
|
|
|
|
|
|
|
(define-command self-insert-command
|
|
|
|
|
"Insert the character you type.
|
|
|
|
|
Whichever character you type to run this command is inserted."
|
|
|
|
|
"P"
|
|
|
|
|
(lambda (argument)
|
|
|
|
|
(let ((char (last-command-key)))
|
|
|
|
|
(if (not (char? char))
|
|
|
|
|
(editor-error "self-insert-command only works on character keys."))
|
|
|
|
|
(self-insert char (command-argument-numeric-value argument) #t))))
|
|
|
|
|
|
|
|
|
|
(define (self-insert char n allow-auto-fill?)
|
|
|
|
|
(and (> n 0)
|
|
|
|
|
(let ((point (current-point))
|
|
|
|
|
(hairy? #f))
|
|
|
|
|
(if (and (not (group-start? point))
|
|
|
|
|
(buffer-minor-mode? (mark-buffer point)
|
|
|
|
|
(ref-mode-object abbrev))
|
|
|
|
|
(not (char=? #\w (char-syntax char)))
|
|
|
|
|
(char=? #\w (char-syntax (extract-left-char point))))
|
|
|
|
|
(let ((t (group-modified-tick (mark-group point))))
|
|
|
|
|
((ref-command expand-abbrev) point)
|
|
|
|
|
(if (not (fix:= t (group-modified-tick (mark-group point))))
|
|
|
|
|
(set! hairy? #t))))
|
|
|
|
|
(if (and allow-auto-fill?
|
|
|
|
|
(or (char=? #\space char)
|
|
|
|
|
(char=? #\newline char))
|
|
|
|
|
(current-minor-mode? (ref-mode-object auto-fill)))
|
|
|
|
|
(let ((t (group-modified-tick (mark-group point))))
|
|
|
|
|
(auto-fill-break (current-point))
|
|
|
|
|
(if (not (fix:= t (group-modified-tick (mark-group point))))
|
|
|
|
|
(set! hairy? #t))))
|
|
|
|
|
(insert-chars char n)
|
|
|
|
|
hairy?)))
|
|
|
|
|
|
|
|
|
|
(define (read-quoted-char prompt-string)
|
|
|
|
|
(let ((read-ascii-char
|
|
|
|
|
(lambda ()
|
|
|
|
|
(let ((input (with-editor-interrupts-disabled keyboard-read)))
|
|
|
|
|
(if (input-event? input)
|
|
|
|
|
(abort-current-command input)
|
|
|
|
|
(begin
|
|
|
|
|
(if (not (ascii-char? input))
|
|
|
|
|
(editor-error "Can't quote non-ASCII char:" input))
|
|
|
|
|
(set-command-prompt!
|
|
|
|
|
(string-append (command-prompt) (key-name input)))
|
|
|
|
|
input))))))
|
|
|
|
|
(let ((read-digit
|
|
|
|
|
(lambda ()
|
|
|
|
|
(or (char->digit (read-ascii-char) 8)
|
|
|
|
|
(editor-error "Not an octal digit")))))
|
|
|
|
|
(set-command-prompt! prompt-string)
|
|
|
|
|
(let ((char (read-ascii-char)))
|
|
|
|
|
(let ((digit (char->digit char 4)))
|
|
|
|
|
(if digit
|
|
|
|
|
(integer->char
|
|
|
|
|
(let ((digit2 (read-digit)))
|
|
|
|
|
(let ((digit3 (read-digit)))
|
|
|
|
|
(+ (* (+ (* digit 8) digit2) 8) digit3))))
|
|
|
|
|
char))))))
|
|
|
|
|
|
|
|
|
|
(define-command quoted-insert
|
|
|
|
|
"Reads a character and inserts it."
|
|
|
|
|
"p"
|
|
|
|
|
(lambda (argument)
|
|
|
|
|
(insert-chars (read-quoted-char "Quote Character: ")
|
|
|
|
|
argument)))
|
|
|
|
|
|
|
|
|
|
(define-command open-line
|
|
|
|
|
"Insert a newline after point.
|
|
|
|
|
Differs from ordinary insertion in that point remains
|
|
|
|
|
before the inserted characters.
|
|
|
|
|
With an argument, inserts several newlines."
|
|
|
|
|
"P"
|
|
|
|
|
(lambda (argument)
|
|
|
|
|
(let ((m* (mark-right-inserting (current-point))))
|
|
|
|
|
(insert-newlines (command-argument-numeric-value argument))
|
|
|
|
|
(set-current-point! m*))))
|
|
|
|
|
|
|
|
|
|
(define-command narrow-to-region
|
|
|
|
|
"Restrict editing in current buffer to text between point and mark.
|
|
|
|
|
Use \\[widen] to undo the effects of this command."
|
|
|
|
|
"r"
|
|
|
|
|
region-clip!)
|
|
|
|
|
|
|
|
|
|
(define-command widen
|
|
|
|
|
"Remove restrictions from current buffer.
|
|
|
|
|
Allows full text to be seen and edited."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(buffer-widen! (current-buffer))))
|
|
|
|
|
|
|
|
|
|
(define-command set-key
|
|
|
|
|
"Define a key binding from the keyboard.
|
|
|
|
|
Prompts for a command and a key, and sets the key's binding.
|
|
|
|
|
The key is bound in fundamental mode."
|
|
|
|
|
(lambda ()
|
|
|
|
|
(let ((command (prompt-for-command "Command" 'HISTORY 'SET-KEY)))
|
|
|
|
|
(list command
|
|
|
|
|
(prompt-for-key (string-append "Put \""
|
|
|
|
|
(command-name-string command)
|
|
|
|
|
"\" on key")
|
|
|
|
|
(mode-comtabs (ref-mode-object fundamental))))))
|
|
|
|
|
(lambda (command key)
|
|
|
|
|
(if (prompt-for-confirmation? "Go ahead")
|
|
|
|
|
(define-key 'fundamental key (command-name command)))))
|
|
|
|
|
|
|
|
|
|
(define-variable buffer-reallocation-factor
|
|
|
|
|
"Determines how much a buffer grows by when it needs to expand.
|
|
|
|
|
This is a real number greater than one. When a buffer is expanded,
|
|
|
|
|
its size is multiplied by this factor until it is big enough.
|
|
|
|
|
Similarly, when a buffer shrinks, its size is divided by this factor.
|
|
|
|
|
|
|
|
|
|
Increasing this factor reduces the average time for insertion and
|
|
|
|
|
deletion, but increases the average space used by the buffer.
|
|
|
|
|
|
|
|
|
|
The minimum ratio between the number of characters in a buffer and the
|
|
|
|
|
amount of space allocated to hold them is
|
|
|
|
|
(/ 1 (expt buffer-reallocation-factor 2))"
|
|
|
|
|
5/4
|
|
|
|
|
(lambda (object) (and (real? object) (> object 1))))
|
|
|
|
|
|
|
|
|
|
;;;; Prefixes
|
|
|
|
|
|
|
|
|
|
(define-command control-prefix
|
|
|
|
|
"Sets Control-bit of following character.
|
|
|
|
|
This command followed by an = is equivalent to a Control-=."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(read-extension-key
|
|
|
|
|
(lambda (char)
|
|
|
|
|
(merge-bucky-bits char char-bit:control)))))
|
|
|
|
|
|
|
|
|
|
(define-command meta-prefix
|
2021-04-26 07:57:47 -04:00
|
|
|
|
"Sets Meta-bit of following character.
|
2021-04-26 07:53:20 -04:00
|
|
|
|
Turns a following A into a Meta-A.
|
|
|
|
|
If the Metizer character is Altmode, it turns ^A
|
|
|
|
|
into Control-Meta-A. Otherwise, it turns ^A into plain Meta-A."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(read-extension-key
|
|
|
|
|
(lambda (char)
|
|
|
|
|
(merge-bucky-bits (if (eqv? (current-command-key) #\altmode)
|
|
|
|
|
char
|
|
|
|
|
(char-base char))
|
|
|
|
|
char-bit:meta)))))
|
|
|
|
|
|
|
|
|
|
(define-command control-meta-prefix
|
|
|
|
|
"Sets Control- and Meta-bits of following character.
|
|
|
|
|
Turns a following A (or C-A) into a Control-Meta-A."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(read-extension-key
|
|
|
|
|
(lambda (char)
|
|
|
|
|
(merge-bucky-bits char (fix:or char-bit:control char-bit:meta))))))
|
|
|
|
|
|
|
|
|
|
(define execute-extended-keys?
|
|
|
|
|
#t)
|
|
|
|
|
|
|
|
|
|
(define extension-commands
|
|
|
|
|
(list (name->command 'control-prefix)
|
|
|
|
|
(name->command 'meta-prefix)
|
|
|
|
|
(name->command 'control-meta-prefix)))
|
|
|
|
|
|
|
|
|
|
(define (read-extension-key modifier)
|
|
|
|
|
(if execute-extended-keys?
|
|
|
|
|
(set-command-prompt-prefix!))
|
|
|
|
|
(let ((key
|
|
|
|
|
(modifier
|
|
|
|
|
(let ((input (with-editor-interrupts-disabled keyboard-read)))
|
|
|
|
|
(if (char? input)
|
|
|
|
|
input
|
|
|
|
|
(abort-current-command input))))))
|
|
|
|
|
(if execute-extended-keys?
|
|
|
|
|
(dispatch-on-key (current-comtabs) key)
|
|
|
|
|
key)))
|
|
|
|
|
|
|
|
|
|
(define-command prefix-key
|
|
|
|
|
"This is a prefix for more commands.
|
|
|
|
|
It reads another character (a subcommand) and dispatches on it."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(set-command-prompt-prefix!)
|
|
|
|
|
(let loop ()
|
|
|
|
|
(let ((input (with-editor-interrupts-disabled keyboard-read)))
|
|
|
|
|
(if (input-event? input)
|
|
|
|
|
(begin
|
|
|
|
|
(apply-input-event input)
|
|
|
|
|
(loop))
|
|
|
|
|
(dispatch-on-key (current-comtabs)
|
|
|
|
|
(let ((prefix-key (current-command-key)))
|
|
|
|
|
((if (pair? prefix-key) append cons)
|
|
|
|
|
prefix-key
|
|
|
|
|
(list input)))))))))
|
|
|
|
|
|
|
|
|
|
(define (set-command-prompt-prefix!)
|
|
|
|
|
(set-command-prompt!
|
|
|
|
|
(string-append-separated
|
|
|
|
|
(command-argument-prompt)
|
|
|
|
|
(string-append (xkey->name (current-command-key)) " -"))))
|
|
|
|
|
|
|
|
|
|
(define-command execute-extended-command
|
|
|
|
|
"Read an extended command from the terminal with completion.
|
|
|
|
|
This command reads the name of a command, with completion. Then the
|
|
|
|
|
command is invoked. Completion is done as the command name is typed
|
|
|
|
|
For more information type the HELP key while entering the name."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(dispatch-on-command
|
|
|
|
|
(prompt-for-command
|
|
|
|
|
;; Prompt with the name of the command char.
|
|
|
|
|
(list (string-append (xkey->name (current-command-key)) " "))
|
|
|
|
|
'HISTORY 'EXECUTE-EXTENDED-COMMAND)
|
|
|
|
|
#t)))
|
|
|
|
|
|
|
|
|
|
;;;; Errors
|
|
|
|
|
|
|
|
|
|
(define-command keyboard-quit
|
|
|
|
|
"Signals a quit condition."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(editor-beep)
|
|
|
|
|
(temporary-message "Quit")
|
|
|
|
|
(^G-signal)))
|
|
|
|
|
|
|
|
|
|
(define-command undefined
|
|
|
|
|
"This command is used to capture undefined keys."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(editor-error "Undefined command: " (xkey->name (current-command-key)))))
|
|
|
|
|
|
|
|
|
|
(define (barf-if-read-only)
|
|
|
|
|
(editor-error "Trying to modify read only text."))
|
|
|
|
|
|
|
|
|
|
(define (check-first-group-modification group)
|
|
|
|
|
(let ((buffer (group-buffer group)))
|
|
|
|
|
(if (and buffer
|
|
|
|
|
(buffer-truename buffer)
|
|
|
|
|
(buffer-modification-time buffer)
|
|
|
|
|
(not (verify-visited-file-modification-time? buffer)))
|
|
|
|
|
(ask-user-about-supersession-threat buffer))))
|
|
|
|
|
|
|
|
|
|
(define (ask-user-about-supersession-threat buffer)
|
|
|
|
|
(if (not
|
|
|
|
|
(with-selected-buffer buffer
|
|
|
|
|
(lambda ()
|
|
|
|
|
(prompt-for-confirmation?
|
|
|
|
|
"File has changed on disk; really want to edit the buffer"))))
|
|
|
|
|
(editor-error "File changed on disk: "
|
|
|
|
|
(->namestring (buffer-pathname buffer))))
|
|
|
|
|
(message
|
|
|
|
|
"File on disk now will become a backup file if you save these changes.")
|
|
|
|
|
(set-buffer-backed-up?! buffer #f))
|
|
|
|
|
|
|
|
|
|
(define (editor-failure . strings)
|
|
|
|
|
(cond ((not (null? strings)) (apply message strings))
|
|
|
|
|
(*defining-keyboard-macro?* (clear-message)))
|
|
|
|
|
(editor-beep)
|
|
|
|
|
(keyboard-macro-disable)
|
|
|
|
|
(abort-keyboard-macro))
|
|
|
|
|
|
|
|
|
|
(define-variable beeping-allowed?
|
|
|
|
|
"False if Edwin must never beep."
|
|
|
|
|
#t)
|
|
|
|
|
|
|
|
|
|
(define-integrable (editor-beep)
|
|
|
|
|
(if (ref-variable beeping-allowed?)
|
|
|
|
|
(screen-beep (selected-screen))))
|
|
|
|
|
|
|
|
|
|
;;;; Level Control
|
|
|
|
|
|
|
|
|
|
(define-command exit-recursive-edit
|
|
|
|
|
"Exit normally from a subsystem of a level of editing."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(exit-recursive-edit 'EXIT)))
|
|
|
|
|
|
|
|
|
|
(define-command abort-recursive-edit
|
|
|
|
|
"Abnormal exit from recursive editing command.
|
|
|
|
|
The recursive edit is exited and the command that invoked it is aborted.
|
|
|
|
|
For a normal exit, you should use \\[exit-recursive-edit], NOT this command."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(exit-recursive-edit 'ABORT)))
|
|
|
|
|
|
|
|
|
|
;;;; Leaving Edwin
|
|
|
|
|
|
|
|
|
|
;; Set this to #F to indicate that returning from the editor has the
|
|
|
|
|
;; same effect as calling EXIT, or to prevent the editor from
|
|
|
|
|
;; returning to scheme.
|
|
|
|
|
(define editor-can-exit? #t)
|
|
|
|
|
|
|
|
|
|
;; Set this to #F to indicate that calling SUSPEND has the same effect
|
|
|
|
|
;; as calling EXIT, or to prevent the editor from suspending to the OS.
|
|
|
|
|
(define scheme-can-suspend?
|
|
|
|
|
#t)
|
|
|
|
|
|
|
|
|
|
;; Set this to #T to force the exit commands to always prompt for
|
|
|
|
|
;; confirmation before killing Edwin.
|
|
|
|
|
(define paranoid-exit? #f)
|
|
|
|
|
|
|
|
|
|
(define-command suspend-scheme
|
|
|
|
|
"Go back to Scheme's superior job.
|
|
|
|
|
With argument, saves visited file first."
|
|
|
|
|
"P"
|
|
|
|
|
(lambda (argument)
|
|
|
|
|
(if argument (save-buffer (current-buffer) #f))
|
|
|
|
|
(if (and scheme-can-suspend? (os/scheme-can-suspend?))
|
|
|
|
|
(quit-scheme)
|
|
|
|
|
(editor-error "Scheme cannot be suspended"))))
|
|
|
|
|
|
|
|
|
|
(define-command suspend-edwin
|
|
|
|
|
"Stop Edwin and return to Scheme."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(if (not editor-can-exit?)
|
|
|
|
|
(editor-error "Edwin cannot be suspended"))
|
|
|
|
|
(quit-editor)))
|
|
|
|
|
|
|
|
|
|
(define (save-buffers-and-exit no-confirmation? noun exit)
|
|
|
|
|
(save-some-buffers no-confirmation? #t)
|
|
|
|
|
(if (and (or (not (any (lambda (buffer)
|
|
|
|
|
(and (buffer-modified? buffer)
|
|
|
|
|
(buffer-pathname buffer)))
|
|
|
|
|
(buffer-list)))
|
|
|
|
|
(prompt-for-yes-or-no? "Modified buffers exist; exit anyway"))
|
|
|
|
|
(if (any (lambda (process)
|
|
|
|
|
(and (not (process-kill-without-query process))
|
|
|
|
|
(process-runnable? process)))
|
|
|
|
|
(process-list))
|
|
|
|
|
(and (prompt-for-yes-or-no?
|
|
|
|
|
"Active processes exist; kill them and exit anyway")
|
|
|
|
|
(begin
|
|
|
|
|
(for-each delete-process (process-list))
|
|
|
|
|
#t))
|
|
|
|
|
(or (not paranoid-exit?)
|
|
|
|
|
(prompt-for-yes-or-no? (string-append "Kill " noun)))))
|
|
|
|
|
(exit)))
|
|
|
|
|
|
|
|
|
|
(define-command save-buffers-kill-scheme
|
|
|
|
|
"Offer to save each buffer, then kill Scheme.
|
|
|
|
|
With prefix arg, silently save all file-visiting buffers, then kill."
|
|
|
|
|
"P"
|
|
|
|
|
(lambda (no-confirmation?)
|
|
|
|
|
(save-buffers-and-exit no-confirmation? "Scheme" exit-scheme)))
|
|
|
|
|
|
|
|
|
|
(define (save-buffers-kill-edwin #!optional no-confirmation?)
|
|
|
|
|
(let ((no-confirmation?
|
|
|
|
|
(and (not (default-object? no-confirmation?)) no-confirmation?)))
|
|
|
|
|
(if editor-can-exit?
|
|
|
|
|
(save-buffers-and-exit no-confirmation? "Edwin" exit-editor)
|
|
|
|
|
(save-buffers-and-exit no-confirmation? "Scheme" exit-scheme))))
|
|
|
|
|
|
|
|
|
|
(define-command save-buffers-kill-edwin
|
|
|
|
|
"Offer to save each buffer, then kill Edwin, returning to Scheme.
|
|
|
|
|
With prefix arg, silently save all file-visiting buffers, then kill."
|
|
|
|
|
"P"
|
|
|
|
|
save-buffers-kill-edwin)
|
|
|
|
|
|
|
|
|
|
;;;; Comment Commands
|
|
|
|
|
|
|
|
|
|
(define-variable-per-buffer comment-column
|
|
|
|
|
"Column to indent right-margin comments to.
|
|
|
|
|
Setting this variable automatically makes it local to the current buffer."
|
|
|
|
|
32
|
|
|
|
|
exact-nonnegative-integer?)
|
|
|
|
|
|
|
|
|
|
(define-variable comment-locator-hook
|
|
|
|
|
"Procedure to find a comment, or false if no comment syntax defined.
|
|
|
|
|
The procedure is passed a mark, and should return false if it cannot
|
|
|
|
|
find a comment, or a pair of marks. The car should be the start of
|
|
|
|
|
the comment, and the cdr should be the end of the comment's starter."
|
|
|
|
|
#f)
|
|
|
|
|
|
|
|
|
|
(define-variable comment-indent-hook
|
|
|
|
|
"Procedure to compute desired indentation for a comment.
|
|
|
|
|
The procedure is passed the start mark of the comment
|
|
|
|
|
and should return the column to indent the comment to."
|
|
|
|
|
#f)
|
|
|
|
|
|
|
|
|
|
(define-variable comment-start
|
|
|
|
|
"String to insert to start a new comment, or #f if no comment syntax defined."
|
|
|
|
|
""
|
|
|
|
|
string-or-false?)
|
|
|
|
|
|
|
|
|
|
(define-variable comment-end
|
|
|
|
|
"String to insert to end a new comment.
|
|
|
|
|
Should be an empty string if comments are terminated by end-of-line."
|
|
|
|
|
""
|
|
|
|
|
string?)
|
|
|
|
|
|
|
|
|
|
(define-command set-comment-column
|
|
|
|
|
"Set the comment column based on point.
|
|
|
|
|
With no arg, set the comment column to the current column.
|
|
|
|
|
With just minus as arg, kill any comment on this line.
|
|
|
|
|
Otherwise, set the comment column to the argument."
|
|
|
|
|
"P"
|
|
|
|
|
(lambda (argument)
|
|
|
|
|
(if (command-argument-negative-only? argument)
|
|
|
|
|
((ref-command kill-comment))
|
|
|
|
|
(let ((column
|
|
|
|
|
(or (command-argument-value argument)
|
|
|
|
|
(current-column))))
|
|
|
|
|
(set-variable! comment-column column)
|
|
|
|
|
(message "comment-column set to " column)))))
|
|
|
|
|
|
|
|
|
|
(define-command indent-for-comment
|
|
|
|
|
"Indent this line's comment to comment column, or insert an empty comment."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(if (not (ref-variable comment-locator-hook))
|
|
|
|
|
(editor-error "No comment syntax defined"))
|
|
|
|
|
(let ((start (line-start (current-point) 0))
|
|
|
|
|
(end (line-end (current-point) 0)))
|
|
|
|
|
(let ((com ((ref-variable comment-locator-hook) start)))
|
|
|
|
|
(set-current-point! (if com (car com) end))
|
|
|
|
|
(let ((comment-end (and com (mark-permanent! (cdr com)))))
|
|
|
|
|
(let ((indent
|
|
|
|
|
((ref-variable comment-indent-hook) (current-point))))
|
|
|
|
|
(maybe-change-column indent)
|
|
|
|
|
(if comment-end
|
|
|
|
|
(set-current-point! comment-end)
|
|
|
|
|
(begin
|
|
|
|
|
(insert-string (ref-variable comment-start))
|
|
|
|
|
(insert-comment-end (current-point))))))))))
|
|
|
|
|
|
|
|
|
|
(define-variable comment-multi-line
|
|
|
|
|
"True means \\[indent-new-comment-line] should continue same comment
|
|
|
|
|
on new line, with no new terminator or starter."
|
|
|
|
|
#f
|
|
|
|
|
boolean?)
|
|
|
|
|
|
|
|
|
|
(define-command indent-new-comment-line
|
|
|
|
|
"Break line at point and indent, continuing comment if presently within one."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(indent-new-comment-line (current-point) (ref-variable fill-prefix))))
|
|
|
|
|
|
|
|
|
|
(define (indent-new-comment-line mark fill-prefix)
|
|
|
|
|
(let ((mark (mark-left-inserting-copy mark)))
|
|
|
|
|
(delete-horizontal-space mark)
|
|
|
|
|
(insert-newlines 1 mark)
|
|
|
|
|
(let ((if-not-in-comment
|
|
|
|
|
(lambda ()
|
|
|
|
|
(if fill-prefix
|
|
|
|
|
(insert-string fill-prefix mark)
|
|
|
|
|
(with-selected-buffer (mark-buffer mark)
|
|
|
|
|
(lambda ()
|
|
|
|
|
(with-current-point mark
|
|
|
|
|
(ref-command indent-according-to-mode))))))))
|
|
|
|
|
(if (ref-variable comment-locator-hook mark)
|
|
|
|
|
(let ((com ((ref-variable comment-locator-hook mark)
|
|
|
|
|
(line-start mark -1))))
|
|
|
|
|
(if com
|
|
|
|
|
(let ((start-column (mark-column (car com)))
|
|
|
|
|
(end-column (mark-column (cdr com)))
|
|
|
|
|
(comment-start (extract-string (car com) (cdr com))))
|
|
|
|
|
(if (ref-variable comment-multi-line mark)
|
|
|
|
|
(maybe-change-column end-column mark)
|
|
|
|
|
(begin
|
|
|
|
|
(insert-string (ref-variable comment-end mark)
|
|
|
|
|
(line-end mark -1))
|
|
|
|
|
(maybe-change-column start-column mark)
|
|
|
|
|
(insert-string comment-start mark)))
|
|
|
|
|
(if (line-end? mark)
|
|
|
|
|
(insert-comment-end mark)))
|
|
|
|
|
(if-not-in-comment)))
|
|
|
|
|
(if-not-in-comment)))
|
|
|
|
|
(mark-temporary! mark)))
|
|
|
|
|
|
|
|
|
|
(define (insert-comment-end mark)
|
|
|
|
|
(let ((mark (mark-right-inserting-copy mark)))
|
|
|
|
|
(insert-string (ref-variable comment-end mark) mark)
|
|
|
|
|
(set-buffer-point! (mark-buffer mark) mark)
|
|
|
|
|
(mark-temporary! mark)))
|
|
|
|
|
|
|
|
|
|
(define-command kill-comment
|
|
|
|
|
"Kill the comment on this line, if any."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(if (not (ref-variable comment-locator-hook))
|
|
|
|
|
(editor-error "No comment syntax defined")
|
|
|
|
|
(let ((start (line-start (current-point) 0))
|
|
|
|
|
(end (line-end (current-point) 0)))
|
|
|
|
|
(let ((com ((ref-variable comment-locator-hook) start)))
|
|
|
|
|
(if com
|
|
|
|
|
(kill-string (horizontal-space-start (car com)) end)))))))
|
|
|
|
|
|
|
|
|
|
;;;; Useful Documentation
|
|
|
|
|
|
|
|
|
|
(define-command define-command
|
|
|
|
|
"Scheme special form used to define commands:
|
|
|
|
|
|
|
|
|
|
(define-command NAME DOCUMENTATION INTERACTIVE-SPEC PROCEDURE)
|
|
|
|
|
|
|
|
|
|
where:
|
|
|
|
|
NAME is a symbol;
|
|
|
|
|
DOCUMENTATION is a string;
|
|
|
|
|
INTERACTIVE-SPEC describes how to call PROCEDURE when the command is
|
|
|
|
|
invoked interactively (see below); and
|
|
|
|
|
PROCEDURE is a Scheme procedure that is called to perform the
|
|
|
|
|
command's actions.
|
|
|
|
|
|
|
|
|
|
INTERACTIVE-SPEC and PROCEDURE are evaluated, the others aren't.
|
|
|
|
|
|
|
|
|
|
INTERACTIVE-SPEC specifies a way of parsing arguments for interactive
|
|
|
|
|
use of a command. For example, write
|
|
|
|
|
(define-command foo \"Doc string\" \"p\" (lambda (arg) ...use arg...))
|
|
|
|
|
to make arg be the prefix numeric argument when foo is invoked.
|
|
|
|
|
|
|
|
|
|
INTERACTIVE-SPEC is usually a string containing a code letter
|
|
|
|
|
followed by a prompt. (Some code letters do not use I/O to get
|
|
|
|
|
the argument and do not need prompts.) To prompt for multiple arguments,
|
|
|
|
|
give a code letter, its prompt, a newline, and another code letter, etc.
|
|
|
|
|
If INTERACTIVE-SPEC is not a string, it is either a procedure or ().
|
|
|
|
|
If it's a procedure, then the procedure is invoked with no arguments,
|
|
|
|
|
and should return a list of arguments for the command.
|
|
|
|
|
Otherwise, if it's the empty list, the command gets no arguments.
|
|
|
|
|
|
|
|
|
|
Code letters available are:
|
|
|
|
|
b -- Name of existing buffer (string).
|
|
|
|
|
B -- Name of buffer, possibly nonexistent (string).
|
|
|
|
|
c -- Character.
|
|
|
|
|
C -- Command name (symbol).
|
|
|
|
|
d -- Value of point (editor-mark object). Does not do I/O.
|
|
|
|
|
D -- Directory name (string).
|
|
|
|
|
f -- Existing file name (string).
|
|
|
|
|
F -- Possibly nonexistent file name (string).
|
|
|
|
|
k -- Key sequence (list of chars).
|
|
|
|
|
m -- Value of mark (editor-mark object). Does not do I/O.
|
|
|
|
|
n -- Number read using minibuffer.
|
|
|
|
|
N -- Prefix arg converted to number, or if none, do like code `n'.
|
|
|
|
|
p -- Prefix arg converted to number, or 1 if no prefix. Does not do I/O.
|
|
|
|
|
P -- Prefix arg converted to number, or #F if no prefix. Does not do I/O.
|
|
|
|
|
r -- Region: current region (editor-region object). Does no I/O.
|
|
|
|
|
s -- Any string.
|
|
|
|
|
v -- Variable name (symbol).
|
|
|
|
|
x -- Scheme expression read but not evaluated.
|
|
|
|
|
X -- Scheme expression read and evaluated.
|
|
|
|
|
In addition, if the first character of the string is '*' then an error is
|
|
|
|
|
signaled if the buffer is read-only.
|
|
|
|
|
This happens before reading any arguments."
|
|
|
|
|
()
|
2021-04-26 07:57:47 -04:00
|
|
|
|
(lambda () (editor-error "DEFINE-COMMAND shouldn't be invoked")))
|