;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/argred.scm,v 1.27 1989/03/14 07:58:32 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/argred.scm,v 1.28 1989/04/15 00:46:21 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
\f
;;;; Commands
-(define-command ("^R Universal Argument")
+(define-command universal-argument
"Increments the argument multiplier and enters Autoarg mode.
In Autoarg mode, - negates the numeric argument, and the
digits 0, ..., 9 accumulate it."
- (command-argument-increment-multiplier-exponent!)
- (enter-autoargument-mode!)
- (update-argument-prompt!)
- (read-and-dispatch-on-char))
-
-(define-command ("^R Argument Digit")
+ ()
+ (lambda ()
+ (command-argument-increment-multiplier-exponent!)
+ (enter-autoargument-mode!)
+ (update-argument-prompt!)
+ (read-and-dispatch-on-char)))
+
+(define-command digit-argument
"Sets the numeric argument for the next command.
Several such digits typed consecutively accumulate to form
the argument. This command should *only* be placed on a character
which is a digit (modulo control/meta bits)."
- (command-argument-accumulate-digit! (char-base (current-command-char)))
- (update-argument-prompt!)
- (read-and-dispatch-on-char))
+ ()
+ (lambda ()
+ (command-argument-accumulate-digit! (char-base (current-command-char)))
+ (update-argument-prompt!)
+ (read-and-dispatch-on-char)))
-(define-command ("^R Negative Argument")
+(define-command negative-argument
"Negates the numeric argument for the next command.
If no argument has yet been given, the argument defaults to -1."
- (command-argument-negate!)
- (update-argument-prompt!)
- (read-and-dispatch-on-char))
+ ()
+ (lambda ()
+ (command-argument-negate!)
+ (update-argument-prompt!)
+ (read-and-dispatch-on-char)))
(define (command-argument-self-insert? procedure)
- (and (or (eq? procedure ^r-autoargument-digit-command)
- (and (eq? procedure ^r-auto-negative-argument-command)
+ (and (or (eq? procedure (ref-command auto-digit-argument))
+ (and (eq? procedure (ref-command auto-negative-argument))
(command-argument-beginning?)))
(not *autoargument-mode?*)))
-(define-command ("^R Autoargument Digit" argument)
+(define-command auto-digit-argument
"In Autoargument mode, sets numeric argument to the next command.
Otherwise, the digit inserts itself. This just dispatches to either
-Argument Digit or Insert Self, depending on the mode."
- ((if (autoargument-mode?)
- ^r-argument-digit-command
- ^r-insert-self-command)
- argument))
-
-(define-command ("^R Auto Negative Argument" argument)
+\\[digit-argument] or \\[self-insert-command], depending on the mode."
+ ()
+ (lambda ()
+ (dispatch-on-command
+ (if (autoargument-mode?)
+ (ref-command-object digit-argument)
+ (ref-command-object self-insert-command)))))
+
+(define-command auto-negative-argument
"In Autoargument mode, sets numeric sign to the next command.
Otherwise, the character inserts itself. This just dispatches to either
-Negative Argument or Insert Self, depending on the mode."
- ((if (and *autoargument-mode?* (command-argument-beginning?))
- ^r-negative-argument-command
- ^r-insert-self-command)
- argument))
-
-(define-command ("^R Autoargument" argument)
+\\[negative-argument] or \\[insert-self-command], depending on the mode."
+ ()
+ (lambda ()
+ (dispatch-on-command
+ (if (and *autoargument-mode?* (command-argument-beginning?))
+ (ref-command-object negative-argument)
+ (ref-command-object self-insert-command)))))
+
+(define-command auto-argument
"Used to start a command argument and enter Autoargument mode.
This should only be placed on digits or -, with or without control
or meta bits."
- (let ((char (char-base (current-command-char))))
- (if (eq? char #\-)
- (if (command-argument-beginning?)
- (begin (enter-autoargument-mode!)
- (^r-negative-argument-command argument))
- (insert-chars char argument))
- (begin (enter-autoargument-mode!)
- (^r-argument-digit-command argument)))))
+ "P"
+ (lambda (argument)
+ (let ((char (char-base (current-command-char))))
+ (cond ((not (eq? char #\-))
+ (enter-autoargument-mode!)
+ (dispatch-on-command (ref-command-object digit-argument)))
+ ((command-argument-beginning?)
+ (enter-autoargument-mode!)
+ (dispatch-on-command (ref-command-object negative-argument)))
+ (else
+ (insert-chars char argument))))))
\f
;;;; Primitives
;;;; Value
+(define (command-argument-standard-value?)
+ (or *magnitude*
+ (not (zero? *multiplier-exponent*))
+ *negative?*))
+
(define (command-argument-standard-value)
(or (command-argument-value)
(and *negative?* -1)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/autold.scm,v 1.41 1989/04/05 18:11:32 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/autold.scm,v 1.42 1989/04/15 00:46:29 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
\f
;;;; Definitions
-(define (define-autoload-procedure package name library-name)
- (let ((environment (->environment package)))
- (local-assignment environment
- name
- (make-autoloading-procedure
- library-name
- (lambda () (lexical-reference environment name))))))
-
(define (make-autoloading-procedure library-name get-procedure)
(define entity
(make-entity (lambda arguments
(cons autoloading-procedure-tag library-name)))
entity)
-(define autoloading-procedure-tag
- "autoloading-procedure-tag")
+(define autoloading-procedure-tag "autoloading-procedure-tag")
(define (autoloading-procedure? object)
(and (entity? object)
(eq? autoloading-procedure-tag (car (entity-extra object)))))
-(define (define-autoload-major-mode name super-mode-name library-name
- description)
+(define-integrable (autoloading-procedure/library-name procedure)
+ (cdr (entity-extra procedure)))
+(define (define-autoload-procedure name package library-name)
+ (let ((environment (->environment package)))
+ (local-assignment environment
+ name
+ (make-autoloading-procedure
+ library-name
+ (lambda () (lexical-reference environment name))))))
+\f
+(define (define-autoload-major-mode name super-mode-name display-name
+ library-name description)
(define mode
(make-mode name
true
+ display-name
(if super-mode-name
(mode-comtabs (name->mode super-mode-name))
'())
(make-autoloading-procedure library-name
(lambda ()
(mode-initialization mode)))))
- mode)
+ (local-assignment (->environment '(EDWIN))
+ (mode-name->scheme-name name)
+ mode)
+ name)
-(define (define-autoload-minor-mode name library-name description)
+(define (define-autoload-minor-mode name display-name library-name description)
(define mode
(make-mode name
false
+ display-name
'()
description
(make-autoloading-procedure library-name
(lambda ()
(mode-initialization mode)))))
- mode)
+ (local-assignment (->environment '(EDWIN))
+ (mode-name->scheme-name name)
+ mode)
+ name)
(define (autoloading-mode? mode)
(autoloading-procedure? (mode-initialization mode)))
(define command
(make-command name
description
+ '()
(make-autoloading-procedure library-name
(lambda ()
(command-procedure command)))))
- command)
+ (local-assignment (->environment '(EDWIN))
+ (command-name->scheme-name name)
+ command)
+ name)
(define (autoloading-command? command)
(autoloading-procedure? (command-procedure command)))
+
+(define (guarantee-command-loaded command)
+ (let ((procedure (command-procedure command)))
+ (if (autoloading-procedure? procedure)
+ (load-library (autoloading-procedure/library-name procedure)))))
\f
;;;; Libraries
(if (or (default-object? purify?) purify?) (purify scode))
(scode-eval scode (->environment package)))) (append-message " -- done"))
-(define-variable "Load File Default"
- "Pathname given as default for \\[Load File]."
- edwin-binary-directory)
-
-(define-command ("Load File" argument)
+(define-command load-file
"Load an Edwin binary file.
An argument, if given, means purify the file too."
- (let ((pathname
- (prompt-for-pathname "Load File" (ref-variable "Load File Default"))))
- (set-variable! "Load File Default" pathname)
- (load-edwin-file pathname '(EDWIN) argument)))
+ "fLoad file\nP"
+ (lambda (filename purify?)
+ (load-edwin-file filename '(EDWIN) purify?)))
-(define-command ("Load Library")
+(define-command load-library
"Load an Edwin library."
- (%load-library
- (prompt-for-alist-value "Load Library"
- (map (lambda (library)
- (cons (symbol->string (car library))
- library))
- known-libraries))))
+ (lambda ()
+ (list
+ (car
+ (prompt-for-alist-value "Load library"
+ (map (lambda (library)
+ (cons (symbol->string (car library))
+ library))
+ known-libraries)))))
+ (lambda (name)
+ (%load-library
+ (or (assq name known-libraries)
+ (editor-error "Unknown library name: " name)))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/autosv.scm,v 1.18 1989/03/14 07:58:41 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/autosv.scm,v 1.19 1989/04/15 00:46:35 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define-variable "Auto Save Visited File"
+(define-variable auto-save-visited-file
"If not false, auto save into the visited file."
false)
-(define-variable "Auto Save Default"
+(define-variable auto-save-default
"If not false, auto save all visited files."
true)
-(define-variable "Auto Save Interval"
+(define-variable auto-save-interval
"The number of keystrokes between auto saves."
300)
-(define-variable "Delete Auto Save Files"
+(define-variable delete-auto-save-files
"If not false, delete auto save files when normal saves happen."
false)
-(define-command ("Auto Save Mode" argument)
+(define-command auto-save-mode
"Toggle Auto Save mode.
With argument, turn Auto Save mode on iff argument is positive."
- (let ((buffer (current-buffer)))
- (if (if argument
- (positive? argument)
- (not (buffer-auto-save-pathname buffer)))
- (begin (enable-buffer-auto-save! buffer)
- (temporary-message "Auto Save enabled"))
- (begin (disable-buffer-auto-save! buffer)
- (temporary-message "Auto Save disabled")))))
+ "P"
+ (lambda (argument)
+ (let ((buffer (current-buffer)))
+ (if (if argument
+ (positive? argument)
+ (not (buffer-auto-save-pathname buffer)))
+ (begin
+ (enable-buffer-auto-save! buffer)
+ (temporary-message "Auto Save enabled"))
+ (begin
+ (disable-buffer-auto-save! buffer)
+ (temporary-message "Auto Save disabled"))))))
(define (setup-buffer-auto-save! buffer)
- (if (ref-variable "Auto Save Default")
+ (if (ref-variable auto-save-default)
(enable-buffer-auto-save! buffer)
(disable-buffer-auto-save! buffer)))
buffer
(let ((pathname (buffer-pathname buffer)))
(if (and pathname
- (ref-variable "Auto Save Visited File"))
+ (ref-variable auto-save-visited-file))
pathname
(os/auto-save-pathname pathname (buffer-name buffer))))))
(set-buffer-auto-saved! buffer))
(define (delete-auto-save-file! buffer)
- (if (and (ref-variable "Delete Auto Save Files")
+ (if (and (ref-variable delete-auto-save-files)
(buffer-auto-save-pathname buffer)
(file-exists? (buffer-auto-save-pathname buffer)))
(delete-file (buffer-auto-save-pathname buffer))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/basic.scm,v 1.95 1989/03/14 07:58:42 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/basic.scm,v 1.96 1989/04/15 00:46:39 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define-command ("^R Bad Command")
- "This command is used to capture undefined keys.
-It is usually called directly by the command lookup
-procedure when it fails to find a command."
- (editor-error "Undefined command: " (xchar->name (current-command-char))))
-
-(define-command ("^R Insert Self" (argument 1))
+(define-command self-insert-command
"Insert the character used to invoke this.
With an argument, insert the character that many times."
- (insert-chars (current-command-char) argument))
+ "P"
+ (lambda (argument)
+ (insert-chars (current-command-char) (or argument 1))))
-(define-command ("^R Quoted Insert" (argument 1))
+(define-command quoted-insert
"Reads a character and inserts it."
- (define (read-char)
- (let ((char (keyboard-read-char)))
- (set-command-prompt! (string-append (command-prompt) (char-name char)))
- char))
-
- (define (read-digit)
- (or (char->digit (read-char) 8)
- (editor-error "Not an octal digit")))
-
- (set-command-prompt! "Quote Character: ")
- (insert-chars (let ((char (read-char)))
- (let ((digit (char->digit char 4)))
- (if digit
- (ascii->char
- (let ((digit2 (read-digit)))
- (let ((digit3 (read-digit)))
- (+ (* (+ (* digit 8) digit2) 8) digit3))))
- char)))
- argument))
-
-(define-command ("^R Open Line" (argument 1))
+ "P"
+ (lambda (argument)
+ (let ((read-char
+ (lambda ()
+ (let ((char (with-editor-interrupts-disabled keyboard-read-char)))
+ (set-command-prompt!
+ (string-append (command-prompt) (char-name char)))
+ char))))
+ (let ((read-digit
+ (lambda ()
+ (or (char->digit (read-char) 8)
+ (editor-error "Not an octal digit")))))
+ (set-command-prompt! "Quote Character: ")
+ (insert-chars (let ((char (read-char)))
+ (let ((digit (char->digit char 4)))
+ (if digit
+ (ascii->char
+ (let ((digit2 (read-digit)))
+ (let ((digit3 (read-digit)))
+ (+ (* (+ (* digit 8) digit2) 8) digit3))))
+ char)))
+ (or argument 1))))))
+
+(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."
- (let ((m* (mark-right-inserting (current-point))))
- (insert-newlines argument)
- (set-current-point! m*)))
-
-(define (xchar->name char)
- (if (pair? char)
- (chars->name char)
- (char-name char)))
-
-(define (chars->name chars)
- (if (null? chars)
- ""
- (string-append-separated (char-name (car chars))
- (chars->name (cdr chars)))))
-
-(define (string-append-separated x y)
- (cond ((string-null? x) y)
- ((string-null? y) x)
- (else (string-append x " " y))))
+ "P"
+ (lambda (argument)
+ (let ((m* (mark-right-inserting (current-point))))
+ (insert-newlines (or argument 1))
+ (set-current-point! m*))))
+\f
+(define-command keyboard-quit
+ "Signals a quit condition."
+ ()
+ (lambda ()
+ (editor-beep)
+ (temporary-message "Quit")
+ (^G-signal)))
+
+(define-command ^r-bad-command
+ "This command is used to capture undefined keys.
+It is usually called directly by the command lookup
+procedure when it fails to find a command."
+ ()
+ (lambda ()
+ (editor-error "Undefined command: " (xchar->name (current-command-char)))))
+
+(define (barf-if-read-only)
+ (editor-error "Trying to modify read only text."))
(define (editor-error . strings)
(if (not (null? strings)) (apply temporary-message strings))
(editor-beep)
(abort-current-command))
-
(define (editor-failure . strings)
(cond ((not (null? strings)) (apply temporary-message strings))
(*defining-keyboard-macro?* (clear-message)))
(define (not-implemented)
(editor-error "Not yet implemented"))
\f
-(define-command ("^R Prefix Control")
+(define-command control-prefix
"Sets Control-bit of following character.
This command followed by an = is equivalent to a Control-=."
- (read-extension-char "C-" char-controlify))
+ ()
+ (lambda ()
+ (read-extension-char "C-" char-controlify)))
-(define-command ("^R Prefix Meta")
+(define-command meta-prefix
"Sets Meta-bit of following character.
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."
- (read-extension-char "M-"
- (if (let ((char (current-command-char)))
- (and (char? char)
- (char=? #\Altmode char)))
- char-metafy
- (lambda (char)
- (char-metafy (char-base char))))))
-
-(define-command ("^R Prefix Control-Meta")
+ ()
+ (lambda ()
+ (read-extension-char "M-"
+ (if (let ((char (current-command-char)))
+ (and (char? char)
+ (char=? #\Altmode char)))
+ char-metafy
+ (lambda (char)
+ (char-metafy (char-base char)))))))
+
+(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."
- (read-extension-char "C-M-" char-control-metafy))
+ ()
+ (lambda ()
+ (read-extension-char "C-M-" char-control-metafy)))
(define execute-extended-chars?
true)
(define extension-commands
- (list (name->command "^R Prefix Control")
- (name->command "^R Prefix Meta")
- (name->command "^R Prefix Control-Meta")))
+ (list (name->command 'control-prefix)
+ (name->command 'meta-prefix)
+ (name->command 'control-meta-prefix)))
(define (read-extension-char prefix-string modifier)
(if execute-extended-chars?
(set-command-prompt-prefix! prefix-string))
- (let ((char (modifier (keyboard-read-char))))
+ (let ((char (modifier (with-editor-interrupts-disabled keyboard-read-char))))
(if execute-extended-chars?
(dispatch-on-char (current-comtabs) char)
char)))
(string-append-separated (command-argument-prompt)
prefix-string)))
-(define-command ("^R Prefix Character")
+(define-command prefix-char
"This is a prefix for more commands.
It reads another character (a subcommand) and dispatches on it."
- (let ((prefix-char (current-command-char)))
- (set-command-prompt-prefix! (string-append (xchar->name prefix-char) " "))
- (dispatch-on-char (current-comtabs)
- ((if (pair? prefix-char) append cons)
- prefix-char
- (list (keyboard-read-char))))))
-
-(define-command ("^R Extended Command")
+ ()
+ (lambda ()
+ (let ((prefix-char (current-command-char)))
+ (set-command-prompt-prefix!
+ (string-append (xchar->name prefix-char) " "))
+ (dispatch-on-char
+ (current-comtabs)
+ ((if (pair? prefix-char) append cons)
+ prefix-char
+ (list (with-editor-interrupts-disabled keyboard-read-char)))))))
+
+(define-command execute-extended-command
"Read an extended command from the terminal with completion.
This command reads the name of a function, with completion. Then the
function is called. Completion is done as the function name is typed
For more information type the HELP key while entering the name."
- (dispatch-on-command (prompt-for-command "Extended Command")))
+ ()
+ (lambda ()
+ (dispatch-on-command (prompt-for-command "Extended Command"))))
\f
-(define-command ("^R Return to Superior" argument)
+(define-command suspend-scheme
"Go back to Scheme's superior job.
With argument, saves visited file first."
- (if argument (^r-save-file-command))
- (quit)
- (update-screens! true))
+ "P"
+ (lambda (argument)
+ (if argument ((ref-command save-buffer) false))
+ (quit)
+ (update-screens! true)))
-(define-command ("^R Scheme")
+(define-command suspend-edwin
"Stop Edwin and return to Scheme."
- (editor-abort *the-non-printing-object*))
-
-(define-command ("^R Exit")
+ ()
+ (lambda ()
+ (editor-abort *the-non-printing-object*)))
+(define-command exit-recursive-edit
"Exit normally from a subsystem of a level of editing.
-At top level, exit from Edwin like \\[^R Return to Superior]."
- (exit-recursive-edit 'EXIT))
+At top level, exit from Edwin like \\[suspend-scheme]." ()
+ (lambda ()
+ (exit-recursive-edit 'EXIT)))
-(define-command ("Abort Recursive Edit")
+(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 \\[^R Exit], NOT this command."
- (exit-recursive-edit 'ABORT))
+For a normal exit, you should use \\[exit-recursive-edit], NOT this command."
+ ()
+ (lambda ()
+ (exit-recursive-edit 'ABORT)))
-(define-command ("^R Narrow Bounds to Region")
+(define-command narrow-to-region
"Restrict editing in current buffer to text between point and mark.
-Use \\[^R Widen Bounds] to undo the effects of this command."
- (region-clip! (current-region)))
+Use \\[widen] to undo the effects of this command."
+ ()
+ (lambda ()
+ (region-clip! (current-region))))
-(define-command ("^R Widen Bounds")
+(define-command widen
"Remove restrictions from current buffer.
Allows full text to be seen and edited."
- (buffer-widen! (current-buffer)))
+ ()
+ (lambda ()
+ (buffer-widen! (current-buffer))))
-(define-command ("Set Key")
+(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."
- (let ((command (prompt-for-command "Command")))
- (let ((key (prompt-for-key (string-append "Put \""
- (command-name command)
- "\" on key")
- (mode-comtabs fundamental-mode))))
- (if (prompt-for-confirmation? "Go ahead")
- (define-key "Fundamental" key (command-name command))))))
-\f
+The key is bound in fundamental mode."
+ (lambda ()
+ (let ((command (prompt-for-command "Command")))
+ (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)))))\f
;;;; Comment Commands
-(define-variable "Comment Column"
+(define-variable comment-column
"Column to indent right-margin comments to."
32)
-(define-variable "Comment Locator Hook"
+(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."
false)
-(define-variable "Comment Indent Hook"
+(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."
false)
-(define-variable "Comment Start"
+(define-variable comment-start
"String to insert to start a new comment."
"")
-(define-variable "Comment End"
+(define-variable comment-end
"String to insert to end a new comment.
This should be a null string if comments are terminated by Newline."
"")
-(define-command ("^R Set Comment Column" argument)
+(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 an arg, kill any comment on this line.
Otherwise, set the comment column to the argument."
- (cond ((command-argument-negative-only?)
- (^r-kill-comment-command))
- (else
- (set! comment-column (or argument (current-column)))
- (message "Comment column set to " (write-to-string comment-column)))))
+ "P"
+ (lambda (argument)
+ (cond ((command-argument-negative-only?)
+ ((ref-command kill-comment)))
+ (else
+ (set-variable! comment-column (or argument (current-column)))
+ (message "Comment column set to " (ref-variable comment-column))))))
\f
-(define-command ("^R Indent for Comment")
+(define-command indent-for-comment
"Indent this line's comment to comment column, or insert an empty comment."
- (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))
- (if com (mark-permanent! (cdr com)))
- (let ((indent ((ref-variable "Comment Indent Hook")
- (current-point))))
- (maybe-change-column indent)
- (if com
- (set-current-point! (cdr com))
- (begin (insert-string (ref-variable "Comment Start"))
- (insert-comment-end))))))))
-
-(define-variable "Comment Multi Line"
- "If true, means \\[^R Indent New Comment Line] should continue same 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))
+ (if com (mark-permanent! (cdr com)))
+ (let ((indent
+ ((ref-variable comment-indent-hook) (current-point))))
+ (maybe-change-column indent)
+ (if com
+ (set-current-point! (cdr com))
+ (begin (insert-string (ref-variable comment-start))
+ (insert-comment-end)))))))))
+
+(define-variable comment-multi-line
+ "If true, means \\[indent-new-comment-line] should continue same comment
on new line, with no new terminator or starter."
false)
-(define-command ("^R Indent New Comment Line")
+(define-command indent-new-comment-line
"Break line at point and indent, continuing comment if presently within one."
- (define (if-not-in-comment)
- (if (ref-variable "Fill Prefix")
- (insert-string (ref-variable "Fill Prefix"))
- (^r-indent-according-to-mode-command)))
- (delete-horizontal-space)
- (insert-newlines 1)
- (if (ref-variable "Comment Locator Hook")
- (let ((com ((ref-variable "Comment Locator Hook")
- (line-start (current-point) -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")
- (maybe-change-column end-column)
- (begin (insert-string (ref-variable "Comment End")
- (line-end (current-point) -1))
- (maybe-change-column start-column)
- (insert-string comment-start)))
- (if (line-end? (current-point))
- (insert-comment-end)))
- (if-not-in-comment)))
- (if-not-in-comment)))
+ ()
+ (lambda ()
+ (delete-horizontal-space)
+ (insert-newlines 1)
+ (let ((if-not-in-comment
+ (lambda ()
+ (if (ref-variable fill-prefix)
+ (insert-string (ref-variable fill-prefix))
+ ((ref-command indent-according-to-mode))))))
+ (if (ref-variable comment-locator-hook)
+ (let ((com ((ref-variable comment-locator-hook)
+ (line-start (current-point) -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)
+ (maybe-change-column end-column)
+ (begin (insert-string (ref-variable comment-end)
+ (line-end (current-point) -1))
+ (maybe-change-column start-column)
+ (insert-string comment-start)))
+ (if (line-end? (current-point))
+ (insert-comment-end)))
+ (if-not-in-comment)))
+ (if-not-in-comment)))))
(define (insert-comment-end)
(let ((point (mark-right-inserting (current-point))))
- (insert-string (ref-variable "Comment End"))
+ (insert-string (ref-variable comment-end))
(set-current-point! point)))
-(define-command ("^R Kill Comment")
+(define-command kill-comment
"Kill the comment on this line, if any."
- (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))))))
\ No newline at end of file
+ ()
+ (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)))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufcom.scm,v 1.80 1989/03/14 07:58:45 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufcom.scm,v 1.81 1989/04/15 00:46:55 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define-command ("^R Buffer Not Modified")
+(define-command not-modified
"Pretend that this buffer hasn't been altered."
- (buffer-not-modified! (current-buffer)))
+ ()
+ (lambda ()
+ (buffer-not-modified! (current-buffer))))
-(define-command ("Select Buffer")
- "Select buffer with specified name.
-If the variable Select Buffer Create is true,
-specifying a non-existent buffer will cause it to be created."
- (select-buffer (prompt-for-select-buffer "Select Buffer")))
-
-(define-command ("Select Buffer Other Window")
- "Select buffer in another window."
- (select-buffer-other-window
- (prompt-for-select-buffer "Select Buffer Other Window")))
-
-(define-variable "Select Buffer Create"
+(define-variable select-buffer-create
"If true, buffer selection commands may create new buffers."
true)
(define (prompt-for-select-buffer prompt)
- ((if (ref-variable "Select Buffer Create")
- prompt-for-buffer prompt-for-existing-buffer)
- prompt (previous-buffer)))
+ (lambda ()
+ (list
+ (buffer-name
+ ((if (ref-variable select-buffer-create)
+ prompt-for-buffer
+ prompt-for-existing-buffer)
+ prompt
+ (previous-buffer))))))
+
+(define-command switch-to-buffer
+ "Select buffer with specified name.
+If the variable select-buffer-create is true,
+specifying a non-existent buffer will cause it to be created."
+ (prompt-for-select-buffer "Switch to buffer")
+ (lambda (buffer)
+ (select-buffer (find-buffer buffer))))
+(define-command switch-to-buffer-other-window
+ "Select buffer in another window."
+ (prompt-for-select-buffer "Switch to buffer in other window")
+ (lambda (buffer)
+ (select-buffer-other-window (find-buffer buffer))))
-(define-command ("Create Buffer")
+(define-command create-buffer
"Create a new buffer with a given name, and select it."
- (let ((buffer (new-buffer (prompt-for-string "Create Buffer" false))))
- (set-buffer-major-mode! buffer (ref-variable "Editor Default Mode"))
- (select-buffer buffer)))
+ "sCreate buffer"
+ (lambda (name)
+ (let ((buffer (new-buffer name)))
+ (set-buffer-major-mode! buffer (ref-variable editor-default-mode))
+ (select-buffer buffer))))
-(define-command ("Insert Buffer")
+(define-command insert-buffer
"Insert the contents of a specified buffer at point."
- (let ((point (mark-right-inserting (current-point))))
- (region-insert-string!
- point
- (region->string
- (buffer-region (prompt-for-existing-buffer "Insert Buffer" false))))
- (push-current-mark! (current-point))
- (set-current-point! point)))
-
-(define-command ("^R Twiddle Buffers")
+ "bInsert buffer"
+ (lambda (buffer)
+ (let ((point (mark-right-inserting (current-point))))
+ (region-insert-string!
+ point
+ (region->string (buffer-region (find-buffer buffer))))
+ (push-current-mark! (current-point))
+ (set-current-point! point))))
+
+(define-command twiddle-buffers
"Select previous buffer."
- (let ((buffer (previous-buffer)))
- (if buffer
- (select-buffer buffer)
- (editor-error "No previous buffer to select"))))
-
-(define-command ("Bury Current Buffer")
- "Deselect the current buffer, putting it at the end of the buffer list."
- (let ((buffer (current-buffer))
- (previous (previous-buffer)))
- (if previous
- (begin (select-buffer previous)
- (bury-buffer buffer)))))
+ ()
+ (lambda ()
+ (let ((buffer (previous-buffer)))
+ (if buffer
+ (select-buffer buffer)
+ (editor-error "No previous buffer to select")))))
+
+(define-command bury-buffer
+ "Put current buffer at the end of the list of all buffers.
+There it is the least likely candidate for other-buffer to return;
+thus, the least likely buffer for \\[switch-to-buffer] to select by default."
+ ()
+ (lambda ()
+ (let ((buffer (current-buffer))
+ (previous (previous-buffer)))
+ (if previous
+ (begin
+ (select-buffer previous)
+ (bury-buffer buffer))))))
\f
-(define-command ("Kill Buffer")
- "Kill the buffer with specified name.
-Does a completing read of the buffer name in the echo area.
-If the buffer has changes in it, we offer to write it out."
- (kill-buffer-interactive
- (prompt-for-existing-buffer "Kill Buffer" (current-buffer))))
+(define-command kill-buffer
+ "One arg, a string or a buffer. Get rid of the specified buffer."
+ "bKill buffer"
+ (lambda (buffer)
+ (kill-buffer-interactive (find-buffer buffer))))
(define (kill-buffer-interactive buffer)
(if (not (other-buffer buffer)) (editor-error "Only one buffer"))
(save-buffer-changes buffer)
(kill-buffer buffer))
-(define-command ("Kill Some Buffers")
+(define-command kill-some-buffers
"For each buffer, ask whether to kill it."
- (kill-some-buffers true))
+ ()
+ (lambda ()
+ (kill-some-buffers true)))
(define (kill-some-buffers prompt?)
(for-each (lambda (buffer)
(kill-buffer-interactive buffer)
(set-buffer-major-mode!
(create-buffer initial-buffer-name)
- (ref-variable "Editor Default Mode"))
+ (ref-variable editor-default-mode))
(kill-buffer dummy)))))
(buffer-list)))
-(define-command ("Rename Buffer")
+(define-command rename-buffer
"Change the name of the current buffer.
Reads the new name in the echo area."
- (let ((buffer (current-buffer)))
- (let ((name
- (prompt-for-string "Rename Buffer"
- (let ((pathname (buffer-pathname buffer)))
- (and pathname
- (pathname->buffer-name pathname))))))
- (if (find-buffer name)
- (editor-error "Buffer named " name " already exists"))
- (rename-buffer buffer name))))
-
-(define-command ("Normal Mode")
+ "sRename buffer (to new name)"
+ (lambda (name)
+ (if (find-buffer name)
+ (editor-error "Buffer named " name " already exists"))
+ (rename-buffer (current-buffer) name)))
+
+(define-command normal-mode
"Reset mode and local variable bindings to their default values.
Just like what happens when the file is first visited."
- (initialize-buffer! (current-buffer)))
+ ()
+ (lambda ()
+ (initialize-buffer! (current-buffer))))
\f
(define (save-buffer-changes buffer)
(if (and (buffer-pathname buffer)
buffer))
(define (prompt-for-buffer prompt default-buffer)
- (let ((name (prompt-for-buffer-name prompt default-buffer)))
+ (let ((name (prompt-for-buffer-name prompt default-buffer false)))
(or (find-buffer name)
(let ((buffer (create-buffer name)))
- (set-buffer-major-mode! buffer (ref-variable "Editor Default Mode"))
+ (set-buffer-major-mode! buffer (ref-variable editor-default-mode))
(temporary-message "(New Buffer)")
buffer))))
-(define (prompt-for-buffer-name prompt default-buffer)
- (prompt-for-completed-string prompt
- (and default-buffer
- (buffer-name default-buffer))
- (if default-buffer
- 'VISIBLE-DEFAULT
- 'NO-DEFAULT)
- (buffer-names)
- 'PERMISSIVE-COMPLETION))
-
(define (prompt-for-existing-buffer prompt default-buffer)
- (find-buffer
- (prompt-for-completed-string prompt
+ (find-buffer (prompt-for-buffer-name prompt default-buffer true)))
+
+(define (prompt-for-buffer-name prompt default-buffer require-match?)
+ (prompt-for-string-table-name prompt
(and default-buffer
(buffer-name default-buffer))
- (if default-buffer
- 'VISIBLE-DEFAULT
- 'NO-DEFAULT)
+ (if default-buffer
+ 'VISIBLE-DEFAULT
+ 'NO-DEFAULT)
(buffer-names)
- 'STRICT-COMPLETION)))
\ No newline at end of file
+ require-match?))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.128 1989/03/15 19:09:51 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.129 1989/04/15 00:47:01 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
backed-up?
modification-time
)
-(define-variable "Buffer Creation Hook"
+(define-variable buffer-creation-hook
"If not false, a procedure to call when a new buffer is created.
The procedure is passed the new buffer as its argument.
The buffer is guaranteed to be deselected at that time."
false)
(define (make-buffer name #!optional mode)
- (let ((mode (if (default-object? mode) fundamental-mode mode)))
+ (let ((mode (if (default-object? mode) (ref-mode-object fundamental) mode)))
(let ((group (region-group (string->region ""))))
(let ((buffer (%make-buffer)))
(vector-set! buffer buffer-index:name name)
(enable-group-undo! group))
(vector-set! buffer
buffer-index:mark-ring
- (make-ring (ref-variable "Mark Ring Maximum")))
+ (make-ring (ref-variable mark-ring-maximum)))
(ring-push! (buffer-mark-ring buffer) (group-start-mark group))
(vector-set! buffer buffer-index:modes (list mode))
(vector-set! buffer buffer-index:comtabs (mode-comtabs mode))
(vector-set! buffer buffer-index:save-length 0)
(vector-set! buffer buffer-index:backed-up? false)
(vector-set! buffer buffer-index:modification-time false)
- (let ((hook (ref-variable "Buffer Creation Hook")))
+ (let ((hook (ref-variable buffer-creation-hook)))
(if hook (hook buffer)))
buffer))))
\f
\f
;;;; Local Bindings
-(define (make-local-binding! name #!optional new-value)
+(define (make-local-binding! variable new-value)
(without-interrupts
(lambda ()
(let ((buffer (current-buffer))
- (value (lexical-assignment variable-environment
- name
- (if (default-object? new-value)
- (unmap-reference-trap
- (make-unassigned-reference-trap))
- new-value))))
+ (old-value (variable-value variable)))
+ (set-variable-value! variable new-value)
(let ((bindings (buffer-local-bindings buffer)))
- (let ((binding (assq name bindings)))
+ (let ((binding (assq variable bindings)))
(if (not binding)
(vector-set! buffer
buffer-index:local-bindings
- (cons (cons name value) bindings))))))
+ (cons (cons variable old-value) bindings))))))
unspecific)))
-(define (unmake-local-binding! name)
+(define (unmake-local-binding! variable)
(without-interrupts
(lambda ()
(let ((buffer (current-buffer)))
(let ((bindings (buffer-local-bindings buffer)))
- (let ((binding (assq name bindings)))
+ (let ((binding (assq variable bindings)))
(if binding
(begin
- (lexical-assignment variable-environment
- name
- (cdr binding))
+ (set-variable-value! variable (cdr binding))
(vector-set! buffer
buffer-index:local-bindings
(delq! binding bindings)))))))
(lambda ()
(let ((buffer (current-buffer)))
(for-each (lambda (binding)
- (lexical-assignment variable-environment
- (car binding)
- (cdr binding)))
+ (set-variable-value! (car binding) (cdr binding)))
(buffer-local-bindings buffer))
(vector-set! buffer buffer-index:local-bindings '()))
unspecific)))
(define (%wind-local-bindings! buffer)
;; Assumes that interrupts are disabled and that BUFFER is selected.
(for-each (lambda (binding)
- (set-cdr! binding
- (lexical-assignment variable-environment
- (car binding)
- (cdr binding)))
+ (let ((variable (car binding)))
+ (let ((old-value (variable-value variable)))
+ (set-variable-value! variable (cdr binding))
+ (set-cdr! binding old-value)))
unspecific)
(buffer-local-bindings buffer)))\f
;;;; Modes
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffrm.scm,v 1.30 1989/03/30 16:39:21 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffrm.scm,v 1.31 1989/04/15 00:47:06 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(define-method buffer-frame (:minimum-x-size window)
(if (window-has-right-neighbor? window)
- (+ (ref-variable "Window Minimum Width")
+ (+ (ref-variable window-minimum-width)
(inferior-x-size border-inferior))
- (ref-variable "Window Minimum Width")))
+ (ref-variable window-minimum-width)))
(define-method buffer-frame (:minimum-y-size window)
(if modeline-inferior
- (+ (ref-variable "Window Minimum Height")
+ (+ (ref-variable window-minimum-height)
(inferior-y-size modeline-inferior))
- (ref-variable "Window Minimum Height")))
+ (ref-variable window-minimum-height)))
(define (buffer-frame-x-size frame)
(window-x-size (frame-text-inferior frame)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufmnu.scm,v 1.108 1989/03/14 07:58:57 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufmnu.scm,v 1.109 1989/04/15 00:47:13 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define-variable "Buffer Menu Kill on Quit"
+(define-variable buffer-menu-kill-on-quit
"If not false, kill the *Buffer-List* buffer when leaving it."
false)
-(define-command ("List Buffers")
+(define-command list-buffers
"Display a list of names of existing buffers."
- (pop-up-buffer (update-buffer-list) false))
+ ()
+ (lambda ()
+ (pop-up-buffer (update-buffer-list) false)))
-(define-command ("Buffer Menu")
+(define-command buffer-menu
"Display a list of names of existing buffers."
- (pop-up-buffer (update-buffer-list) true)
- (message "Commands: d, s, x; 1, 2, m, u, q; rubout; ? for help."))
+ ()
+ (lambda ()
+ (pop-up-buffer (update-buffer-list) true)
+ (message "Commands: d, s, x; 1, 2, m, u, q; rubout; ? for help.")))
(define (update-buffer-list)
(let ((buffer (temporary-buffer "*Buffer-List*")))
- (set-buffer-major-mode! buffer buffer-menu-mode)
+ (set-buffer-major-mode! buffer (ref-mode-object buffer-menu))
(buffer-put! buffer 'REVERT-BUFFER-METHOD revert-buffer-menu)
(fill-buffer-menu! buffer)
buffer))
-(define (revert-buffer-menu argument)
- argument ;ignore
- (let ((buffer (current-buffer)))
- (set-buffer-writeable! buffer)
- (region-delete! (buffer-region buffer))
- (fill-buffer-menu! buffer)))
+(define (revert-buffer-menu buffer dont-use-auto-save? dont-confirm?)
+ dont-use-auto-save? dont-confirm? ;ignore
+ (set-buffer-writeable! buffer)
+ (region-delete! (buffer-region buffer))
+ (fill-buffer-menu! buffer))
(define (fill-buffer-menu! buffer)
(with-output-to-mark (buffer-point buffer)
(buffer-name buffer)
(write-to-string
(group-length (buffer-group buffer)))
- (mode-name (buffer-major-mode buffer))
+ (mode-display-name (buffer-major-mode buffer))
(let ((truename (buffer-truename buffer)))
(if truename (pathname->string truename) ""))))
(newline))))
(set-buffer-point! buffer (line-start (buffer-start buffer) 2))
(set-buffer-read-only! buffer))
\f
-(define-major-mode "Buffer-Menu" "Fundamental"
+(define-major-mode buffer-menu fundamental "Buffer Menu"
"Major mode for editing a list of buffers.
Each line describes a buffer in the editor.
-M -- mark buffer to be displayed.
-Q -- select buffer of line point is in.
+m -- mark buffer to be displayed.
+q -- select buffer of line point is in.
1 -- select that buffer in full-screen window.
2 -- select that buffer in one window,
together with buffer selected before this one in another window.
-F -- select buffer of line point is in,
+f -- select buffer of line point is in,
leaving *Buffer-List* as the previous buffer.
-O -- like F, but select buffer in another window.
+o -- like f, but select buffer in another window.
~ -- clear modified-flag of that buffer.
-S -- mark that buffer to be saved.
-D or K or C-D or C-K -- mark that buffer to be killed.
-X -- kill or save marked buffers.
-U -- remove all kinds of marks from the current line.
-Rubout -- move up a line and remove marks.
-Space -- move down a line.
+s -- mark that buffer to be saved.
+d or k or C-d or C-k -- mark that buffer to be killed.
+x -- kill or save marked buffers.
+u -- remove all kinds of marks from the current line.
+DEL -- move up a line and remove marks.
+SPC -- move down a line.
C-] -- abort Buffer-Menu edit, killing *Buffer-List*.")
-(define-key "Buffer-Menu" #\M "^R Buffer Menu Mark")
-(define-key "Buffer-Menu" #\Q "^R Buffer Menu Quit")
-(define-key "Buffer-Menu" #\1 "^R Buffer Menu 1 Window")
-(define-key "Buffer-Menu" #\2 "^R Buffer Menu 2 Window")
-(define-key "Buffer-Menu" #\F "^R Buffer Menu Find")
-(define-key "Buffer-Menu" #\O "^R Buffer Menu Find Other Window")
-(define-key "Buffer-Menu" #\~ "^R Buffer Menu Not Modified")
-(define-key "Buffer-Menu" #\S "^R Buffer Menu Save")
-(define-key "Buffer-Menu" #\D "^R Buffer Menu Kill")
-(define-key "Buffer-Menu" #\K "^R Buffer Menu Kill")
-(define-key "Buffer-Menu" #\C-D "^R Buffer Menu Kill")
-(define-key "Buffer-Menu" #\C-K "^R Buffer Menu Kill")
-(define-key "Buffer-Menu" #\X "^R Buffer Menu Execute")
-(define-key "Buffer-Menu" #\U "^R Buffer Menu Unmark")
-(define-key "Buffer-Menu" #\Rubout "^R Buffer Menu Backup Unmark")
-(define-key "Buffer-Menu" #\Space "^R Buffer Menu Next")
-(define-key "Buffer-Menu" #\C-\] "^R Buffer Menu Abort")
-(define-key "Buffer-Menu" #\? "Describe Mode")
+(define-key 'buffer-menu #\m 'buffer-menu-mark)
+(define-key 'buffer-menu #\q 'buffer-menu-quit)
+(define-key 'buffer-menu #\1 'buffer-menu-1-window)
+(define-key 'buffer-menu #\2 'buffer-menu-2-window)
+(define-key 'buffer-menu #\f 'buffer-menu-this-window)
+(define-key 'buffer-menu #\o 'buffer-menu-other-window)
+(define-key 'buffer-menu #\~ 'buffer-menu-not-modified)
+(define-key 'buffer-menu #\s 'buffer-menu-save)
+(define-key 'buffer-menu #\d 'buffer-menu-delete)
+(define-key 'buffer-menu #\k 'buffer-menu-delete)
+(define-key 'buffer-menu #\c-d 'buffer-menu-delete)
+(define-key 'buffer-menu #\c-k 'buffer-menu-delete)
+(define-key 'buffer-menu #\x 'buffer-menu-execute)
+(define-key 'buffer-menu #\u 'buffer-menu-unmark)
+(define-key 'buffer-menu #\rubout 'buffer-menu-backup-unmark)
+(define-key 'buffer-menu #\space 'buffer-menu-next-line)
+(define-key 'buffer-menu #\c-\] 'buffer-menu-abort)
+(define-key 'buffer-menu #\? 'describe-mode)
\f
-(define-command ("^R Buffer Menu Mark" (argument 1))
- "Mark buffer on this line for being displayed by \\[^R Buffer Menu Quit] command."
- (set-multiple-marks! 0 #\> argument))
+(define-command buffer-menu-mark
+ "Mark buffer on this line for being displayed by \\[buffer-menu-quit] command."
+ "p"
+ (lambda (argument)
+ (set-multiple-marks! 0 #\> argument)))
-(define-command ("^R Buffer Menu Quit")
+(define-command buffer-menu-quit
"Select this line's buffer; also display buffers marked with >.
-You can mark buffers with the \\[^R Buffer Menu Mark] command."
- (let ((lstart (current-lstart))
- (window (current-window)))
- (let ((menu (window-buffer window))
- (buffer (buffer-menu-buffer lstart))
- (others (map buffer-menu-buffer (find-buffers-marked 0 #\>))))
- (if (and (ref-variable "Preserve Window Arrangement")
- (null? others))
- (buffer-menu-select menu buffer false)
- (begin
- (delete-other-windows window)
- (buffer-menu-select menu buffer (memq menu others))
- (let ((height (max (quotient (1+ (window-y-size window))
- (1+ (length others)))
- (1+ (ref-variable "Window Minimum Height")))))
- (define (loop window buffers)
- (let ((new (window-split-vertically! window height)))
- (if new
- (begin
- (set-window-buffer! new (car buffers) true)
- (loop new (cdr buffers))))))
- (loop window others))))))
- (clear-message))
-
-(define-command ("^R Buffer Menu 1 Window")
+You can mark buffers with the \\[buffer-menu-mark] command."
+ ()
+ (lambda ()
+ (let ((lstart (current-lstart))
+ (window (current-window)))
+ (let ((menu (window-buffer window))
+ (buffer (buffer-menu-buffer lstart))
+ (others (map buffer-menu-buffer (find-buffers-marked 0 #\>))))
+ (if (and (ref-variable preserve-window-arrangement)
+ (null? others))
+ (buffer-menu-select menu buffer false)
+ (begin
+ (delete-other-windows window)
+ (buffer-menu-select menu buffer (memq menu others))
+ (let ((height (max (quotient (1+ (window-y-size window))
+ (1+ (length others)))
+ (1+ (ref-variable window-minimum-height)))))
+ (define (loop window buffers)
+ (let ((new (window-split-vertically! window height)))
+ (if new
+ (begin
+ (set-window-buffer! new (car buffers) true)
+ (loop new (cdr buffers))))))
+ (loop window others))))))
+ (clear-message)))
+
+(define-command buffer-menu-1-window
"Select this line's buffer, alone, in full screen."
- (let ((window (current-window)))
- (delete-other-windows window)
- (buffer-menu-select (window-buffer window)
- (buffer-menu-buffer (current-lstart))
- false))
- (clear-message))
-
-(define-command ("^R Buffer Menu 2 Window")
+ ()
+ (lambda ()
+ (let ((window (current-window)))
+ (delete-other-windows window)
+ (buffer-menu-select (window-buffer window)
+ (buffer-menu-buffer (current-lstart))
+ false))
+ (clear-message)))
+
+(define-command buffer-menu-2-window
"Select this line's buffer, with previous buffer in second window."
- (buffer-menu-select (window-buffer (current-window))
- (buffer-menu-buffer (current-lstart))
- false)
- (fluid-let (((ref-variable "Pop Up Windows") true))
- (pop-up-buffer (previous-buffer)))
- (clear-message))
+ ()
+ (lambda ()
+ (buffer-menu-select (window-buffer (current-window))
+ (buffer-menu-buffer (current-lstart))
+ false)
+ (with-variable-value! (ref-variable-object pop-up-windows) true
+ (lambda ()
+ (pop-up-buffer (previous-buffer))))
+ (clear-message)))
\f
-(define-command ("^R Buffer Menu Find")
+(define-command buffer-menu-this-window
"Select this line's buffer."
- (buffer-menu-find select-buffer))
+ ()
+ (lambda ()
+ (buffer-menu-find select-buffer)))
-(define-command ("^R Buffer Menu Find Other Window")
+(define-command buffer-menu-other-window
"Select this line's buffer in another window."
- (buffer-menu-find select-buffer-other-window))
+ ()
+ (lambda ()
+ (buffer-menu-find select-buffer-other-window)))
(define (buffer-menu-find select-buffer)
(let ((buffer (buffer-menu-buffer (current-lstart))))
(select-buffer buffer)))
(clear-message))
-(define-command ("^R Buffer Menu Not Modified")
+(define-command buffer-menu-not-modified
"Mark buffer on this line as unmodified (no changes to save)."
- (buffer-not-modified! (buffer-menu-buffer (current-lstart)))
- (let ((lstart (current-lstart)))
- (if (char=? #\* (buffer-menu-mark lstart 1))
- (set-buffer-menu-mark! lstart 1 #\Space))))
-
-(define-command ("^R Buffer Menu Save" (argument 1))
+ ()
+ (lambda ()
+ (buffer-not-modified! (buffer-menu-buffer (current-lstart)))
+ (let ((lstart (current-lstart)))
+ (if (char=? #\* (buffer-menu-mark lstart 1))
+ (set-buffer-menu-mark! lstart 1 #\Space)))))
+
+(define-command buffer-menu-save
"Mark buffer on this line to be saved by X command."
- (set-multiple-marks! 1 #\S argument))
+ "p"
+ (lambda (argument)
+ (set-multiple-marks! 1 #\S argument)))
-(define-command ("^R Buffer Menu Kill" (argument 1))
+(define-command buffer-menu-delete
"Mark buffer on this line to be killed by X command."
- (set-multiple-marks! 0 #\K argument))
+ "p"
+ (lambda (argument)
+ (set-multiple-marks! 0 #\K argument)))
-(define-command ("^R Buffer Menu Execute")
- "Save and/or Kill buffers marked with \\[^R Buffer Menu Save] or \\[^R Buffer Menu Kill]."
- (buffer-menu-save-and-kill!))
+(define-command buffer-menu-execute
+ "Save and/or Kill buffers marked with \\[buffer-menu-save] or \\[buffer-menu-delete]."
+ ()
+ (lambda ()
+ (buffer-menu-save-and-kill!)))
-(define-command ("^R Buffer Menu Unmark")
+(define-command buffer-menu-unmark
"Remove all marks from this line."
- (let ((lstart (mark-right-inserting (current-lstart))))
- (let ((buffer (buffer-menu-buffer lstart)))
- (set-buffer-menu-mark! lstart 0 #\Space)
- (set-buffer-menu-mark! lstart 1
- (if (buffer-modified? buffer) #\* #\Space))))
- (set-current-point! (next-lstart)))
-
-(define-command ("^R Buffer Menu Backup Unmark")
+ ()
+ (lambda ()
+ (let ((lstart (mark-right-inserting (current-lstart))))
+ (let ((buffer (buffer-menu-buffer lstart)))
+ (set-buffer-menu-mark! lstart 0 #\Space)
+ (set-buffer-menu-mark! lstart 1
+ (if (buffer-modified? buffer) #\* #\Space))))
+ (set-current-point! (next-lstart))))
+
+(define-command buffer-menu-backup-unmark
"Remove all marks from the previous line."
- (set-current-point! (previous-lstart))
- (^r-buffer-menu-unmark-command)
- (set-current-point! (previous-lstart)))
+ ()
+ (lambda ()
+ (set-current-point! (previous-lstart))
+ ((ref-command buffer-menu-unmark))
+ (set-current-point! (previous-lstart))))
-(define-command ("^R Buffer Menu Next" (argument 1))
+(define-command buffer-menu-next-line
"Move down to the next line."
- (set-current-point! (line-start (current-point) argument 'BEEP)))
+ "p"
+ (lambda (argument)
+ (set-current-point! (line-start (current-point) argument 'BEEP))))
-(define-command ("^R Buffer Menu Abort")
+(define-command buffer-menu-abort
"Abort buffer menu edit."
- (kill-buffer-interactive (current-buffer))
- (clear-message))
+ ()
+ (lambda ()
+ (kill-buffer-interactive (current-buffer))
+ (clear-message)))
\f
(define (buffer-menu-select menu buffer needed?)
(select-buffer buffer)
(if (not (or (eq? menu buffer) needed?))
- (if (ref-variable "Buffer Menu Kill on Quit")
+ (if (ref-variable buffer-menu-kill-on-quit)
(kill-buffer-interactive menu)
(bury-buffer menu))))
(for-each buffer-menu-kill! (find-buffers-marked 0 #\K)))
(define (buffer-menu-save! lstart)
- (save-file (buffer-menu-buffer lstart))
+ (save-buffer (buffer-menu-buffer lstart))
(set-buffer-menu-mark! lstart 1 #\Space))
(define (buffer-menu-kill! lstart)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwin.scm,v 1.275 1989/03/14 07:59:06 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwin.scm,v 1.276 1989/04/15 00:47:24 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(if (not override-inferior)
(begin
(set! override-inferior (make-inferior window line-window))
- (set! inferiors (list override-inferior blank-inferior))
+ (set! inferiors
+ (list override-inferior cursor-inferior blank-inferior))
(set-inferior-start! override-inferior 0 0)))
- (set-line-window-string! (inferior-window override-inferior) message)
+ (let ((override-window (inferior-window override-inferior)))
+ (set-line-window-string! override-window message)
+ (let ((length (string-length message)))
+ (set-inferior-position!
+ cursor-inferior
+ (string-base:index->coordinates override-window length))))
(set-blank-inferior-start! window (inferior-y-end override-inferior))))
(define (clear-override-message! window)
(set! override-inferior false)
(set! inferiors
(cons* cursor-inferior blank-inferior line-inferiors))
+ (let ((coordinates (%window-mark->coordinates window point)))
+ (set-inferior-position! cursor-inferior coordinates)
+ (set-buffer-cursor-y! buffer (cdr coordinates)))
(blank-inferior-changed! window)
(for-each inferior-needs-redisplay! inferiors)))))
(define (maybe-recenter! window)
(with-instance-variables buffer-window window ()
- (let ((threshold (ref-variable "Cursor Centering Threshold")))
+ (let ((threshold (ref-variable cursor-centering-threshold)))
(if (zero? threshold)
(%window-redraw! window (%window-y-center window))
(if (< (mark-index point) (mark-index start-mark))
(string-base:index->y (inferior-window inferior)
(- index start))))
(fill-top! window (list inferior) start true))))))
-\f
+
(define (everything-changed! window if-not-visible)
(with-instance-variables buffer-window window (if-not-visible)
(no-outstanding-changes! window)
(start-mark-changed! window)
(end-mark-changed! window)
(update-cursor! window if-not-visible)))
-
+\f
(define (maybe-marks-changed! window inferiors y-end)
(with-instance-variables buffer-window window (inferiors y-end)
(no-outstanding-changes! window)
(define (%window-y-center window)
(with-instance-variables buffer-window window ()
- (let ((qr (integer-divide (* y-size cursor-centering-point) 100)))
+ (let ((qr
+ (integer-divide (* y-size (ref-variable cursor-centering-point))
+ 100)))
(if (< (integer-divide-remainder qr) 50)
(integer-divide-quotient qr)
(1+ (integer-divide-quotient qr))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/c-mode.scm,v 1.41 1989/03/14 07:59:30 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/c-mode.scm,v 1.42 1989/04/15 00:47:31 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define-command ("C Mode")
+(define-command c-mode
"Enter C mode."
- (set-current-major-mode! c-mode))
+ ()
+ (lambda ()
+ (set-current-major-mode! (ref-mode-object c))))
-(define-major-mode "C" "Fundamental"
+(define-major-mode c fundamental "C"
"Major mode for editing C code.
Expression and list commands understand all C brackets.
Tab indents for C code.
C Label Offset
Extra indentation for line that is a label, or case or default."
- (local-set-variable! "Syntax Table" c-mode:syntax-table)
- (local-set-variable! "Syntax Ignore Comments Backwards" true)
- (local-set-variable! "Paragraph Start" "^$")
- (local-set-variable! "Paragraph Separate" (ref-variable "Paragraph Start"))
- (local-set-variable! "Indent Line Procedure" c-indent-line-command)
- (local-set-variable! "Require Final Newline" true)
- (local-set-variable! "Comment Locator Hook" c-mode:comment-locate)
- (local-set-variable! "Comment Indent Hook" c-mode:comment-indent)
- (local-set-variable! "Comment Start" "/* ")
- (local-set-variable! "Comment End" " */")
- (local-set-variable! "Comment Column" 32)
- (if (ref-variable "C Mode Hook") ((ref-variable "C Mode Hook"))))
+ (local-set-variable! syntax-table c-mode:syntax-table)
+ (local-set-variable! syntax-ignore-comments-backwards true)
+ (local-set-variable! paragraph-start "^$")
+ (local-set-variable! paragraph-separate (ref-variable paragraph-start))
+ (local-set-variable! indent-line-procedure (ref-command c-indent-line))
+ (local-set-variable! require-final-newline true)
+ (local-set-variable! comment-locator-hook c-mode:comment-locate)
+ (local-set-variable! comment-indent-hook c-mode:comment-indent)
+ (local-set-variable! comment-start "/* ")
+ (local-set-variable! comment-end " */")
+ (local-set-variable! comment-column 32)
+ (if (ref-variable c-mode-hook) ((ref-variable c-mode-hook))))
\f
-(define-key "C" #\Linefeed "Reindent then Newline and Indent")
-(define-key "C" #\{ "Electric C Brace")
-(define-key "C" #\} "Electric C Brace")
-(define-key "C" #\; "Electric C Semi")
-(define-key "C" #\: "Electric C Terminator")
-(define-key "C" #\C-M-H "Mark C Function")
-(define-key "C" #\C-M-Q "C Indent Expression")
-(define-key "C" #\Rubout "^R Backward Delete Hacking Tabs")
-(define-key "C" #\Tab "C Indent Line")
+(define-key 'c #\linefeed 'reindent-then-newline-and-indent)
+(define-key 'c #\{ 'electric-c-brace)
+(define-key 'c #\} 'electric-c-brace)
+(define-key 'c #\; 'electric-c-semi)
+(define-key 'c #\: 'electric-c-terminator)
+(define-key 'c #\c-m-h 'mark-c-function)
+(define-key 'c #\c-m-q 'indent-c-function)
+(define-key 'c #\rubout 'backward-delete-char-untabify)
+(define-key 'c #\tab 'c-indent-line)
(define c-mode:syntax-table (make-syntax-table))
(modify-syntax-entry! c-mode:syntax-table #\\ "\\")
(if (re-match-forward "^/\\*" start (line-end start 0))
0
(max (1+ (mark-column (horizontal-space-start start)))
- (ref-variable "Comment Column"))))
+ (ref-variable comment-column))))
\f
-(define-command ("Electric C Brace" argument)
+(define-command electric-c-brace
"Insert character and correct line's indentation."
- (let ((point (current-point)))
- (if (and (not argument)
- (line-end? point)
- (or (line-blank? point)
- (and (ref-variable "C Auto Newline")
- (begin (c-indent-line-command false)
- (insert-newline)
- true))))
- (begin (^r-insert-self-command false)
- (c-indent-line-command false)
- (if (ref-variable "C Auto Newline")
- (begin (insert-newline)
- (c-indent-line-command false))))
- (^r-insert-self-command argument))))
+ "P"
+ (lambda (argument)
+ (let ((point (current-point)))
+ (if (and (not argument)
+ (line-end? point)
+ (or (line-blank? point)
+ (and (ref-variable c-auto-newline)
+ (begin
+ ((ref-command c-indent-line) false)
+ (insert-newline)
+ true))))
+ (begin
+ ((ref-command self-insert-command) false)
+ ((ref-command c-indent-line) false)
+ (if (ref-variable c-auto-newline)
+ (begin
+ (insert-newline)
+ ((ref-command c-indent-line) false))))
+ ((ref-command self-insert-command) false)))))
-(define-command ("Electric C Semi" argument)
+(define-command electric-c-semi
"Insert character and correct line's indentation."
- (if (ref-variable "C Auto Newline")
- (electric-c-terminator-command argument)
- (^r-insert-self-command argument)))
+ "P"
+ (lambda (argument)
+ (if (ref-variable c-auto-newline)
+ ((ref-command electric-c-terminator) argument)
+ ((ref-command self-insert-command) argument))))
-(define-command ("Electric C Terminator" argument)
+(define-command electric-c-terminator
"Insert character and correct line's indentation."
- (let ((point (current-point)))
- (if (and (not argument)
- (line-end? point)
- (not (let ((mark (indentation-end point)))
- (or (char-match-forward #\# mark)
- (let ((state (parse-partial-sexp mark point)))
- (or (parse-state-in-string? state)
- (parse-state-in-comment? state)
- (parse-state-quoted? state)))))))
- (begin
- (^r-insert-self-command false)
- (c-indent-line-command false)
- (if (and (ref-variable "C Auto Newline")
- (not (c-inside-parens? point)))
- (begin
- (insert-newline)
- (c-indent-line-command false))))
- (^r-insert-self-command argument))))
-
-(define-command ("Mark C Procedure")
+ "P"
+ (lambda (argument)
+ (let ((point (current-point)))
+ (if (and (not argument)
+ (line-end? point)
+ (not (let ((mark (indentation-end point)))
+ (or (char-match-forward #\# mark)
+ (let ((state (parse-partial-sexp mark point)))
+ (or (parse-state-in-string? state)
+ (parse-state-in-comment? state)
+ (parse-state-quoted? state)))))))
+ (begin
+ ((ref-command self-insert-command) false)
+ ((ref-command c-indent-line) false)
+ (if (and (ref-variable c-auto-newline)
+ (not (c-inside-parens? point)))
+ (begin
+ (insert-newline)
+ ((ref-command c-indent-line) false))))
+ ((ref-command self-insert-command) argument)))))
+\f
+(define-command mark-c-procedure
"Put mark at end of C procedure, point at beginning."
- (push-current-mark! (current-point))
- (let ((end (forward-definition-end (current-point) 1 'LIMIT)))
- (push-current-mark! end)
- (set-current-point!
- (backward-paragraph (backward-definition-start end 1 'LIMIT) 1 'LIMIT))))
+ ()
+ (lambda ()
+ (push-current-mark! (current-point))
+ (let ((end (forward-definition-end (current-point) 1 'LIMIT)))
+ (push-current-mark! end)
+ (set-current-point!
+ (backward-paragraph (backward-definition-start end 1 'LIMIT)
+ 1
+ 'LIMIT)))))
-(define-command ("C Indent Line" argument)
+(define-command c-indent-line
"Indent current line as C code.
Argument means shift any additional lines of grouping
rigidly with this line."
- (let ((start (line-start (current-point) 0)))
- (let ((indentation (c-indent-line:indentation start)))
- (let ((shift-amount (- indentation (mark-indentation start))))
- (cond ((not (zero? shift-amount))
- (change-indentation indentation start)
- (if argument
- (indent-code-rigidly start
- (forward-sexp start 1 'ERROR)
- shift-amount
- "#")))
- ((within-indentation? (current-point))
- (set-current-point! (indentation-end (current-point)))))))))
+ "P"
+ (lambda (#!optional argument)
+ (let ((argument (and (not (default-object? argument)) argument))
+ (start (line-start (current-point) 0)))
+ (let ((indentation (c-indent-line:indentation start)))
+ (let ((shift-amount (- indentation (mark-indentation start))))
+ (cond ((not (zero? shift-amount))
+ (change-indentation indentation start)
+ (if argument
+ (indent-code-rigidly start
+ (forward-sexp start 1 'ERROR)
+ shift-amount
+ "#")))
+ ((within-indentation? (current-point))
+ (set-current-point! (indentation-end (current-point))))))))))
-(define-command ("C Indent Expression")
+(define-command c-indent-expression
"Indent each line of the C grouping following point."
- (c-indent-expression (current-point)))
\ No newline at end of file
+ ()
+ (lambda ()
+ (c-indent-expression (current-point))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/cinden.scm,v 1.1 1989/03/14 07:59:36 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/cinden.scm,v 1.2 1989/04/15 00:47:37 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(maybe-change-indentation (c-indent-line:indentation start) start))
(define (c-indent-line:indentation start)
- (fluid-let (((ref-variable "Case Fold Search") false))
- (let ((indentation (calculate-indentation start false)))
- (cond ((not indentation) (mark-indentation start))
- ((eq? indentation true)
- ;; Inside a comment; indentation of line depends on
- ;; whether or not it starts with a *.
- (mark-column
- (let ((end (whitespace-start start (group-start start))))
- (let ((iend (indentation-end end)))
- (let ((comstart (re-search-forward "/\\*[ \t]*" iend end)))
- (cond ((not comstart) iend)
- ((re-match-forward "[ \t]*\\*" start)
- (mark1+ (re-match-start 0)))
- (else comstart)))))))
- ((char-match-forward #\# start) 0)
- (else
- (indent-line:adjust-indentation (horizontal-space-end start)
- indentation))))))
+ (with-variable-value! (ref-variable-object case-fold-search) false
+ (lambda ()
+ (let ((indentation (calculate-indentation start false)))
+ (cond ((not indentation) (mark-indentation start))
+ ((eq? indentation true)
+ ;; Inside a comment; indentation of line depends on
+ ;; whether or not it starts with a *.
+ (mark-column
+ (let ((end (whitespace-start start (group-start start))))
+ (let ((iend (indentation-end end)))
+ (let ((comstart (re-search-forward "/\\*[ \t]*" iend end)))
+ (cond ((not comstart) iend)
+ ((re-match-forward "[ \t]*\\*" start)
+ (mark1+ (re-match-start 0)))
+ (else comstart)))))))
+ ((char-match-forward #\# start) 0)
+ (else
+ (indent-line:adjust-indentation (horizontal-space-end start)
+ indentation)))))))
(define (indent-line:adjust-indentation start indentation)
(cond ((or (re-match-forward "case\\b" start)
(and (re-match-forward "[A-Za-z]" start)
(char-match-forward #\: (forward-one-sexp start))))
- (max 1 (+ indentation (ref-variable "C Label Offset"))))
+ (max 1 (+ indentation (ref-variable c-label-offset))))
((re-match-forward "else\\b" start)
(mark-indentation
(backward-to-start-of-if start
(backward-one-definition-start start))))
((char-match-forward #\} start)
- (- indentation (ref-variable "C Indent Level")))
+ (- indentation (ref-variable c-indent-level)))
((char-match-forward #\{ start)
- (+ indentation (ref-variable "C Brace Offset")))
+ (+ indentation (ref-variable c-brace-offset)))
(else indentation)))
\f
(define (calculate-indentation mark parse-start)
(or parse-start
gstart))))
(if (char-match-backward #\) mark)
- (ref-variable "C Argdecl Indent")
+ (ref-variable c-argdecl-indent)
(mark-indentation mark)))))
((char-match-forward #\{ container)
(calculate-indentation:statement indent-point container))
;; This line is continuation of preceding line's statement;
;; indent C Continued Statement Offset more than the previous
;; line of the statement.
- (+ (ref-variable "C Continued Statement Offset")
+ (+ (ref-variable c-continued-statement-offset)
(mark-column (backward-to-start-of-continued-exp mark container)))
(let ((mark (skip-comments&labels (mark1+ container) indent-point)))
(if (not mark)
;; not the first thing in a line, add in C Brace
;; Imaginary Offset.
(+ (if (and (line-start? container)
- (zero? (ref-variable "C Indent Level")))
- (+ (ref-variable "C Brace Offset")
- (ref-variable "C Continued Statement Offset"))
- (ref-variable "C Indent Level"))
+ (zero? (ref-variable c-indent-level)))
+ (+ (ref-variable c-brace-offset)
+ (ref-variable c-continued-statement-offset))
+ (ref-variable c-indent-level))
(+ (if (within-indentation? container)
0
- (ref-variable "C Brace Imaginary Offset"))
+ (ref-variable c-brace-imaginary-offset))
(mark-indentation container)))
;; Otherwise, indent under that first statement.
(mark-column mark))))))
(phi2 (backward-sexp start 1 'LIMIT) 1))
\f
(define (c-indent-expression expression-start)
- (fluid-let (((ref-variable "Case Fold Search") false))
- (let ((end (mark-left-inserting (line-start (forward-sexp expression-start
- 1 'ERROR)
- 0))))
- (define (loop start indent-stack contain-stack last-depth)
- (next-line-start start false
- (lambda (start state)
- (let ((depth-delta (- (parse-state-depth state) last-depth)))
- (let ((indent-stack (adjust-stack depth-delta indent-stack))
- (contain-stack (adjust-stack depth-delta contain-stack)))
- (if (not (car contain-stack))
- (set-car! contain-stack
- (or (parse-state-containing-sexp state)
- (backward-one-sexp start))))
- (if (not (line-blank? start))
- (indent-line start indent-stack contain-stack))
- (if (not (mark= start end))
- (loop start indent-stack contain-stack
- (parse-state-depth state))))))))
+ (with-variable-value! (ref-variable-object case-fold-search) false
+ (lambda ()
+ (let ((end
+ (mark-left-inserting
+ (line-start (forward-sexp expression-start 1 'ERROR) 0))))
+ (define (loop start indent-stack contain-stack last-depth)
+ (next-line-start start false
+ (lambda (start state)
+ (let ((depth-delta (- (parse-state-depth state) last-depth)))
+ (let ((indent-stack (adjust-stack depth-delta indent-stack))
+ (contain-stack (adjust-stack depth-delta contain-stack)))
+ (if (not (car contain-stack))
+ (set-car! contain-stack
+ (or (parse-state-containing-sexp state)
+ (backward-one-sexp start))))
+ (if (not (line-blank? start))
+ (indent-line start indent-stack contain-stack))
+ (if (not (mark= start end))
+ (loop start indent-stack contain-stack
+ (parse-state-depth state))))))))
- (define (next-line-start start state receiver)
- (define (loop start state)
- (let ((start* (line-start start 1)))
- (let ((state*
- (parse-partial-sexp start start* false false state)))
- (if (and state (parse-state-in-comment? state))
- (c-indent-line start))
- (cond ((mark= start* end)
- (receiver start* state*))
- ((parse-state-in-comment? state*)
- (if (not (and state (parse-state-in-comment? state)))
- (if (re-search-forward "/\\*[ \t]*" start start*)
- (c-mode:comment-indent (re-match-start 0))
- (error "C-Indent-Expression: Missing comment")))
- (loop start* state*))
- ((parse-state-in-string? state*)
- (loop start* state*))
- (else
- (receiver start* state*))))))
- (loop start state))
+ (define (next-line-start start state receiver)
+ (let loop ((start start) (state state))
+ (let ((start* (line-start start 1)))
+ (let ((state*
+ (parse-partial-sexp start start* false false state)))
+ (if (and state (parse-state-in-comment? state))
+ (c-indent-line start))
+ (cond ((mark= start* end)
+ (receiver start* state*))
+ ((parse-state-in-comment? state*)
+ (if (not (and state (parse-state-in-comment? state)))
+ (if (re-search-forward "/\\*[ \t]*" start start*)
+ (c-mode:comment-indent (re-match-start 0))
+ (error "C-Indent-Expression: Missing comment")))
+ (loop start* state*))
+ ((parse-state-in-string? state*)
+ (loop start* state*))
+ (else
+ (receiver start* state*)))))))
- (define (indent-line start indent-stack contain-stack)
- (let ((indentation
- (indent-line:adjust-indentation
- start
- (if (car indent-stack)
- (if (char-match-forward #\{ (car contain-stack))
- ;; Line is at statement level. Is it a new
- ;; statement? Is it an else? Find last
- ;; non-comment character before this line.
- (let ((mark
- (backward-to-noncomment
- start expression-start)))
- (cond ((not (memv (extract-left-char mark)
- '(#F #\. #\; #\} #\:)))
- (+ (ref-variable
- "C Continued Statement Offset")
- (mark-column
- (backward-to-start-of-continued-exp
- mark (car contain-stack)))))
- ((re-match-forward "else\\b" start)
- (mark-indentation
- (backward-to-start-of-if mark
- expression-start)))
- (else (car indent-stack))))
- (car indent-stack))
- (let ((indentation (calculate-indentation start false)))
- (set-car! indent-stack indentation)
- indentation)))))
- (if (not (or (= indentation (mark-indentation start))
- (re-match-forward "[ \t]*#" start)))
- (change-indentation indentation start))))
+ (define (indent-line start indent-stack contain-stack)
+ (let ((indentation
+ (indent-line:adjust-indentation
+ start
+ (if (car indent-stack)
+ (if (char-match-forward #\{ (car contain-stack))
+ ;; Line is at statement level. Is it a new
+ ;; statement? Is it an else? Find last
+ ;; non-comment character before this line.
+ (let ((mark
+ (backward-to-noncomment
+ start expression-start)))
+ (cond ((not (memv (extract-left-char mark)
+ '(#F #\. #\; #\} #\:)))
+ (+ (ref-variable
+ c-continued-statement-offset)
+ (mark-column
+ (backward-to-start-of-continued-exp
+ mark (car contain-stack)))))
+ ((re-match-forward "else\\b" start)
+ (mark-indentation
+ (backward-to-start-of-if
+ mark
+ expression-start)))
+ (else (car indent-stack))))
+ (car indent-stack))
+ (let ((indentation (calculate-indentation start false)))
+ (set-car! indent-stack indentation)
+ indentation)))))
+ (if (not (or (= indentation (mark-indentation start))
+ (re-match-forward "[ \t]*#" start)))
+ (change-indentation indentation start))))
- (loop expression-start (list false) (list expression-start) 0))))
+ (loop expression-start (list false) (list expression-start) 0)))))
\f
(define (adjust-stack depth-delta indent-stack)
(cond ((zero? depth-delta) indent-stack)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/class.scm,v 1.67 1989/03/14 07:59:37 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/class.scm,v 1.68 1989/04/15 00:47:44 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(class-methods/ref (class-methods class) name))
(define (class-methods/ref methods name)
- (or (method-lookup methods name)
- (error "unknown method" name)))
+ (or (method-lookup methods name) (error "unknown method" name)))
(define (method-lookup methods name)
(let loop ((methods methods))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comman.scm,v 1.56 1989/03/14 07:59:42 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comman.scm,v 1.57 1989/04/15 00:47:49 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(define-named-structure "Command"
name
description
+ interactive-specification
procedure)
-(define (make-command name description procedure)
+(define (command-name-string command)
+ (editor-name/internal->external (symbol->string (command-name command))))
+
+(define (editor-name/internal->external string)
+ string)
+
+(define (editor-name/external->internal string)
+ string)
+
+(define (make-command name description specification procedure)
(let ((command
- (or (string-table-get editor-commands name)
- (let ((command (%make-command)))
- (string-table-put! editor-commands name command)
- command))))
+ (let ((name (symbol->string name)))
+ (or (string-table-get editor-commands name)
+ (let ((command (%make-command)))
+ (string-table-put! editor-commands name command)
+ command)))))
(vector-set! command command-index:name name)
(vector-set! command command-index:description description)
+ (vector-set! command command-index:interactive-specification specification)
(vector-set! command command-index:procedure procedure)
command))
(make-string-table 500))
(define (name->command name)
- (or (string-table-get editor-commands name)
- (make-command name
- ""
- (lambda (#!optional argument)
- argument ;ignore
- (editor-error "Undefined command: \"" name "\"")))))
-
+ (let ((name (canonicalize-name name)))
+ (or (string-table-get editor-commands (symbol->string name))
+ (letrec ((command
+ (make-command
+ name
+ "undefined command"
+ '()
+ (lambda ()
+ (editor-error "Undefined command: "
+ (command-name-string command))))))
+ command))))
+\f
(define-named-structure "Variable"
name
description
- symbol)
+ value)
+
+(define (variable-name-string variable)
+ (editor-name/internal->external (symbol->string (variable-name variable))))
-(define (make-variable name description symbol)
+(define (make-variable name description value)
(let ((variable
- (or (string-table-get editor-variables name)
- (let ((variable (%make-variable)))
- (string-table-put! editor-variables name variable)
- variable))))
+ (let ((name (symbol->string name)))
+ (or (string-table-get editor-variables name)
+ (let ((variable (%make-variable)))
+ (string-table-put! editor-variables name variable)
+ variable)))))
(vector-set! variable variable-index:name name)
(vector-set! variable variable-index:description description)
- (vector-set! variable variable-index:symbol symbol)
+ (vector-set! variable variable-index:value value)
variable))
(define editor-variables
(make-string-table 50))
(define (name->variable name)
- (or (string-table-get editor-variables name)
- (make-variable name "" 'UNASSIGNED-VARIABLE)))
-
-(define-integrable (variable-ref variable)
- (lexical-reference variable-environment (variable-symbol variable)))
-
-(define (variable-set! variable #!optional value)
- (lexical-assignment variable-environment
- (variable-symbol variable)
- (if (default-object? value)
- (unmap-reference-trap
- (make-unassigned-reference-trap))
- value)))
-
-(define-integrable (variable-unbound? variable)
- (lexical-unbound? variable-environment (variable-symbol variable)))
-
-(define-integrable (variable-unassigned? variable)
- (lexical-unassigned? variable-environment (variable-symbol variable)))
-
-(define variable-environment
- (->environment '(EDWIN)))
\ No newline at end of file
+ (let ((name (canonicalize-name name)))
+ (or (string-table-get editor-variables (symbol->string name))
+ (make-variable name "" false))))
+(define-integrable (set-variable-value! variable value) (vector-set! variable variable-index:value value)
+ unspecific)
+(define (with-variable-value! variable new-value thunk)
+ (let ((old-value))
+ (dynamic-wind (lambda ()
+ (set! old-value (variable-value variable))
+ (set-variable-value! variable new-value)
+ (set! new-value)
+ unspecific)
+ thunk
+ (lambda ()
+ (set! new-value (variable-value variable))
+ (set-variable-value! variable old-value)
+ (set! old-value)
+ unspecific))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comred.scm,v 1.71 1989/03/14 07:59:44 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comred.scm,v 1.72 1989/04/15 00:47:54 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
+(define *command-continuation*) ;Continuation of current command
+(define *command-char*) ;Character read to find current command
+(define *command*) ;The current command
+(define *command-message*) ;Message from last command
+(define *next-message*) ;Message to next command
+(define *non-undo-count*) ;# of self-inserts since last undo boundary
+(define keyboard-chars-read) ;# of chars read from keyboard
+(define command-history)
+(define command-history-limit 30)
+
+(define (initialize-command-reader!)
+ (set! keyboard-chars-read 0)
+ (set! command-history (make-circular-list command-history-limit false))
+ unspecific)
+
+(define (command-history-list)
+ (let loop ((history command-history))
+ (if (car history)
+ (let loop ((history (cdr history)) (result (list (car history))))
+ (if (eq? history command-history)
+ result
+ (loop (cdr history) (cons (car history) result))))
+ (let ((history (cdr history)))
+ (if (eq? history command-history)
+ '()
+ (loop history))))))
+
(define (top-level-command-reader)
(let loop ()
(with-keyboard-macro-disabled
command-reader)))
(loop)))
-(define *command-continuation*) ;Continuation of current command
-(define *command-char*) ;Character read to find current command
-(define *command*) ;The current command
-(define *command-message*) ;Message from last command
-(define *next-message*) ;Message to next command
-(define *non-undo-count*) ;# of self-inserts since last undo boundary
-
(define (command-reader)
(define (command-reader-loop)
(let ((value
(define (start-next-command)
(reset-command-state!)
- (let ((char (keyboard-read-char)))
+ (let ((char (with-editor-interrupts-disabled keyboard-read-char)))
(set! *command-char* char)
(set-command-prompt! (char-name char))
(let ((window (current-window)))
(reset-command-state!)
(dispatch-on-command command))
-(define-integrable (read-and-dispatch-on-char)
- (dispatch-on-char (current-comtabs) (keyboard-read-char)))
+(define-integrable (read-and-dispatch-on-char) (dispatch-on-char (current-comtabs)
+ (with-editor-interrupts-disabled keyboard-read-char)))
(define (dispatch-on-char comtab char)
(set! *command-char* char)
(if (and *command-message*
(eq? (car *command-message*) tag))
(apply if-received (cdr *command-message*))
- (if-not-received)))
-\f
+ (if-not-received)))\f
(define (%dispatch-on-command window command)
(set! *command* command)
- (let ((procedure (command-procedure command))
- (argument (command-argument-standard-value)))
- (if (or argument
- *executing-keyboard-macro?*
- (window-needs-redisplay? window))
+ (guarantee-command-loaded command)
+ (let ((procedure (command-procedure command)))
+ (let ((normal
+ (lambda ()
+ (apply procedure (interactive-arguments command false)))))
+ (if (or *executing-keyboard-macro?*
+ (window-needs-redisplay? window)
+ (command-argument-standard-value?))
+ (begin
+ (set! *non-undo-count* 0)
+ (normal))
+ (let ((point (window-point window))
+ (point-x (window-point-x window)))
+ (if (or (eq? procedure (ref-command self-insert-command))
+ (and (eq? procedure (ref-command auto-fill-space))
+ (not (auto-fill-break? point)))
+ (command-argument-self-insert? procedure))
+ (let ((char *command-char*))
+ (if (let ((buffer (window-buffer window)))
+ (and (buffer-auto-save-modified? buffer)
+ (null? (cdr (buffer-windows buffer)))
+ (line-end? point)
+ (char-graphic? char)
+ (< point-x (-1+ (window-x-size window)))))
+ (begin
+ (if (or (zero? *non-undo-count*)
+ (>= *non-undo-count* 20))
+ (begin
+ (undo-boundary! point)
+ (set! *non-undo-count* 0)))
+ (set! *non-undo-count* (1+ *non-undo-count*))
+ (window-direct-output-insert-char! window char))
+ (region-insert-char! point char)))
+ (begin
+ (set! *non-undo-count* 0)
+ (cond ((eq? procedure (ref-command forward-char))
+ (if (and (not (group-end? point))
+ (char-graphic? (mark-right-char point))
+ (< point-x (- (window-x-size window) 2)))
+ (window-direct-output-forward-char! window)
+ (normal)))
+ ((eq? procedure (ref-command backward-char))
+ (if (and (not (group-start? point))
+ (char-graphic? (mark-left-char point))
+ (positive? point-x)) (window-direct-output-backward-char! window)
+ (normal)))
+ (else
+ (if (not (typein-window? window))
+ (undo-boundary! point))
+ (normal))))))))))\f
+(define (interactive-arguments command record?)
+ (let ((specification (command-interactive-specification command))
+ (record-command-arguments
+ (lambda (arguments)
+ (let ((history command-history))
+ (set-car! history (cons (command-name command) arguments))
+ (set! command-history (cdr history))))))
+ (cond ((string? specification)
+ (with-values
+ (lambda ()
+ (let ((end (string-length specification)))
+ (let loop
+ ((index
+ (if (and (not (zero? end))
+ (char=? #\* (string-ref specification 0)))
+ (begin
+ (if (buffer-read-only? (current-buffer))
+ (barf-if-read-only))
+ 1)
+ 0)))
+ (if (< index end)
+ (let ((newline
+ (substring-find-next-char specification
+ index
+ end
+ #\newline)))
+ (with-values
+ (lambda ()
+ (interactive-argument
+ (string-ref specification index)
+ (substring specification
+ (1+ index)
+ (or newline end))))
+ (lambda (argument expression from-tty?)
+ (with-values
+ (lambda ()
+ (if newline
+ (loop (1+ newline))
+ (values '() '() false)))
+ (lambda (arguments expressions any-from-tty?)
+ (values (cons argument arguments)
+ (cons expression expressions)
+ (or from-tty? any-from-tty?)))))))
+ (values '() '() false)))))
+ (lambda (arguments expressions any-from-tty?)
+ (if (or record?
+ (and any-from-tty?
+ (not (prefix-char-list? (current-comtabs)
+ (current-command-char)))))
+ (record-command-arguments expressions))
+ arguments)))
+ ((null? specification)
+ (if record?
+ (record-command-arguments '()))
+ '())
+ (else
+ (let ((old-chars-read keyboard-chars-read))
+ (let ((arguments (specification)))
+ (if (or record?
+ (not (= keyboard-chars-read old-chars-read))) (record-command-arguments (map quotify-sexp arguments)))
+ arguments))))))
+
+(define (execute-command-history-entry entry)
+ (let ((history command-history))
+ (if (not (equal? entry
+ (let loop ((entries (cdr history)) (tail history))
+ (if (eq? entries history)
+ (car tail)
+ (loop (cdr entries) entries)))))
(begin
- (set! *non-undo-count* 0)
- (procedure argument))
- (let ((point (window-point window))
- (point-x (window-point-x window)))
- (if (or (eq? procedure ^r-insert-self-command)
- (and (eq? procedure ^r-auto-fill-space-command)
- (not (auto-fill-break? point)))
- (command-argument-self-insert? procedure))
- (if (let ((buffer (window-buffer window)))
- (and (buffer-auto-save-modified? buffer)
- (null? (cdr (buffer-windows buffer)))
- (line-end? point)
- (char-graphic? *command-char*)
- (< point-x (-1+ (window-x-size window)))))
- (begin
- (if (or (zero? *non-undo-count*)
- (>= *non-undo-count* 20))
- (begin
- (undo-boundary! point)
- (set! *non-undo-count* 0)))
- (set! *non-undo-count* (1+ *non-undo-count*))
- (window-direct-output-insert-char! window *command-char*))
- (region-insert-char! point *command-char*))
- (begin
- (set! *non-undo-count* 0)
- (cond ((eq? procedure ^r-forward-character-command)
- (if (and (not (group-end? point))
- (char-graphic? (mark-right-char point))
- (< point-x (- (window-x-size window) 2)))
- (window-direct-output-forward-char! window)
- (procedure argument)))
- ((eq? procedure ^r-backward-character-command)
- (if (and (not (group-start? point))
- (char-graphic? (mark-left-char point))
- (positive? point-x))
- (window-direct-output-backward-char! window)
- (procedure argument)))
- (else
- (if (not (typein-window? window))
- (undo-boundary! point))
- (procedure argument)))))))))
\ No newline at end of file
+ (set-car! history entry)
+ (set! command-history (cdr history)))))
+ (apply (command-procedure (name->command (car entry)))
+ (map (let ((environment (->environment '(EDWIN))))
+ (lambda (expression)
+ (eval expression environment))) (cdr entry))))
+\f
+(define (interactive-argument char prompt)
+ (let ((prompting
+ (lambda (value)
+ (values value (quotify-sexp value) true)))
+ (prefix
+ (lambda (prefix)
+ (values prefix (quotify-sexp prefix) false)))
+ (varies
+ (lambda (value expression)
+ (values value expression false))))
+ (case char
+ ((#\b)
+ (prompting
+ (buffer-name (prompt-for-existing-buffer prompt (current-buffer)))))
+ ((#\B)
+ (prompting (buffer-name (prompt-for-buffer prompt (current-buffer)))))
+ ((#\c)
+ (prompting (prompt-for-char prompt)))
+ ((#\C)
+ (prompting (command-name (prompt-for-command prompt))))
+ ((#\d)
+ (varies (current-point) '(CURRENT-POINT)))
+ ((#\D)
+ (prompting
+ (pathname->string
+ (prompt-for-directory prompt (current-default-pathname)))))
+ ((#\f)
+ (prompting
+ (pathname->string
+ (prompt-for-input-truename prompt (current-default-pathname)))))
+ ((#\F)
+ (prompting
+ (pathname->string
+ (prompt-for-pathname prompt (current-default-pathname)))))
+ ((#\k)
+ (prompting (prompt-for-key prompt (current-comtabs))))
+ ((#\m)
+ (varies (current-mark) '(CURRENT-MARK)))
+ ((#\n)
+ (prompting (prompt-for-number prompt false)))
+ ((#\N)
+ (prefix
+ (or (command-argument-standard-value)
+ (prompt-for-number prompt false))))
+ ((#\p)
+ (prefix (or (command-argument-standard-value) 1)))
+ ((#\P)
+ (prefix (command-argument-standard-value)))
+ ((#\r)
+ (varies (current-region) '(CURRENT-REGION)))
+ ((#\s)
+ (prompting (or (prompt-for-string prompt false) ""))) ((#\v)
+ (prompting (variable-name (prompt-for-variable prompt))))
+ ((#\x)
+ (prompting (prompt-for-expression prompt false)))
+ ((#\X)
+ (prompting (prompt-for-expression-value prompt false))) (else
+ (editor-error "Invalid control letter "
+ char
+ " in interactive calling string")))))
+
+(define (quotify-sexp sexp)
+ (if (or (boolean? sexp)
+ (number? sexp)
+ (string? sexp)
+ (char? sexp))
+ sexp
+ `(QUOTE ,sexp)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comtab.scm,v 1.50 1989/03/14 07:59:53 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comtab.scm,v 1.51 1989/04/15 00:48:01 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(define-structure (comtab (constructor make-comtab ()))
(dispatch-alists (cons '() '()) read-only true))
-(define (remap-char char)
- (char-upcase (remap-alias-char char)))
-
(define (set-comtab-entry! alists char command)
- (let ((char (remap-char char)))
+ (let ((char (remap-alias-char char)))
(let ((entry (assq char (cdr alists))))
(if entry
(set-cdr! entry command)
unspecific)
(define (make-prefix-char! alists char alists*)
- (let ((char (remap-char char)))
+ (let ((char (remap-alias-char char)))
(let ((entry (assq char (car alists))))
(if entry
(set-cdr! entry alists*)
(define (comtab-lookup-prefix comtabs char receiver #!optional if-undefined)
(define (loop char->alist chars)
- (let ((entry (assq (remap-char (car chars)) char->alist)))
+ (let ((entry (assq (remap-alias-char (car chars)) char->alist)))
(if entry
(if (null? (cddr chars))
(receiver (cdr entry) (cadr chars))
(else (cadr comtabs))))))
(comtab-lookup-prefix comtabs xchar
(lambda (alists char)
- (let ((entry (assq (remap-char char) (cdr alists))))
+ (let ((entry (assq (remap-alias-char char) (cdr alists))))
(if entry
(cdr entry)
(continue))))
continue)))
(define bad-command
- (name->command "^R Bad Command"))
+ (name->command '^r-bad-command))
(define (prefix-char-list? comtabs chars)
(let loop
((char->alist (car (comtab-dispatch-alists (car comtabs))))
- (chars chars))
+ (chars (if (list? chars) chars (list chars))))
(or (null? chars)
- (let ((entry (assq (remap-char (car chars)) char->alist)))
+ (let ((entry (assq (remap-alias-char (car chars)) char->alist)))
(if entry
(loop (cadr entry) (cdr chars))
(and (not (null? (cdr comtabs)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/curren.scm,v 1.80 1989/03/14 08:00:13 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/curren.scm,v 1.81 1989/04/15 00:48:10 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(define-integrable (set-buffer-mark! buffer mark)
(ring-set! (buffer-mark-ring buffer) 0 (mark-right-inserting mark)))
-(define-variable "Auto Push Point Notification"
+(define-variable auto-push-point-notification
"Message to display when point is pushed on the mark ring, or false."
"Mark Set")
(define (push-current-mark! mark)
(guarantee-mark mark 'PUSH-CURRENT-MARK!)
(push-buffer-mark! (current-buffer) mark)
- (let ((notification (ref-variable "Auto Push Point Notification")))
+ (let ((notification (ref-variable auto-push-point-notification)))
(if (and notification
(not *executing-keyboard-macro?*)
(not (typein-window? (current-window))))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/debuge.scm,v 1.35 1989/03/14 08:00:20 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/debuge.scm,v 1.36 1989/04/15 00:48:15 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(set-buffer-truename! buffer truename)
(buffer-not-modified! buffer)))))))))
-(define-command ("Redraw Display")
- "Redraws the entire display from scratch."
- (update-screens! true))
-
-(define-command ("Debug Show Rings")
+(define-command debug-show-rings
""
- (message "Mark Ring: "
- (write-to-string (ring-size (buffer-mark-ring (current-buffer))))
- "; Kill Ring: "
- (write-to-string (ring-size (current-kill-ring)))))
+ ()
+ (lambda ()
+ (message "Mark Ring: "
+ (write-to-string (ring-size (buffer-mark-ring (current-buffer))))
+ "; Kill Ring: "
+ (write-to-string (ring-size (current-kill-ring))))))
-(define-command ("Debug Count Marks")
+(define-command debug-count-marks
""
- (count-marks-group (buffer-group (current-buffer))
- (lambda (n-existing n-gced)
- (message "Existing: " (write-to-string n-existing)
- "; GCed: " (write-to-string n-gced)))))
+ ()
+ (lambda ()
+ (count-marks-group (buffer-group (current-buffer))
+ (lambda (n-existing n-gced)
+ (message "Existing: " (write-to-string n-existing)
+ "; GCed: " (write-to-string n-gced))))))
(define (count-marks-group group receiver)
(let loop ((marks (group-marks group)) (receiver receiver))
"class"
"clscon"
"clsmac"
- "complt"
"cterm"
"entity"
"grpops"
"filcom"
"fileio"
"fill"
- "filser"
"hlpcom"
"info"
"input"
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/dired.scm,v 1.98 1989/03/15 19:10:20 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/dired.scm,v 1.99 1989/04/15 00:48:24 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define-command ("Dired")
- "Edit a directory. You type the directory name."
- (select-buffer (make-dired-buffer "Dired")))
+(define-command dired
+ "\"Edit\" directory DIRNAME--delete, rename, print, etc. some files in it.
+Dired displays a list of files in DIRNAME.
+You can move around in it with the usual commands.
+You can flag files for deletion with C-d
+and then delete them by typing `x'.
+Type `h' after entering dired for more info."
+ "DDired (directory)"
+ (lambda (directory)
+ (select-buffer (make-dired-buffer directory))))
-(define-command ("Dired Other Window")
- "Edit a directory in another window. You type the directory name."
- (select-buffer-other-window (make-dired-buffer "Dired Other Window")))
+(define-command dired-other-window
+ "\"Edit\" directory DIRNAME. Like \\[dired] but selects in another window."
+ "DDired in other window (directory)"
+ (lambda (directory)
+ (select-buffer-other-window (make-dired-buffer directory))))
-(define (make-dired-buffer prompt)
- (let ((pathname (prompt-for-directory prompt (current-default-pathname))))
+(define (make-dired-buffer directory)
+ (let ((pathname (->pathname directory)))
(let ((buffer (get-dired-buffer pathname)))
- (set-buffer-major-mode! buffer dired-mode)
+ (set-buffer-major-mode! buffer (ref-mode-object dired))
(set-buffer-truename! buffer pathname)
(buffer-put! buffer 'REVERT-BUFFER-METHOD revert-dired-buffer)
(fill-dired-buffer! buffer)
(define (get-dired-buffer pathname)
(or (list-search-positive (buffer-list)
(lambda (buffer)
- (and (eq? dired-mode (buffer-major-mode buffer))
+ (and (eq? (ref-mode-object dired) (buffer-major-mode buffer))
(pathname=? pathname (buffer-truename buffer)))))
(new-buffer (pathname->buffer-name pathname))))
-(define (revert-dired-buffer argument)
- argument ;ignore
- (fill-dired-buffer! (current-buffer)))
+(define (revert-dired-buffer buffer dont-use-auto-save? dont-confirm?)
+ dont-use-auto-save? dont-confirm? ;ignore
+ (fill-dired-buffer! buffer))
(define (fill-dired-buffer! buffer)
(set-buffer-writeable! buffer)
(lambda ()
(set-dired-point! (line-start (buffer-start (current-buffer)) 2)))))
\f
-(define-major-mode "Dired" "Fundamental"
+(define-major-mode dired fundamental "Dired"
"Major mode for editing a list of files.
Each line describes a file in the directory.
F -- visit the file on the current line.
Space -- move down one line.
X -- kill marked files.
Q -- quit, killing marked files.
- This is like \\[^R Dired Execute] followed by \\[Kill Buffer].
-C-] -- abort Dired; this is like \\[Kill Buffer] on this buffer."
- (local-set-variable! "Case Fold Search" true)
- (local-set-variable! "Cursor Centering Threshold" 0)
- (local-set-variable! "Cursor Centering Point" 10))
+ This is like \\[dired-do-deletions] followed by \\[kill-buffer].
+C-] -- abort Dired; this is like \\[kill-buffer] on this buffer."
+ (local-set-variable! case-fold-search true))
-(define-key "Dired" #\F "^R Dired Find File")
-(define-key "Dired" #\O "^R Dired Find File Other Window")
-(define-key "Dired" #\G "^R Dired Revert")
-(define-key "Dired" #\D "^R Dired Kill")
-(define-key "Dired" #\K "^R Dired Kill")
-(define-key "Dired" #\C-D "^R Dired Kill")
-(define-key "Dired" #\C-K "^R Dired Kill")
-(define-key "Dired" #\U "^R Dired Unmark")
-(define-key "Dired" #\Rubout "^R Dired Backup Unmark")
-(define-key "Dired" #\Space "^R Dired Next")
-(define-key "Dired" #\C-N "^R Dired Next")
-(define-key "Dired" #\C-P "^R Dired Previous")
-(define-key "Dired" #\X "^R Dired Execute")
-(define-key "Dired" #\Q "^R Dired Quit")
-(define-key "Dired" #\C-\] "^R Dired Abort")
-(define-key "Dired" #\? "^R Dired Summary")
+(define-key 'dired #\f 'dired-find-file)
+(define-key 'dired #\o 'dired-find-file-other-window)
+(define-key 'dired #\g 'dired-revert)
+(define-key 'dired #\d 'dired-flag-file-deleted)
+(define-key 'dired #\c-d 'dired-flag-file-deleted)
+(define-key 'dired #\u 'dired-unflag)
+(define-key 'dired #\rubout 'dired-backup-unflag)
+(define-key 'dired #\space 'dired-next-line)
+(define-key 'dired #\c-n 'dired-next-line)
+(define-key 'dired #\c-p 'dired-previous-line)
+(define-key 'dired #\x 'dired-do-deletions)
+(define-key 'dired #\q 'dired-quit)
+(define-key 'dired #\c-\] 'dired-abort)
+(define-key 'dired #\? 'dired-summary)
\f
-(define-command ("^R Dired Find File")
+(define-command dired-find-file
"Read the current file into a buffer."
- (find-file (dired-current-pathname)))
+ ()
+ (lambda ()
+ (find-file (dired-current-pathname))))
-(define-command ("^R Dired Find File Other Window")
+(define-command dired-find-file-other-window
"Read the current file into a buffer in another window."
- (find-file-other-window (dired-current-pathname)))
+ ()
+ (lambda ()
+ (find-file-other-window (dired-current-pathname))))
-(define-command ("^R Dired Revert")
+(define-command dired-revert
"Read the current buffer."
- (revert-buffer (current-buffer) true true))
+ ()
+ (lambda ()
+ (revert-buffer (current-buffer) true true)))
-(define-command ("^R Dired Kill" (argument 1))
+(define-command dired-flag-file-deleted
"Mark the current file to be killed."
- (dired-mark #\D argument))
+ "p"
+ (lambda (argument)
+ (dired-mark #\D argument)))
-(define-command ("^R Dired Unmark" (argument 1))
+(define-command dired-unflag
"Cancel the kill requested for the current file."
- (dired-mark #\Space argument))
+ "p"
+ (lambda (argument)
+ (dired-mark #\Space argument)))
-(define-command ("^R Dired Backup Unmark" (argument 1))
+(define-command dired-backup-unflag
"Cancel the kill requested for the file on the previous line."
- (set-dired-point! (line-start (current-point) -1 'ERROR))
- (dired-mark #\Space argument)
- (set-dired-point! (line-start (current-point) -1 'ERROR)))
+ "p"
+ (lambda (argument)
+ (set-dired-point! (line-start (current-point) -1 'ERROR))
+ (dired-mark #\Space argument)
+ (set-dired-point! (line-start (current-point) -1 'ERROR))))
-(define-command ("^R Dired Next" (argument 1))
+(define-command dired-next-line
"Move down to the next line."
- (set-dired-point! (line-start (current-point) argument 'BEEP)))
+ "p"
+ (lambda (argument)
+ (set-dired-point! (line-start (current-point) argument 'BEEP))))
-(define-command ("^R Dired Previous" (argument 1))
+(define-command dired-previous-line
"Move up to the previous line."
- (set-dired-point! (line-start (current-point) (- argument) 'BEEP)))
+ "p"
+ (lambda (argument)
+ (set-dired-point! (line-start (current-point) (- argument) 'BEEP))))
-(define-command ("^R Dired Execute")
+(define-command dired-do-deletions
"Kill all marked files."
- (dired-kill-files))
+ ()
+ (lambda ()
+ (dired-kill-files)))
-(define-command ("^R Dired Quit")
+(define-command dired-quit
"Exit Dired, offering to kill any files first."
- (dired-kill-files)
- (kill-buffer-interactive (current-buffer)))
+ ()
+ (lambda ()
+ (dired-kill-files)
+ (kill-buffer-interactive (current-buffer))))
-(define-command ("^R Dired Abort")
+(define-command dired-abort
"Exit Dired."
- (kill-buffer-interactive (current-buffer)))
+ ()
+ (lambda ()
+ (kill-buffer-interactive (current-buffer))))
-(define-command ("^R Dired Summary")
+(define-command dired-summary
"Summarize the Dired commands in the typein window."
- (message "d-elete, u-ndelete, x-ecute, q-uit, f-ind, o-ther window"))
+ ()
+ (lambda ()
+ (message "d-elete, u-ndelete, x-ecute, q-uit, f-ind, o-ther window")))
\f
(define (set-dired-point! mark)
(set-current-point!
\f
;;;; List Directory
-(define-command ("List Directory" argument)
+(define-command list-directory
"Generate a directory listing."
- (let ((pathname
- (prompt-for-directory "List Directory" (current-default-pathname))))
- (let ((pathnames (directory-read pathname))
- (directory (pathname->string pathname)))
- (with-output-to-temporary-buffer "*Directory*"
- (lambda ()
- (write-string "Directory ")
- (write-string directory)
- (newline)
- (newline)
- (cond (argument
- (for-each (lambda (pathname)
- (write-string (os/make-dired-line pathname))
- (newline))
- pathnames))
- ((ref-variable "List Directory Unpacked")
- (for-each (lambda (pathname)
- (write-string (pathname-name-string pathname))
- (newline))
- pathnames))
- (else
- (write-strings-densely
- (map pathname-name-string pathnames)))))))))
\ No newline at end of file
+ "P"
+ (lambda (argument)
+ (let ((pathname
+ (prompt-for-directory "List directory" (current-default-pathname))))
+ (let ((pathnames (directory-read pathname))
+ (directory (pathname->string pathname)))
+ (with-output-to-temporary-buffer "*Directory*"
+ (lambda ()
+ (write-string "Directory ")
+ (write-string directory)
+ (newline)
+ (newline)
+ (cond (argument
+ (for-each (lambda (pathname)
+ (write-string (os/make-dired-line pathname))
+ (newline))
+ pathnames))
+ ((ref-variable list-directory-unpacked)
+ (for-each (lambda (pathname)
+ (write-string (pathname-name-string pathname))
+ (newline))
+ pathnames))
+ (else
+ (write-strings-densely
+ (map pathname-name-string pathnames))))))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/editor.scm,v 1.184 1989/03/30 16:39:37 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/editor.scm,v 1.185 1989/04/15 00:48:32 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(if (not edwin-editor)
(edwin-reset))
(call-with-current-continuation
- (lambda (edwin-abort-continuation)
+ (lambda (continuation)
(bind-condition-handler
- '()
- (lambda (condition)
- (within-continuation edwin-abort-continuation
- (lambda ()
- (signal-error condition))))
- enter-edwin))))
-
-(define (enter-edwin)
- (using-screen edwin-screen
- (lambda ()
- (with-editor-input-port edwin-input-port
- (lambda ()
- (with-editor-interrupts
- (lambda ()
- (within-editor edwin-editor
- (lambda ()
- (perform-buffer-initializations! (current-buffer))
- (dynamic-wind
- (lambda ()
- (update-screens! true))
- (lambda ()
- ;; Should this be in a dynamic wind? -- Jinx
- (if edwin-initialization (edwin-initialization))
- (let ((message (cmdl-message/null)))
- (push-cmdl (lambda (cmdl)
- cmdl ;ignore
- (top-level-command-reader)
- message)
- false
- message)))
- (lambda ()
- unspecific))))))))))
- ;; Should this be here or in a dynamic wind? -- Jinx
- (if edwin-finalization (edwin-finalization))
+ '()
+ (lambda (condition)
+ (and (not (condition/internal? condition))
+ (error? condition)
+ (if (ref-variable debug-on-error)
+ (begin
+ (with-output-to-temporary-buffer "*Error*"
+ (lambda ()
+ (format-error-message (condition/message condition)
+ (condition/irritants condition)
+ (current-output-port))))
+ (editor-error "Scheme error"))
+ (within-continuation continuation
+ (lambda ()
+ (signal-error condition))))))
+ (lambda ()
+ (using-screen edwin-screen
+ (lambda ()
+ (with-editor-input-port edwin-input-port
+ (lambda ()
+ (with-editor-interrupts
+ (lambda ()
+ (within-editor edwin-editor
+ (lambda ()
+ (perform-buffer-initializations! (current-buffer))
+ (dynamic-wind
+ (lambda ()
+ (update-screens! true))
+ (lambda ()
+ ;; Should this be in a dynamic wind? -- Jinx
+ (if edwin-initialization (edwin-initialization))
+ (let ((message (cmdl-message/null)))
+ (push-cmdl (lambda (cmdl)
+ cmdl ;ignore
+ (top-level-command-reader)
+ message)
+ false
+ message)))
+ (lambda ()
+ unspecific))))))))))
+ ;; Should this be here or in a dynamic wind? -- Jinx
+ (if edwin-finalization (edwin-finalization))))))
unspecific)
+(define-variable debug-on-error
+ "*True means enter debugger if an error is signalled.
+Does not apply to editor errors."
+ false)
+
;; Set this before entering the editor to get something done after the
;; editor's dynamic environment is initialized, but before the command
;; loop is started. [Should this bind the ^G interrupt also? -- CPH](define edwin-initialization false)
;; the editor's dynamic environment; for example, this can be used to
;; reset and then reenter the editor.
(define edwin-finalization false)
-
+\f
(define (within-editor editor thunk)
(call-with-current-continuation
(lambda (continuation)
(define recursive-edit-continuation)
(define recursive-edit-level)
(define current-editor)
-\f
+
(define (enter-recursive-edit)
(let ((value
(call-with-current-continuation
(define (exit-recursive-edit value)
(if recursive-edit-continuation
(recursive-edit-continuation value)
- (editor-abort value)))
+ (editor-error "No recursive edit is in progress")))
(define (editor-abort value)
(editor-continuation value))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edtfrm.scm,v 1.73 1989/03/14 08:00:30 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edtfrm.scm,v 1.74 1989/04/15 00:48:37 cph Exp $
;;;
;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
typein-inferior
selected-window
cursor-window
- select-time))
+ select-time
+ properties))
(define (make-editor-frame root-screen main-buffer typein-buffer)
(let ((window (make-object editor-frame)))
(set! y-size (screen-y-size root-screen))
(set! redisplay-flags (list false))
(set! inferiors '())
+ (set! properties (make-1d-table))
(let ((main-window (make-buffer-frame window main-buffer true))
(typein-window (make-buffer-frame window typein-buffer false)))
(set! screen root-screen)
(with-instance-variables editor-frame window ()
cursor-window))
+(define-integrable (editor-frame-root-window window)
+ (with-instance-variables editor-frame window ()
+ (inferior-window root-inferior)))
+
+(define-integrable (editor-frame-screen window)
+ (with-instance-variables editor-frame window ()
+ screen))
(define (editor-frame-select-window! window window*)
(with-instance-variables editor-frame window (window*)
(if (not (buffer-frame? window*))
(char-history false read-only true))
(define (make-editor name screen)
- (let ((initial-buffer (make-buffer initial-buffer-name interaction-mode)))
+ (let ((initial-buffer
+ (make-buffer initial-buffer-name (ref-mode-object interaction))))
(let ((bufferset (make-bufferset initial-buffer)))
(let ((frame
(make-editor-frame screen
(load "clsmac" (->environment '(EDWIN CLASS-MACROS)))
(load "xform"
(->environment '(EDWIN CLASS-MACROS TRANSFORM-INSTANCE-VARIABLES)))
- (load "complt" environment)
(load "paths" environment)
(load "struct" environment)
(load "grpops" (->environment '(EDWIN GROUP-OPERATIONS)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.2 1989/03/30 16:39:47 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.3 1989/04/15 00:48:50 cph Exp $
Copyright (c) 1989 Massachusetts Institute of Technology
"strtab"
"strpad"
"class"
- "complt"
"unix"
"paths"
(export (edwin)
edwin-syntax-table)
(export (edwin class-macros)
- edwin-syntax-table))
+ edwin-syntax-table)
+ (export (edwin)
+ canonicalize-name
+ command-name->scheme-name
+ mode-name->scheme-name
+ variable-name->scheme-name))
(define-package (edwin group-operations)
(files "grpops")
(parent (edwin))
(export (edwin)
abort-current-command
+ command-history-list
command-message-receive
command-reader
current-command
dispatch-on-command
execute-char
execute-command
+ execute-command-history-entry
+ initialize-command-reader!
+ keyboard-chars-read
read-and-dispatch-on-char
set-command-message!
top-level-command-reader))
(files "prompt")
(parent (edwin))
(export (edwin)
- enable-recursive-minibuffers
- initialize-typein!
- list-completions
+ edwin-variable$enable-recursive-minibuffers initialize-typein!
prompt-for-alist-value
prompt-for-char
- prompt-for-char-without-interrupts
prompt-for-command
prompt-for-completed-string
prompt-for-confirmation?
prompt-for-key
+ prompt-for-number
prompt-for-string
+ prompt-for-string-table-name
prompt-for-string-table-value
prompt-for-typein
prompt-for-variable
(files "rgxcmp")
(parent (edwin))
(export (edwin)
+ error-type:re-compile-pattern
re-compile-char
re-compile-char-set
re-compile-pattern
(files "linden")
(parent (edwin))
(export (edwin)
+ edwin-variable$lisp-body-indent
+ edwin-variable$lisp-indent-hook
+ edwin-variable$lisp-indent-methods
+ edwin-variable$lisp-indent-offset
indent-code-rigidly
- lisp-body-indent
lisp-comment-indentation
lisp-comment-locate
lisp-indent-definition
- lisp-indent-hook
lisp-indent-line
- lisp-indent-methods
- lisp-indent-offset
lisp-indent-sexp
lisp-indent-special-form
standard-lisp-indent-hook))
command-argument-prompt
command-argument-self-insert?
command-argument-standard-value
+ command-argument-standard-value?
command-argument-value
reset-command-argument-reader!
with-command-argument-reader))
(files "bufmnu")
(parent (edwin))
(export (edwin)
- buffer-menu-kill-on-quit))
+ edwin-variable$buffer-menu-kill-on-quit))
(define-package (edwin register-command)
(files "regcom")
(define-package (edwin incremental-search)
(files "iserch")
- (parent (edwin)))
+ (parent (edwin))
+ (export (edwin)
+ isearch))
(define-package (edwin command-summary)
(files "keymap")
(parent (edwin)))
|#(define-package (edwin dired)
(files "dired")
- (parent (edwin)))
+ (parent (edwin))
+ (export (edwin)
+ make-dired-buffer))
(define-package (edwin info)
(files "info")
(if (not (name->package '(EDWIN)))
(begin
(load "edwin.bcon")
- (load "macros" '(EDWIN MACROS))
- (load "clsmac" '(EDWIN CLASS-MACROS))
- (load "xform" '(EDWIN CLASS-MACROS TRANSFORM-INSTANCE-VARIABLES))
- (load "class" '(EDWIN))
- (load "clscon" '(EDWIN CLASS-CONSTRUCTOR))))
+ (load "macros.bin" '(EDWIN MACROS))
+ (load "clsmac.bin" '(EDWIN CLASS-MACROS))
+ (load "xform.bin" '(EDWIN CLASS-MACROS TRANSFORM-INSTANCE-VARIABLES))
+ (load "class.bin" '(EDWIN))
+ (load "clscon.bin" '(EDWIN CLASS-CONSTRUCTOR))))
(load "decls")
;; Guarantee that the package modeller is loaded.
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/evlcom.scm,v 1.12 1989/03/15 19:11:35 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/evlcom.scm,v 1.13 1989/04/15 00:49:00 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define-variable "Scheme Environment"
+(define-variable scheme-environment
"The environment used by the evaluation commands, or 'DEFAULT.
If 'DEFAULT, use the default (REP loop) environment."
'DEFAULT)
-(define-variable "Scheme Syntax Table"
+(define-variable scheme-syntax-table
"The syntax table used by the evaluation commands, or false.
If false, use the default (REP loop) syntax-table."
false)
-(define-variable "Previous Evaluation Environment"
- "The last explicit environment for an evaluation command."
+(define-variable previous-evaluation-expression
+ "The last expression evaluated in the typein window."
false)
-(define-command ("^R Evaluate Definition" argument)
+(define-command eval-definition
"Evaluate the definition at point.
Prints the result in the typein window.
With an argument, prompts for the evaluation environment.
Output goes to the transcript buffer."
- (evaluate-sexp (current-definition-start)
- (evaluation-environment argument)))
+ "P"
+ (lambda (argument)
+ (evaluate-from-mark (current-definition-start)
+ (evaluation-environment argument))))
-(define-command ("^R Evaluate Sexp" argument)
+(define-command eval-next-sexp
"Evaluate the expression following point.
Prints the result in the typein window.
With an argument, prompts for the evaluation environment.
Output goes to the transcript buffer."
- (evaluate-sexp (current-point)
- (evaluation-environment argument)))
+ "P"
+ (lambda (argument)
+ (evaluate-from-mark (current-point)
+ (evaluation-environment argument))))
-(define-command ("^R Evaluate Previous Sexp" argument)
+(define-command eval-previous-sexp
"Evaluate the expression preceding point.
Prints the result in the typein window.
With an argument, prompts for the evaluation environment.
Output goes to the transcript buffer."
- (evaluate-sexp (backward-one-sexp (current-point))
- (evaluation-environment argument)))
+ "P"
+ (lambda (argument)
+ (evaluate-from-mark (backward-one-sexp (current-point))
+ (evaluation-environment argument))))
-(define-command ("^R Evaluate Region" argument)
+(define-command eval-region
"Evaluate the region, printing the results in the typein window.
With an argument, prompts for the evaluation environment.
Output goes to the transcript buffer."
- (evaluate-region (current-region)
- (evaluation-environment argument)))
+ "r\nP"
+ (lambda (region argument)
+ (evaluate-region region (evaluation-environment argument))))
-(define-command ("^R Evaluate Buffer" argument)
+(define-command eval-current-buffer
"Evaluate the buffer.
The values are printed in the typein window.
With an argument, prompts for the evaluation environment.
Output goes to the transcript buffer."
- (evaluate-region (buffer-region (current-buffer))
- (evaluation-environment argument)))
+ "P"
+ (lambda (argument)
+ (evaluate-region (buffer-region (current-buffer))
+ (evaluation-environment argument))))
\f
-(define-command ("^R Evaluate Previous Sexp into Buffer" argument)
+(define-command eval-previous-sexp-into-buffer
"Evaluate the expression preceding point.
With an argument, prompts for the evaluation environment.
Output is inserted into the buffer at point."
- (let ((start (backward-sexp (current-point) 1 false)))
- (if (not start) (editor-error "No previous expression"))
- (let ((environment (evaluation-environment argument)))
- (with-output-to-current-point
- (lambda ()
- (write-line (eval-with-history (with-input-from-mark start read)
- environment)))))))
-
-(define-variable "Previous Typein Expression"
- "The last expression evaluated in the typein window."
- false)
-
-(define-command ("^R Evaluate Sexp Typein" argument)
+ "P"
+ (lambda (argument)
+ (let ((start (backward-sexp (current-point) 1 false)))
+ (if (not start) (editor-error "No previous expression"))
+ (let ((environment (evaluation-environment argument)))
+ (with-output-to-current-point
+ (lambda ()
+ (write-line
+ (eval-with-history (read-from-mark start) environment))))))))
+
+(define-command eval-expression
"Read an evaluate an expression in the typein window.
With an argument, prompts for the evaluation environment."
- (let ((string
- (prompt-for-expression "Evaluate Sexp"
- (ref-variable "Previous Typein Expression")
- 'INVISIBLE-DEFAULT)))
- (set-variable! "Previous Typein Expression" string)
- (editor-eval (with-input-from-string string read)
- (evaluation-environment argument))))
-
-(define-command ("Set Environment")
+ "xEvaluate expression\nP"
+ (lambda (expression argument)
+ (editor-eval expression (evaluation-environment argument))))
+
+(define-command set-environment
"Sets the environment for the editor and any inferior REP loops."
- (set-repl/environment! (nearest-repl)
- (->environment
- (prompt-for-expression-value
- "REP environment"
- (ref-variable "Previous Evaluation Environment")))))
-
-(define-command ("Set Syntax Table")
- "Sets the current syntax table (for the syntaxer, not the editor)."
- (set-repl/syntax-table! (nearest-repl)
- (prompt-for-expression-value "Set Syntax Table"
- false)))
+ "XSet environment"
+ (lambda (environment)
+ (set-repl/environment! (nearest-repl) (->environment environment))))
+
+(define (evaluation-environment argument)
+ (cond (argument
+ (->environment
+ (prompt-for-expression-value "Evaluate in environment" false)))
+ ((eq? 'DEFAULT (ref-variable scheme-environment))
+ (nearest-repl/environment))
+ (else
+ (->environment (ref-variable scheme-environment)))))
+
+(define-command set-syntactic-environment
+ "Sets the current syntactic environment."
+ "XSet syntactic environment"
+ (lambda (syntactic-environment)
+ (set-repl/syntax-table! (nearest-repl) syntactic-environment)))
+
+(define (evaluation-syntax-table)
+ (or (ref-variable scheme-syntax-table)
+ (nearest-repl/syntax-table)))
\f
-(define (evaluate-sexp input-mark environment)
- (editor-eval (with-input-from-mark input-mark read) environment))
+(define (evaluate-from-mark input-mark environment)
+ (editor-eval (read-from-mark input-mark) environment))
-(define (evaluate-string string environment)
- (eval-with-history (with-input-from-string string read) environment))
+(define (read-from-mark input-mark)
+ (with-input-from-mark input-mark read))
(define (editor-eval sexp environment)
(with-output-to-transcript-buffer
(define (evaluate-region region environment)
(with-output-to-transcript-buffer
- (lambda ()
- (with-input-from-region region
- (lambda ()
- (define (loop object)
- (if (not (eof-object? object))
- (begin (transcript-write (eval-with-history object environment))
- (loop (read)))))
- (loop (read)))))))
+ (lambda ()
+ (with-input-from-region region
+ (lambda ()
+ (let loop ((object (read)))
+ (if (not (eof-object? object))
+ (begin
+ (transcript-write (eval-with-history object environment))
+ (loop (read))))))))))
(define (eval-with-history expression environment)
(let ((scode (syntax expression (evaluation-syntax-table))))
(editor-error "Error while evaluating expression"))))
(lambda ()
(with-new-history (lambda () (scode-eval scode environment)))))))
-(define (prompt-for-expression prompt default-string #!optional default-type)
- (prompt-for-completed-string prompt
- default-string
- (if (default-object? default-type)
- 'VISIBLE-DEFAULT
- default-type)
- false 'NO-COMPLETION
- prompt-for-expression-mode))
-
-(define-major-mode "Prompt for Expression" "Scheme"
+(define (prompt-for-expression-value prompt default)
+ (eval-with-history (prompt-for-expression prompt default)
+ (evaluation-environment false)))
+
+(define (prompt-for-expression prompt default-object #!optional default-type)
+ (read-from-string
+ (prompt-for-string prompt
+ (and default-object
+ (write-to-string default-object))
+ (if (default-object? default-type)
+ 'VISIBLE-DEFAULT
+ default-type)
+ (ref-mode-object prompt-for-expression))))
+
+(define-major-mode prompt-for-expression scheme #f
"Major mode for editing solicited input expressions.
Depending on what is being solicited, either defaulting or completion
may be available. The following commands are special to this mode:
-\\[^R Terminate Input] terminates the input.
-\\[^R Yank Default String] yanks the default string, if there is one.")
-
-(define-key "Prompt for Expression" #\Return "^R Terminate Input")
-(define-key "Prompt for Expression" #\C-M-Y "^R Yank Default String")
+\\[exit-minibuffer] terminates the input.
+\\[minibuffer-yank-default] yanks the default string, if there is one.")
-(define (prompt-for-expression-value prompt default)
- (evaluate-string (prompt-for-expression prompt default)
- (evaluation-environment false)))
-
-(define (evaluation-syntax-table)
- (or (ref-variable "Scheme Syntax Table")
- (nearest-repl/syntax-table)))
-
-(define (evaluation-environment argument)
- (cond (argument
- (let ((string
- (prompt-for-expression
- "Evaluate in environment"
- (ref-variable "Previous Evaluation Environment"))))
- (set-variable! "Previous Evaluation Environment" string)
- (->environment (eval (with-input-from-string string read)
- (evaluation-environment false)))))
- ((eq? 'DEFAULT (ref-variable "Scheme Environment"))
- (nearest-repl/environment))
- (else
- (->environment (ref-variable "Scheme Environment")))))
+(define-key 'prompt-for-expression #\return 'exit-minibuffer)
+(define-key 'prompt-for-expression #\c-m-y 'minibuffer-yank-default)
\f
;;;; Transcript Buffer
-(define-variable "Transcript Buffer Name"
+(define-variable transcript-buffer-name
"Name of buffer to which evaluation commands record their output."
"*Transcript*")
-(define-variable "Enable Transcript Buffer"
+(define-variable enable-transcript-buffer
"If true, I/O from evaluation commands is recorded in transcript buffer.
Recording is done only for commands that write their output to the
message area, not commands that write to a specific buffer."
false)
(define (transcript-buffer)
- (find-or-create-buffer (ref-variable "Transcript Buffer Name")))
+ (find-or-create-buffer (ref-variable transcript-buffer-name)))
(define (transcript-write value)
- (if (ref-variable "Enable Transcript Buffer")
+ (if (ref-variable enable-transcript-buffer)
(write-line value))
- (if (or (not (ref-variable "Enable Transcript Buffer"))
+ (if (or (not (ref-variable enable-transcript-buffer))
(null? (buffer-windows (transcript-buffer))))
(message (write-to-string value))))
(define (with-output-to-transcript-buffer thunk)
- (if (ref-variable "Enable Transcript Buffer")
+ (if (ref-variable enable-transcript-buffer)
(with-interactive-output-port (transcript-output-port) thunk)
(thunk)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/filcom.scm,v 1.132 1989/04/05 18:19:16 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/filcom.scm,v 1.133 1989/04/15 00:49:07 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define-command ("Toggle Read Only")
- "Change whether this buffer is visiting its file read-only."
- (let ((buffer (current-buffer)))
- ((if (buffer-writeable? buffer)
- set-buffer-read-only!
- set-buffer-writeable!)
- buffer)))
+(define (find-file filename)
+ (select-buffer (find-file-noselect filename)))
-(define-command ("Find File")
- "Visit a file in its own buffer.
-If the file is already in some buffer, select that buffer.
-Otherwise, visit the file in a buffer named after the file."
- (find-file (prompt-for-pathname "Find File" (current-default-pathname))))
-
-(define-command ("Find File Other Window")
- "Visit a file in another window.
-May create a window, or reuse one."
- (find-file-other-window
- (prompt-for-pathname "Find File Other Window" (current-default-pathname))))
+(define (find-file-other-window filename)
+ (select-buffer-other-window (find-file-noselect filename)))
-(define-command ("^R Find Alternate File")
- "Find a file in its own buffer, killing the current buffer.
-Like \\[Kill Buffer] followed by \\[Find File]."
- (let ((buffer (current-buffer)))
- (if (not (buffer-pathname buffer))
- (editor-error "Buffer not visiting any file"))
- (let ((pathname
- (prompt-for-pathname "Find Alternate File"
- (current-default-pathname))))
- (define (kernel)
- (kill-buffer-interactive buffer)
- (find-file pathname))
- (if (not (other-buffer buffer))
- (let ((buffer* (new-buffer "*dummy*")))
- (kernel)
- (kill-buffer buffer*))
- (kernel)))))
-\f
-(define (find-file pathname)
- (select-buffer (find-file-noselect pathname)))
-
-(define (find-file-other-window pathname)
- (select-buffer-other-window (find-file-noselect pathname)))
-
-(define (find-file-noselect pathname)
- (let ((buffer (pathname->buffer pathname)))
- (or buffer
- (let ((buffer (new-buffer (pathname->buffer-name pathname))))
- (after-find-file
- buffer
- (catch-file-errors (lambda () true)
- (lambda () (not (read-buffer buffer pathname)))))
- buffer))))
+(define (find-file-noselect filename)
+ (let ((pathname (pathname->absolute-pathname (->pathname filename))))
+ (if (file-directory? pathname)
+ (make-dired-buffer (pathname-as-directory pathname))
+ (let ((buffer (pathname->buffer pathname)))
+ (or buffer
+ (let ((buffer (new-buffer (pathname->buffer-name pathname))))
+ (after-find-file
+ buffer
+ (catch-file-errors (lambda () true)
+ (lambda ()
+ (not (read-buffer buffer pathname)))))
+ buffer))))))
(define (after-find-file buffer error?)
(let ((pathname (or (buffer-truename buffer) (buffer-pathname buffer))))
(define (pathname=? x y)
(string=? (pathname->string x)
- (pathname->string y)))
-\f
-(define-command ("^R Save File" argument)
- "Save current buffer in visited file if modified. Versions described below.
-
-By default, makes the previous version into a backup file
- if previously requested or if this is the first save.
-With 1 or 3 \\[^R Universal Argument]'s, marks this version
- to become a backup when the next save is done.
-With 2 or 3 \\[^R Universal Argument]'s,
- unconditionally makes the previous version into a backup file.
-With argument of 0, never makes the previous version into a backup file.
+ (pathname->string y)))\f
+(define-command find-file
+ "Visit a file in its own buffer.
+If the file is already in some buffer, select that buffer.
+Otherwise, visit the file in a buffer named after the file."
+ "FFind file"
+ find-file)
-If a file's name is FOO, the names of its numbered backup versions are
- FOO.~i~ for various integers i. A non-numbered backup file is called FOO~.
-Numeric backups (rather than FOO~) will be made if value of
- `Version Control' is not the atom `never' and either there are already
- numeric versions of the file being backed up, or `Version Control' is
- not #F.
-We don't want excessive versions piling up, so there are variables
- `Kept Old Versions', which tells Edwin how many oldest versions to keep,
- and `Kept New Versions', which tells how many newest versions to keep.
- Defaults are 2 old versions and 2 new.
-If `Trim Versions Without Asking' is false, system will query user
- before trimming versions. Otherwise it does it silently."
- (let ((do-it (lambda () (save-file (current-buffer)))))
- (if (eqv? argument 0)
- (fluid-let (((ref-variable "Make Backup Files") false))
- (do-it))
- (do-it))))
+(define-command find-file-other-window
+ "Visit a file in another window.
+May create a window, or reuse one."
+ "FFind file in other window"
+ find-file-other-window)
-(define (save-file buffer)
+(define-command find-alternate-file
+ "Find a file in its own buffer, killing the current buffer.
+Like \\[kill-buffer] followed by \\[find-file]."
+ "FFind alternate file"
+ (lambda (filename)
+ (let ((buffer (current-buffer)))
+ (if (not (buffer-pathname buffer))
+ (editor-error "Buffer not visiting any file"))
+ (let ((do-it
+ (lambda ()
+ (kill-buffer-interactive buffer)
+ (find-file filename))))
+ (if (other-buffer buffer)
+ (do-it)
+ (let ((buffer* (new-buffer "*dummy*")))
+ (do-it)
+ (kill-buffer buffer*)))))))
+
+(define-command toggle-read-only
+ "Change whether this buffer is visiting its file read-only."
+ ()
+ (lambda ()
+ (let ((buffer (current-buffer)))
+ ((if (buffer-writeable? buffer)
+ set-buffer-read-only!
+ set-buffer-writeable!)
+ buffer))))
+\f
+(define (save-buffer buffer)
(if (buffer-modified? buffer)
(let ((exponent (command-argument-multiplier-only?)))
(if (buffer-pathname buffer)
(if (memv exponent '(1 3)) (set-buffer-backed-up?! buffer false)))
(temporary-message "(No changes need to be written)")))
-(define-command ("Save Some Buffers" argument)
- "Saves some modified file-visiting buffers. Asks user about each one.
-With argument, saves all with no questions."
- (save-some-buffers argument))
-
(define (save-some-buffers #!optional no-confirmation?)
(let ((buffers
(list-transform-positive (buffer-list)
(and (buffer-modified? buffer)
(buffer-pathname buffer))))))
(if (null? buffers)
- (temporary-message "(No buffers need saving)")
+ (temporary-message "(No files need saving)")
(for-each (lambda (buffer)
(save-buffer-prepare-version buffer)
(if (or (and (not (default-object? no-confirmation?))
no-confirmation?)
(prompt-for-confirmation?
(string-append
- "Save file '"
- (pathname->string (buffer-pathname buffer))
- "'")))
+ "Save file "
+ (pathname->string (buffer-pathname buffer)))))
(write-buffer-interactive buffer)))
buffers))))
(let ((pathname (buffer-pathname buffer)))
(if (and pathname (integer? (pathname-version pathname)))
(set-buffer-pathname! buffer (newest-pathname pathname)))))
+
+(define-command save-buffer
+ "Save current buffer in visited file if modified. Versions described below.
+
+By default, makes the previous version into a backup file
+ if previously requested or if this is the first save.
+With 1 or 3 \\[universal-argument]'s, marks this version
+ to become a backup when the next save is done.
+With 2 or 3 \\[universal-argument]'s,
+ unconditionally makes the previous version into a backup file.
+With argument of 0, never makes the previous version into a backup file.
+
+If a file's name is FOO, the names of its numbered backup versions are
+ FOO.~i~ for various integers i. A non-numbered backup file is called FOO~.
+Numeric backups (rather than FOO~) will be made if value of
+ `version-control' is not the atom `never' and either there are already
+ numeric versions of the file being backed up, or `version-control' is
+ not #F.
+We don't want excessive versions piling up, so there are variables
+ `kept-old-versions', which tells Edwin how many oldest versions to keep,
+ and `kept-new-versions', which tells how many newest versions to keep.
+ Defaults are 2 old versions and 2 new.
+If `trim-versions-without-asking' is false, system will query user
+ before trimming versions. Otherwise it does it silently."
+ "P"
+ (lambda (argument)
+ (let ((do-it (lambda () (save-buffer (current-buffer)))))
+ (if (eqv? argument 0)
+ (with-variable-value! (ref-variable-object make-backup-files) false
+ do-it)
+ (do-it)))))
+
+(define-command save-some-buffers
+ "Saves some modified file-visiting buffers. Asks user about each one.
+With argument, saves all with no questions."
+ "P"
+ save-some-buffers)
\f
-(define-command ("Set Visited File Name" argument)
- "Change name of file visited in current buffer to given name.
-With an argument, means make buffer not be visiting any file.
-The next time the buffer is saved it will go in the newly specified file. "
- (set-visited-pathname
- (current-buffer)
- (and (not argument)
- (prompt-for-pathname "Set Visited File Name"
- (current-default-pathname)))))
+(define-command set-visited-file-name
+ "Change name of file visited in current buffer.
+The next time the buffer is saved it will go in the newly specified file.
+Delete the initial contents of the minibuffer
+if you wish to make buffer not be visiting any file."
+ "FSet visited file name"
+ (lambda (filename)
+ (set-visited-pathname (current-buffer)
+ (and (not (string-null? filename))
+ (prompt-string->pathname filename)))))
(define (set-visited-pathname buffer pathname)
(set-buffer-pathname! buffer pathname)
(buffer-modified! buffer))
(disable-buffer-auto-save! buffer)))
-(define-command ("Write File")
+(define (pathname->buffer-name pathname)
+ (let ((name (pathname-name pathname)))
+ (if name
+ (pathname->string
+ (make-pathname false false false
+ name
+ (pathname-type pathname)
+ false))
+ (let ((name
+ (let ((directory (pathname-directory pathname)))
+ (and (pair? directory)
+ (car (last-pair directory))))))
+ (if (string? name)
+ name
+ "*random*")))))
+
+(define-command write-file
"Store buffer in specified file.
This file becomes the one being visited."
- (write-file (current-buffer)
- (prompt-for-pathname "Write File" (current-default-pathname))))
+ "FWrite file"
+ (lambda (filename)
+ (write-file (current-buffer) filename)))
-(define (write-file buffer pathname)
- (set-visited-pathname buffer pathname)
+(define (write-file buffer filename)
+ (set-visited-pathname buffer (->pathname filename))
(write-buffer-interactive buffer))
-(define-command ("Write Region")
+(define-command write-region
"Store the region in specified file."
- (write-region (current-region)
- (prompt-for-pathname "Write Region"
- (current-default-pathname))))
+ "FWrite region"
+ (lambda (filename)
+ (write-region (current-region) filename)))
-(define-variable "Previous Inserted File"
- "Pathname of the file that was most recently inserted."
- false)
-
-(define-command ("Insert File")
+(define-command insert-file
"Insert contents of file into existing text.
Leaves point at the beginning, mark at the end."
- (let ((pathname
- (prompt-for-pathname
- "Insert File"
- (newest-pathname (or (ref-variable "Previous Inserted File")
- (buffer-pathname (current-buffer)))))))
- (set-variable! "Previous Inserted File" pathname)
- (set-current-region! (insert-file (current-point) pathname))))
-
-(define-command ("Revert Buffer" argument)
- "Loads current buffer with version of file from disk."
- (revert-buffer (current-buffer) argument false))
-
-(define (revert-buffer buffer argument dont-confirm?)
+ "FInsert file"
+ (lambda (filename)
+ (set-current-region! (insert-file (current-point) filename))))
+\f
+(define-command revert-buffer
+ "Replace the buffer text with the text of the visited file on disk.
+This undoes all changes since the file was visited or saved.
+If latest auto-save file is more recent than the visited file,
+asks user whether to use that instead.
+Argument means don't offer to use auto-save file."
+ "P"
+ (lambda (argument)
+ (revert-buffer (current-buffer) argument false)))
+
+(define (revert-buffer buffer dont-use-auto-save? dont-confirm?)
(let ((method (buffer-get buffer 'REVERT-BUFFER-METHOD)))
(if method
- (method argument)
+ (method buffer dont-use-auto-save? dont-confirm?)
(let ((pathname (buffer-pathname buffer)))
(cond ((not pathname)
(editor-error
"Buffer does not seem to be associated with any file"))
((not (file-exists? pathname))
(editor-error "File "
- (pathname-name-string pathname)
+ (pathname->string pathname)
" no longer exists!"))
((or dont-confirm?
(prompt-for-yes-or-no?
(string-append "Revert buffer from file "
- (pathname-name-string pathname))))
+ (pathname->string pathname))))
(let ((where (mark-index (buffer-point buffer))))
(read-buffer buffer pathname)
(set-current-point!
(mark+ (buffer-start buffer) where 'LIMIT))
- (after-find-file buffer false))))))))
-\f
-(define-command ("Copy File")
+ (after-find-file buffer false))))))))\f
+(define-command copy-file
"Copy a file; the old and new names are read in the typein window.
If a file with the new name already exists, confirmation is requested first."
- (let ((old (prompt-for-input-truename "Copy File"
- (buffer-pathname (current-buffer)))))
- (let ((new (prompt-for-output-truename "Copy to" old)))
- (if (or (not (file-exists? new))
- (prompt-for-yes-or-no?
- (string-append "File '"
- (pathname->string new)
- "' already exists; copy anyway")))
- (begin (copy-file old new)
- (message "Copied '" (pathname->string old)
- "' => '" (pathname->string new) "'"))))))
-
-(define-command ("Rename File")
+ (lambda ()
+ (let ((old
+ (prompt-for-input-truename "Copy file" (current-default-pathname))))
+ (list old (prompt-for-output-truename "Copy to" old))))
+ (lambda (old new)
+ (if (or (not (file-exists? new))
+ (prompt-for-yes-or-no?
+ (string-append "File '"
+ (pathname->string new)
+ "' already exists; copy anyway")))
+ (begin (copy-file old new)
+ (message "Copied '" (pathname->string old)
+ "' => '" (pathname->string new) "'")))))
+
+(define-command rename-file
"Rename a file; the old and new names are read in the typein window.
If a file with the new name already exists, confirmation is requested first."
- (let ((old (prompt-for-input-truename "Rename File"
- (buffer-pathname (current-buffer)))))
- (let ((new (prompt-for-output-truename "Rename to" old)))
- (define (do-it)
- (rename-file old new)
- (message "Renamed '" (pathname->string old)
- "' => '" (pathname->string new) "'"))
+ (lambda ()
+ (let ((old
+ (prompt-for-input-truename "Rename file"
+ (current-default-pathname))))
+ (list old (prompt-for-output-truename "Rename to" old))))
+ (lambda (old new)
+ (let ((do-it
+ (lambda ()
+ (rename-file old new)
+ (message "Renamed '" (pathname->string old)
+ "' => '" (pathname->string new) "'"))))
(if (file-exists? new)
(if (prompt-for-yes-or-no?
(string-append "File '"
(begin (delete-file new) (do-it)))
(do-it)))))
-(define-command ("Delete File")
+(define-command delete-file
"Delete a file; the name is read in the typein window."
- (let ((old (prompt-for-input-truename "Delete File"
- (buffer-pathname (current-buffer)))))
- (if (prompt-for-confirmation?
- (string-append "Delete '"
- (pathname->string old)
- "'"))
- (delete-file old))))
+ "fDelete File"
+ delete-file)
+
+(define-command cd
+ "Make DIR become Scheme's default directory."
+ "DChange default directory"
+ cd)
\f
;;;; Printer Support
-(define-command ("Print File")
+(define-command print-file
"Print a file on the local printer."
- (print-region
- (file->region
- (prompt-for-input-truename "Print File"
- (buffer-pathname (current-buffer))))))
+ "fPrint File"
+ (lambda (filename)
+ (print-region (file->region (->pathname filename)))))
-(define-command ("Print Buffer")
+(define-command print-buffer
"Print the current buffer on the local printer."
- (print-region (buffer-region (current-buffer))))
+ ()
+ (lambda ()
+ (print-region (buffer-region (current-buffer)))))
-(define-command ("Print Page")
+(define-command print-page
"Print the current page on the local printer."
- (print-region (page-interior-region (current-point))))
+ ()
+ (lambda ()
+ (print-region (page-interior-region (current-point)))))
-(define-command ("Print Region")
+(define-command print-region
"Print the current region on the local printer."
- (print-region (current-region)))
+ "r"
+ (lambda (region)
+ (print-region region)))
#|
|#
\f
-;;;; Supporting Stuff
-
-(define *default-pathname*)
-
-(define-command ("^R Complete Filename")
- "Attempt to complete the filename being edited in the echo area."
- (let ((region (buffer-region (current-buffer))))
- (let ((string (region->string region)))
- (if (string-null? string)
- (insert-string
- (pathname->string
- (or (pathname->input-truename *default-pathname*)
- *default-pathname*)))
- (complete-pathname (prompt-string->pathname string)
- *default-pathname*
- (lambda (pathname)
- (region-delete! region)
- (insert-string (pathname->string pathname)))
- (lambda (string start end)
- (region-delete! region)
- (insert-string (substring string start end)))
- editor-beep)))))
-
-(define-command ("^R List Filename Completions")
- "List the possible completions for the filename being input."
- (list-completions
- (map pathname->string
- (pathname-completions
- (prompt-string->pathname
- (region->string (buffer-region (current-buffer))))
- *default-pathname*))))
-
-;;; Derives buffername from pathname
-
-(define (pathname->buffer-name pathname)
- (let ((name (pathname-name pathname)))
- (if name
- (pathname->string
- (make-pathname false false false
- name
- (pathname-type pathname)
- false))
- (let ((name
- (let ((directory (pathname-directory pathname)))
- (and (pair? directory)
- (car (last-pair directory))))))
- (if (string? name)
- name
- "*random*")))))
-
-(define-integrable (prompt-string->pathname string)
- (string->pathname (os/trim-pathname-string string)))
-\f
;;;; Prompting
+(define (prompt-for-filename prompt default require-match?)
+ (let ((default (pathname-directory-path default)))
+ (let ((pathname-completions
+ (lambda (string)
+ (let ((pathname
+ (merge-pathnames (prompt-string->pathname string)
+ default)))
+ (let ((directory (pathname-directory-string pathname)))
+ (map (lambda (filename)
+ ;; This is valid on all the operating systems
+ ;; I can think of, and is faster than doing
+ ;; pathname operations. Hopefully it will not
+ ;; cause a problem later.
+ (string-append directory filename))
+ (os/directory-list-completions
+ directory
+ (pathname-name-string pathname))))))))
+ (prompt-for-completed-string
+ prompt
+ (pathname-directory-string default)
+ 'INSERTED-DEFAULT
+ (lambda (string if-unique if-not-unique if-not-found)
+ (let ((filenames (pathname-completions string)))
+ (cond ((null? filenames)
+ (if-not-found))
+ ((null? (cdr filenames))
+ (if-unique (car filenames)))
+ (else
+ (let ((string (string-greatest-common-prefix filenames)))
+ (if-not-unique
+ string
+ (lambda ()
+ (list-transform-positive filenames
+ (lambda (filename)
+ (string-prefix? string filename))))))))))
+ pathname-completions
+ file-exists?
+ require-match?))))
+
(define (prompt-for-input-truename prompt default)
- (let ((path (prompt-for-pathname prompt default)))
- (if (file-exists? path)
- (pathname->input-truename path)
- (editor-error "'" (pathname->string path) "' does not exist"))))
+ (pathname->input-truename
+ (prompt-string->pathname (prompt-for-filename prompt default true))))
(define (prompt-for-output-truename prompt default)
(pathname->output-truename (prompt-for-pathname prompt default)))
-(define (prompt-for-pathname prompt #!optional default)
- (let ((default
- (or (and (not (default-object? default)) default)
- (current-default-pathname))))
- (prompt-string->pathname
- (fluid-let ((*default-pathname* default))
- (prompt-for-completed-string prompt
- (pathname-directory-string default)
- 'INSERTED-DEFAULT
- false
- 'NO-COMPLETION
- prompt-for-pathname-mode)))))
+(define (prompt-for-pathname prompt default)
+ (prompt-string->pathname (prompt-for-filename prompt default false)))
(define (prompt-for-directory prompt default-pathname)
(let ((pathname (prompt-for-pathname prompt default-pathname)))
(pathname-new-version (or pathname (working-directory-pathname))
(and pathname-newest 'NEWEST)))
-(define-major-mode "Prompt for Pathname" "Fundamental"
- "Major mode for entering pathnames.
-\\[^R Terminate Input] indicates that you are done entering the pathname.
-\\[^R Complete Filename] will complete the pathname.
-\\[^R List Filename Completions] will show you all possible completions.
-\\[^R Yank Default String] will insert the default (if there is one.)")
-
-(define-key "Prompt for Pathname" #\Return "^R Terminate Input")
-(define-key "Prompt for Pathname" #\C-M-Y "^R Yank Default String")
-(define-key "Prompt for Pathname" #\Space "^R Complete Filename")
-(define-key "Prompt for Pathname" #\Tab "^R Complete Filename")
-(define-key "Prompt for Pathname" #\? "^R List Filename Completions")
\ No newline at end of file
+(define-integrable (prompt-string->pathname string)
+ (string->pathname (os/trim-pathname-string string)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/fileio.scm,v 1.88 1989/04/05 18:19:54 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/fileio.scm,v 1.89 1989/04/15 00:49:27 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(initialize-buffer-modes! buffer)
(initialize-buffer-local-variables! buffer))
-(define (insert-file mark pathname)
- (let ((truename (pathname->input-truename pathname)))
- (if truename
- (region-insert! mark (file->region-interactive truename))
- (editor-error "File \"" (pathname->string pathname) "\" not found"))))
+(define (insert-file mark filename)
+ (let ((pathname (->pathname filename)))
+ (let ((truename (pathname->input-truename pathname)))
+ (if truename
+ (region-insert! mark (file->region-interactive truename))
+ (editor-error "File " (pathname->string pathname) " not found")))))
+
+(define-variable read-file-message
+ "If true, messages are displayed when files are read into the editor."
+ false)
(define (file->region-interactive truename)
- (let ((filename (pathname->string truename)))
- (temporary-message "Reading file \"" filename "\"")
- (let ((region (file->region truename)))
- (append-message " -- done")
- region)))
+ (if (ref-variable read-file-message)
+ (let ((filename (pathname->string truename)))
+ (temporary-message "Reading file \"" filename "\"")
+ (let ((region (file->region truename)))
+ (append-message " -- done")
+ region))
+ (file->region truename)))
(define (file->region pathname)
(call-with-input-file pathname port->region))
mode))))
(filename-default-mode buffer))))
(set-buffer-major-mode! buffer
- (or mode (ref-variable "Editor Default Mode"))))))
+ (or mode (ref-variable editor-default-mode))))))
(define (filename-default-mode buffer)
(let ((entry
(and (string? type)
(assoc-string-ci
type
- (ref-variable "File Type to Major Mode"))))))))
- (and entry (cdr entry))))
+ (ref-variable file-type-to-major-mode))))))))
+ (and entry (name->mode (cdr entry)))))
(define assoc-string-ci
(association-procedure string-ci=? car))
(define (parse-buffer-mode-header buffer)
- (fluid-let (((ref-variable "Case Fold Search") true))
- (let ((start (buffer-start buffer)))
- (let ((end (line-end start 0)))
- (let ((start (re-search-forward "-\\*-[ \t]*" start end)))
- (and start
- (re-search-forward "[ \t]*-\\*-" start end)
- (parse-mode-header start (re-match-start 0))))))))
+ (with-variable-value! (ref-variable-object case-fold-search) true
+ (lambda ()
+ (let ((start (buffer-start buffer)))
+ (let ((end (line-end start 0)))
+ (let ((start (re-search-forward "-\\*-[ \t]*" start end)))
+ (and start
+ (re-search-forward "[ \t]*-\\*-" start end)
+ (parse-mode-header start (re-match-start 0)))))))))
(define (parse-mode-header start end)
(if (not (char-search-forward #\: start end))
\f
;;;; Local Variable Initialization
-(define-variable "Local Variable Search Limit"
+(define-variable local-variable-search-limit
"The maximum number of characters searched when looking for local variables
at the end of a file."
3000)
(let ((start
(with-narrowed-region!
(make-region (mark- end
- (ref-variable "Local Variable Search Limit")
+ (ref-variable local-variable-search-limit)
'LIMIT)
end)
(lambda ()
(backward-one-page end)))))
(if start
- (fluid-let (((ref-variable "Case Fold Search") true))
- (if (re-search-forward "Edwin Variables:[ \t]*" start)
- (parse-local-variables buffer
- (re-match-start 0)
- (re-match-end 0)))))))))
+ (with-variable-value! (ref-variable-object case-fold-search) true
+ (lambda ()
+ (if (re-search-forward "Edwin Variables:[ \t]*" start)
+ (parse-local-variables buffer
+ (re-match-start 0)
+ (re-match-end 0))))))))))
(define (evaluate sexp)
(scode-eval (syntax sexp system-global-syntax-table)
system-global-environment))
-
-(define ((local-binding-thunk name value))
- (make-local-binding! name value))
\f
(define (parse-local-variables buffer start end)
(let ((prefix (extract-string (line-start start 0) start))
(evaluate val)
(add-buffer-initialization!
buffer
- (local-binding-thunk
- (variable-symbol (name->variable var))
- (evaluate val)))))))))
+ (let ((variable (name->variable var))
+ (value (evaluate val)))
+ (lambda ()
+ (make-local-binding! variable
+ value))))))))))
(loop m4))))))))
(loop start))))
+
)
\f
;;;; Output
-(define-variable "Require Final Newline"
+(define-variable require-final-newline
"True says silently put a newline at the end whenever a file is saved.
Neither false nor true says ask user whether to add a newline in each
such case. False means don't add newlines."
false)
-(define-variable "Make Backup Files"
+(define-variable make-backup-files
"*Create a backup of each file when it is saved for the first time.
This can be done by renaming the file or by copying.
The file's owner and group are unchanged.
The choice of renaming or copying is controlled by the variables
-Backup By Copying, Backup By Copying When Linked and
-Backup By Copying When Mismatch."
+backup-by-copying , backup-by-copying-when-linked and
+backup-by-copying-when-mismatch ."
true)
-(define-variable "Backup By Copying"
+(define-variable backup-by-copying
"*True means always use copying to create backup files.
-See documentation of variable Make Backup Files."
+See documentation of variable make-backup-files."
false)
-(define-variable "Trim Versions Without Asking"
+(define-variable trim-versions-without-asking
"*If true, deletes excess backup versions silently.
Otherwise asks confirmation."
false)
(set-buffer-modification-time! buffer
(file-modification-time truename))))))
-(define (write-region region pathname)
- (let ((truename (pathname->output-truename pathname)))
+(define (write-region region filename)
+ (let ((truename (pathname->output-truename (->pathname filename))))
(temporary-message "Writing file \"" (pathname->string truename) "\"")
(region->file region truename)
(append-message " -- done")
(write-string (region->string region) port))))
\f
(define (require-newline buffer)
- (let ((require-final-newline? (ref-variable "Require Final Newline")))
+ (let ((require-final-newline? (ref-variable require-final-newline)))
(if require-final-newline?
(without-group-clipped! (buffer-group buffer)
(lambda ()
(define (backup-buffer! buffer truename)
(let ((continue-with-false (lambda () false)))
(and truename
- (ref-variable "Make Backup Files")
+ (ref-variable make-backup-files)
(not (buffer-backed-up? buffer))
(file-exists? truename)
(os/backup-buffer? truename)
false))
(lambda ()
(if (or (file-symbolic-link? truename)
- (ref-variable "Backup By Copying")
+ (ref-variable backup-by-copying)
(os/backup-by-copying? truename))
(begin
(copy-file truename backup-pathname)
(file-modes backup-pathname)))))))
(set-buffer-backed-up?! buffer true)
(if (and (not (null? targets))
- (or (ref-variable "Trim Versions Without Asking")
+ (or (ref-variable trim-versions-without-asking)
(prompt-for-confirmation?
(string-append
"Delete excess backup versions of "
(lambda ()
(delete-file target))))
targets))
- modes))))))))
-
-(define (catch-file-errors if-error thunk)
- (call-with-current-continuation
- (lambda (continuation)
- (bind-condition-handler
- (list error-type:file)
- (lambda (condition)
- condition
- (continuation (if-error)))
- thunk))))
\ No newline at end of file
+ modes))))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/fill.scm,v 1.41 1989/03/14 08:00:45 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/fill.scm,v 1.42 1989/04/15 00:49:34 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define-command ("^R Fill Paragraph")
+(define-command fill-paragraph
"Fill this (or next) paragraph.
Point stays the same."
- (fill-region (paragraph-text-region (current-point))))
+ ()
+ (lambda ()
+ (fill-region (paragraph-text-region (current-point)))))
-(define-command ("^R Fill Region")
+(define-command fill-region
"Fill text from point to mark."
- (fill-region (current-region)))
+ "r"
+ (lambda (region)
+ (fill-region region)))
-(define-variable "Fill Column"
- "Controls where ^R Fill Paragraph and Auto Fill mode put the right margin."
+(define-variable fill-column
+ "Controls where \\[fill-paragraph] and auto-fill mode put the right margin."
70)
-(define-command ("^R Set Fill Column" argument)
+(define-command set-fill-column
"Set fill column to argument or current column.
If an argument is given, that is used.
Otherwise the current position of the cursor is used."
- (local-set-variable! "Fill Column"
- (or argument (current-column)))
- (temporary-message "Fill column set to "
- (write-to-string (ref-variable "Fill Column"))))
-
-(define-variable "Fill Prefix"
- "String for Auto Fill to insert at start of new line, or #F."
+ "P"
+ (lambda (argument)
+ (let ((column (or argument (current-column))))
+ (local-set-variable! fill-column column)
+ (temporary-message "Fill column set to " (write-to-string column)))))
+
+(define-variable fill-prefix
+ "String for auto-fill to insert at start of new line, or #F."
false)
-(define-command ("^R Set Fill Prefix")
- "Set fill prefix to text between point and start of line."
- (if (line-start? (current-point))
- (begin (local-set-variable! "Fill Prefix" false)
- (temporary-message "Fill prefix cancelled"))
- (let ((string (extract-string (line-start (current-point) 0))))
- (local-set-variable! "Fill Prefix" string)
- (temporary-message "Fill prefix now \""
- (ref-variable "Fill Prefix")
- "\""))))
-\f
-(define fill-region)
-(let ()
-
-(set! fill-region
-(named-lambda (fill-region region)
- (let ((start (region-start region))
- (end (region-end region)))
- (let ((start (mark-right-inserting (skip-chars-forward "\n" start end)))
- (end (mark-left-inserting (skip-chars-backward "\n" end start))))
- (with-narrowed-region! (make-region start end)
- (lambda ()
- (canonicalize-sentence-endings start)
- (remove-fill-prefix start)
- (canonicalize-spacing start)
- (delete-horizontal-space end)
- (fill-region-loop start)))))))
+(define-command set-fill-prefix
+ "Set fill-prefix to text between point and start of line."
+ ()
+ (lambda ()
+ (if (line-start? (current-point))
+ (begin
+ (local-set-variable! fill-prefix false)
+ (temporary-message "Fill prefix cancelled"))
+ (let ((string (extract-string (line-start (current-point) 0))))
+ (local-set-variable! fill-prefix string)
+ (temporary-message "Fill prefix now \""
+ (ref-variable fill-prefix)
+ "\"")))))
\f
-(define (fill-region-loop start)
- (if (not (group-end? start))
- (begin
- (if (ref-variable "Fill Prefix")
- (insert-string (ref-variable "Fill Prefix") start))
- (let ((target (move-to-column start (ref-variable "Fill Column"))))
- (if (not (group-end? target))
- (let ((end
- (cond ((char-search-backward #\Space (mark1+ target) start)
- (re-match-end 0))
- ((char-search-forward #\Space target)
- (re-match-start 0))
- (else false))))
- (if end
- (let ((start (mark-left-inserting end)))
- (delete-horizontal-space start)
- (insert-newline start)
- (fill-region-loop start)))))))))
-
-(define (canonicalize-sentence-endings mark)
- (let ((ending (forward-sentence mark 1 false)))
- (if (and ending (not (group-end? ending)))
- (if (char=? #\newline (mark-right-char ending))
- (let ((mark (mark-left-inserting ending)))
- (insert-char #\Space mark)
- (canonicalize-sentence-endings mark))
- (canonicalize-sentence-endings ending)))))
-
-(define (canonicalize-spacing mark)
- (if (char-search-forward #\newline mark)
- (let ((mark (mark-left-inserting (re-match-start 0))))
- (replace-next-char mark #\Space)
- (remove-fill-prefix mark)
- (canonicalize-spacing mark))))
-
-(define (remove-fill-prefix mark)
- (if (ref-variable "Fill Prefix")
- (let ((end (match-forward (ref-variable "Fill Prefix") mark)))
- (if end (delete-string mark end)))))
-
-(define (replace-next-char mark char)
- (delete-string mark (mark1+ mark))
- (insert-char char mark))
-
-)
+(define fill-region
+ (let ()
+ (define (fill-region-loop start)
+ (if (not (group-end? start))
+ (begin
+ (if (ref-variable fill-prefix)
+ (insert-string (ref-variable fill-prefix) start))
+ (let ((target (move-to-column start (ref-variable fill-column))))
+ (if (not (group-end? target))
+ (let ((end
+ (cond ((char-search-backward #\Space
+ (mark1+ target)
+ start)
+ (re-match-end 0))
+ ((char-search-forward #\Space target)
+ (re-match-start 0))
+ (else false))))
+ (if end
+ (let ((start (mark-left-inserting end)))
+ (delete-horizontal-space start)
+ (insert-newline start)
+ (fill-region-loop start)))))))))
+
+ (define (canonicalize-sentence-endings mark)
+ (let ((ending (forward-sentence mark 1 false)))
+ (if (and ending (not (group-end? ending)))
+ (if (char=? #\newline (mark-right-char ending))
+ (let ((mark (mark-left-inserting ending)))
+ (insert-char #\Space mark)
+ (canonicalize-sentence-endings mark))
+ (canonicalize-sentence-endings ending)))))
+
+ (define (canonicalize-spacing mark)
+ (if (char-search-forward #\newline mark)
+ (let ((mark (mark-left-inserting (re-match-start 0))))
+ (replace-next-char mark #\Space)
+ (remove-fill-prefix mark)
+ (canonicalize-spacing mark))))
+
+ (define (remove-fill-prefix mark)
+ (if (ref-variable fill-prefix)
+ (let ((end (match-forward (ref-variable fill-prefix) mark)))
+ (if end (delete-string mark end)))))
+
+ (define (replace-next-char mark char)
+ (delete-string mark (mark1+ mark))
+ (insert-char char mark))
+
+ (named-lambda (fill-region region)
+ (let ((start (region-start region))
+ (end (region-end region)))
+ (let ((start
+ (mark-right-inserting (skip-chars-forward "\n" start end)))
+ (end (mark-left-inserting (skip-chars-backward "\n" end start))))
+ (with-narrowed-region! (make-region start end)
+ (lambda ()
+ (canonicalize-sentence-endings start)
+ (remove-fill-prefix start)
+ (canonicalize-spacing start)
+ (delete-horizontal-space end)
+ (fill-region-loop start))))))))
\f
-(define-command ("Auto Fill Mode" argument)
- "Toggle Auto Fill mode.
-With argument, turn Auto Fill mode on iff argument is positive."
- (cond ((and (or (not argument) (positive? argument))
- (not (current-minor-mode? fill-mode)))
- (enable-current-minor-mode! fill-mode))
- ((and (or (not argument) (not (positive? argument)))
- (current-minor-mode? fill-mode))
- (disable-current-minor-mode! fill-mode))))
-
-(define-command ("^R Auto Fill Space" (argument 1))
+(define-command auto-fill-mode
+ "Toggle auto-fill mode.
+With argument, turn auto-fill mode on iff argument is positive."
+ "P"
+ (lambda (argument)
+ (let ((mode (ref-mode-object auto-fill)))
+ (cond ((and (or (not argument) (positive? argument))
+ (not (current-minor-mode? mode)))
+ (enable-current-minor-mode! mode))
+ ((and (or (not argument) (not (positive? argument)))
+ (current-minor-mode? mode))
+ (disable-current-minor-mode! mode))))))
+
+(define-command auto-fill-space
"Breaks the line if it exceeds the fill column, then inserts a space."
- (insert-chars #\Space argument)
- (auto-fill-break))
+ "p"
+ (lambda (argument)
+ (insert-chars #\Space argument)
+ (auto-fill-break)))
-(define-command ("^R Auto Fill Newline" argument)
+(define-command auto-fill-newline
"Breaks the line if it exceeds the fill column, then inserts a newline."
- (auto-fill-break)
- (^r-newline-command argument))
+ "P"
+ (lambda (argument)
+ (auto-fill-break)
+ ((ref-command newline) argument)))
-(define-minor-mode "Fill"
- "")
+(define-minor-mode auto-fill "Fill" "")
-(define-key "Fill" #\Space "^R Auto Fill Space")
-(define-key "Fill" #\Return "^R Auto Fill Newline")
+(define-key 'auto-fill #\space 'auto-fill-space)
+(define-key 'auto-fill #\return 'auto-fill-newline)
(define (auto-fill-break)
(let ((point (current-point)))
(if (re-search-backward "[^ \t][ \t]+"
(move-to-column
point
- (1+ (ref-variable "Fill Column")))
+ (1+ (ref-variable fill-column)))
(line-start point 0))
(with-current-point (re-match-end 0)
- ^r-indent-new-comment-line-command)))))
+ (ref-command indent-new-comment-line))))))
(define (auto-fill-break? point)
- (and (> (mark-column point) (ref-variable "Fill Column"))
+ (and (> (mark-column point) (ref-variable fill-column))
(line-end? (horizontal-space-end point))))
-\f
-(define-command ("^R Center Line")
- "Center this line's text within the line.
-The width is Fill Column."
- (center-line (current-point)))
-(define-variable "Left Margin"
- "The number of columns to indent each line."
- 0)
+(define-variable left-margin
+ "The number of columns to indent each line." 0)
(define (center-line mark)
(mark-permanent! mark)
(delete-horizontal-space (line-start mark 0))
(delete-horizontal-space (line-end mark 0))
- (let ((d (- (- (ref-variable "Fill Column") (ref-variable "Left Margin"))
+ (let ((d (- (- (ref-variable fill-column) (ref-variable left-margin))
(mark-column (line-end mark 0)))))
(if (positive? d)
- (insert-horizontal-space (+ (ref-variable "Left Margin")
- (quotient d 2))
- (line-start mark 0)))))
\ No newline at end of file
+ (insert-horizontal-space (+ (ref-variable left-margin) (quotient d 2))
+ (line-start mark 0)))))
+
+(define-command center-line
+ "Center the line point is on, within the width specified by `fill-column'.
+This means adjusting the indentation to match
+the distance between the end of the text and `fill-column'."
+ "d"
+ center-line)
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/grpops.scm,v 1.2 1989/03/30 16:39:53 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/grpops.scm,v 1.3 1989/04/15 00:49:40 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(define gap-allocation-extra 2000)
-(define-integrable (barf-if-read-only group)
- (if (group-read-only? group)
- (editor-error "Trying to modify read only text.")))
-
(define (group-insert-char! group index char)
(without-interrupts
(lambda ()
(record-insertion! group index (group-gap-start group)))))
(define-integrable (%group-insert-char! group index char)
- (barf-if-read-only group)
+ (if (group-read-only? group) (barf-if-read-only))
(move-gap-to! group index)
(guarantee-gap-length! group 1)
(string-set! (group-text group) index char)
(record-insertion! group index (group-gap-start group)))))
(define-integrable (%group-insert-substring! group index string start end)
- (barf-if-read-only group)
+ (if (group-read-only? group) (barf-if-read-only))
(move-gap-to! group index)
(let ((n (- end start)))
(guarantee-gap-length! group n)
(lambda ()
(if (not (= start end))
(begin
- (barf-if-read-only group)
+ (if (group-read-only? group) (barf-if-read-only))
(let ((gap-start (group-gap-start group))
(new-end (+ end (group-gap-length group))))
;; Guarantee that the gap is between START and END.
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/hlpcom.scm,v 1.86 1989/04/05 18:21:08 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/hlpcom.scm,v 1.87 1989/04/15 00:49:45 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define-command ("^R Help Prefix")
+(define-command help-prefix
"This is a prefix for more commands.
It reads another character (a subcommand) and dispatches on it."
- (let ((char (prompt-for-char "A C D I K L M T V W or C-h for more help")))
+ "cA C D I K L M T V W or C-h for more help"
+ (lambda (char)
(dispatch-on-char
(current-comtabs)
(list #\Backspace
(if (or (char=? char #\Backspace)
(char=? char #\?))
- (let ((buffer (temporary-buffer "*Help*")))
- (insert-string
- "You have typed C-h, the help character. Type a Help option:
+ (cleanup-pop-up-buffers
+ (lambda ()
+ (let ((buffer (temporary-buffer "*Help*")))
+ (insert-string
+ "You have typed C-h, the help character. Type a Help option:
-A Command apropos. Type a substring, and see a list of commands
+A command-apropos. Type a substring, and see a list of commands
that contain that substring.
-C Describe key briefly. Type a key sequence;
+C describe-key-briefly. Type a key sequence;
it prints the name of the command that sequence runs.
-D Describe command. Type a command name and get its documentation.
-I Info. The Info documentation reader.
-K Describe key. Type a key sequence;
+D describe-command. Type a command name and get its documentation.
+I info. The Info documentation reader.
+K describe-key. Type a key sequence;
it prints the full documentation.
-L View Lossage. Prints the last 100 characters you typed.
-M Describe Mode. Print documentation of current major mode,
+L view-lossage. Prints the last 100 characters you typed.
+M describe-mode. Print documentation of current major mode,
which describes the commands peculiar to it.
-T Help with Tutorial. Select the Emacs learn-by-doing tutorial.
-V Describe variable. Type a variable name and get its documentation.
-W Where is. Type a command name and get its key binding."
- (buffer-point buffer))
- (set-buffer-point! buffer (buffer-start buffer))
- (buffer-not-modified! buffer)
- (pop-up-buffer buffer false)
- (let ((window (get-buffer-window buffer)))
- (define (loop)
- (let ((char
- (char-upcase
- (prompt-for-typein
- "A C D I K L M T V W or space to scroll: "
- keyboard-read-char))))
- (cond ((or (char=? char #\Backspace)
- (char=? char #\?))
- (loop))
- ((or (char=? char #\Space)
- (char=? char #\C-V))
- (scroll-window window
- (standard-scroll-window-argument
- window false 1)
- editor-beep)
- (loop))
- ((or (char=? char #\Rubout)
- (char=? char #\M-V))
- (scroll-window window
- (standard-scroll-window-argument
- window false -1)
- editor-beep)
- (loop))
- (else char))))
- (loop)))
+T help-with-tutorial. Select the Emacs learn-by-doing tutorial.
+V describe-variable. Type a variable name and get its documentation.
+W where-is. Type a command name and get its key binding."
+ (buffer-point buffer))
+ (set-buffer-point! buffer (buffer-start buffer))
+ (buffer-not-modified! buffer)
+ (pop-up-buffer buffer false)
+ (let ((window (get-buffer-window buffer)))
+ (let loop ()
+ (let ((char
+ (prompt-for-char
+ "A C D I K L M T V W or space to scroll"))) (let ((test-for
+ (lambda (char*)
+ (char=? char (remap-alias-char char*)))))
+ (cond ((or (test-for #\C-h)
+ (test-for #\?))
+ (loop))
+ ((or (test-for #\space)
+ (test-for #\C-v))
+ (scroll-window
+ window
+ (standard-scroll-window-argument
+ window false 1)
+ editor-beep)
+ (loop))
+ ((or (test-for #\rubout)
+ (test-for #\M-v))
+ (scroll-window
+ window
+ (standard-scroll-window-argument
+ window false -1)
+ editor-beep)
+ (loop))
+ (else char)))))))))
char)))))
-
-(define-prefix-key "Fundamental" #\Backspace "^R Help Prefix")
-(define-key "Fundamental" '(#\Backspace #\A) "Command Apropos")
-(define-key "Fundamental" '(#\Backspace #\C) "Describe Key Briefly")
-(define-key "Fundamental" '(#\Backspace #\D) "Describe Command")
-(define-key "Fundamental" '(#\Backspace #\I) "Info")
-(define-key "Fundamental" '(#\Backspace #\K) "Describe Key")
-(define-key "Fundamental" '(#\Backspace #\L) "View Lossage")
-(define-key "Fundamental" '(#\Backspace #\M) "Describe Mode")
-(define-key "Fundamental" '(#\Backspace #\T) "Teach Emacs")
-(define-key "Fundamental" '(#\Backspace #\V) "Describe Variable")
-(define-key "Fundamental" '(#\Backspace #\W) "Where Is")
\f
;;;; Commands and Keys
-(define-command ("Command Apropos")
+(define-command command-apropos
"Prompts for a string, lists all commands containing it."
- (let ((string (or (prompt-for-string "Command apropos" false) "")))
+ "sCommand apropos"
+ (lambda (string)
(with-output-to-help-display
(lambda ()
(for-each (lambda (command)
- (write-string (command-name command))
+ (write-string (command-name-string command))
(newline)
(print-key-bindings command)
(print-short-description (command-description command)))
(string-table-apropos editor-commands string))))))
-(define-command ("Describe Command")
+(define-command describe-command
"Prompts for a command, and describes it.
Prints the full documentation for the given command."
- (let ((command (prompt-for-command "Describe Command")))
- (with-output-to-help-display
- (lambda ()
- (write-string (command-name command))
- (newline)
- (print-key-bindings command)
- (write-description (command-description command))))))
+ "CDescribe command"
+ (lambda (name)
+ (help-describe-command (name->command name))))
+
+(define (help-describe-command command)
+ (with-output-to-help-display
+ (lambda ()
+ (write-string (command-name-string command))
+ (write-string ":\n")
+ (write-description (command-description command)))))
-(define-command ("Where Is")
+(define-command where-is
"Prompts for a command, and shows what key it is bound to."
- (let ((command (prompt-for-command "Where is command")))
- (let ((bindings (comtab-key-bindings (current-comtabs) command)))
- (if (null? bindings)
- (message "\"" (command-name command) "\" is not on any keys")
- (message "\"" (command-name command) "\" is on "
- (xchar->name (car bindings)))))))
+ "CWhere is command"
+ (lambda (name)
+ (let ((command (name->command name)))
+ (let ((bindings (comtab-key-bindings (current-comtabs) command)))
+ (if (null? bindings)
+ (message (command-name-string command) " is not on any keys")
+ (message (command-name-string command) " is on "
+ (xchar->name (car bindings))))))))
-(define-command ("Describe Key Briefly")
+(define-command describe-key-briefly
"Prompts for a key, and describes the command it is bound to.
Prints the brief documentation for that command."
- (let ((char (prompt-for-key "Describe key briefly" (current-comtabs))))
- (let ((command (comtab-entry (current-comtabs) char)))
- (if (eq? command (name->command "^R Bad Command"))
- (help-describe-unbound-key char)
- (message (xchar->name char)
- " runs the command \""
- (command-name command)
- "\"")))))
+ "kDescribe key briefly"
+ (lambda (key)
+ (let ((command (comtab-entry (current-comtabs) key)))
+ (if (eq? command (ref-command-object ^r-bad-command))
+ (help-describe-unbound-key key)
+ (message (xchar->name key)
+ " runs the command "
+ (command-name-string command))))))
-(define-command ("Describe Key")
+(define-command describe-key
"Prompts for a key, and describes the command it is bound to.
Prints the full documentation for that command."
- (let ((char (prompt-for-key "Describe key" (current-comtabs))))
- (let ((command (comtab-entry (current-comtabs) char)))
- (if (eq? command (name->command "^R Bad Command"))
- (help-describe-unbound-key char)
- (with-output-to-help-display
- (lambda ()
- (write-string (string-append (xchar->name char)
- " runs the command \""
- (command-name command)
- "\":"))
- (newline)
- (write-description (command-description command))))))))
+ "kDescribe key"
+ (lambda (key)
+ (let ((command (comtab-entry (current-comtabs) key)))
+ (if (eq? command (ref-command-object ^r-bad-command))
+ (help-describe-unbound-key key)
+ (help-describe-command command)))))
-(define (help-describe-unbound-key char)
- (message (xchar->name char) " is undefined"))
+(define (help-describe-unbound-key key)
+ (message (xchar->name key) " is undefined"))
\f
;;;; Variables
-(define-command ("Variable Apropos")
+(define-command variable-apropos
"Prompts for a string, lists all variables containing it."
- (let ((string (or (prompt-for-string "Variable apropos" false) "")))
+ "sVariable apropos"
+ (lambda (string)
(with-output-to-help-display
(lambda ()
(for-each (lambda (variable)
- (write-string (variable-name variable))
+ (write-string (variable-name-string variable))
(newline)
(print-variable-binding variable)
(print-short-description (variable-description variable)))
(string-table-apropos editor-variables string))))))
-(define-command ("Describe Variable")
+(define-command describe-variable
"Prompts for a variable, and describes it.
Prints the full documentation for the given variable."
- (let ((variable (prompt-for-variable "Describe Variable")))
- (with-output-to-help-display
- (lambda ()
- (write-string (variable-name variable))
- (newline)
- (print-variable-binding variable)
- (write-description (variable-description variable))))))
+ "vDescribe variable"
+ (lambda (name)
+ (let ((variable (name->variable name)))
+ (with-output-to-help-display
+ (lambda ()
+ (write-string (variable-name-string variable))
+ (newline)
+ (print-variable-binding variable)
+ (write-string "\nDocumentation:\n")
+ (write-description (variable-description variable)))))))
-(define-command ("Set Variable" argument)
- "Change the value of a variable.
-Prompts for a variable, then sets its value to the argument, if any.
-If no argument is given, reads a Scheme expression and evaluates it,
-using that for the value."
- (let ((variable (prompt-for-variable "Set Variable")))
- (variable-set! variable
- (or argument
- (prompt-for-expression-value
- "Value"
- (write-to-string (variable-ref variable)))))))
+(define-command set-variable
+ "Set VARIABLE to VALUE. VALUE is a Scheme object.
+When using this interactively, supply a Scheme expression for VALUE.
+If you want VALUE to be a string, you must surround it with doublequotes."
+ (lambda ()
+ (let ((variable (prompt-for-variable "Set variable")))
+ (list (variable-name variable)
+ (prompt-for-expression-value
+ (string-append "Set " (variable-name-string variable) " to value")
+ (variable-value variable)))))
+ (lambda (variable value)
+ (set-variable-value! (name->variable variable) value)))
-(define-command ("Make Local Variable" argument)
- "Make a variable have a local value in the current buffer.
-With no argument, the variable's value is unchanged.
-A numeric argument becomes the new value of the variable.
-Just \\[^R Universal Argument] means prompt for the new value."
- (let ((variable (prompt-for-variable "Make Local Variable")))
- (make-local-binding! (variable-symbol variable)
- (cond ((not argument) (variable-ref variable))
- ((command-argument-multiplier-only?)
- (prompt-for-expression-value
- "Value"
- (write-to-string (variable-ref variable))))
- (else argument)))))
+(define-command make-local-variable
+ "Make a variable have a local value in the current buffer."
+ (lambda ()
+ (let ((variable (prompt-for-variable "Make local variable")))
+ (list (variable-name variable)
+ (prompt-for-expression-value
+ (string-append "Set " (variable-name-string variable) " to value")
+ (variable-value variable)))))
+ (lambda (variable value)
+ (make-local-binding! (name->variable variable) value)))
-(define-command ("Kill Local Variable")
+(define-command kill-local-variable
"Make a variable use its global value in the current buffer."
- (unmake-local-binding!
- (variable-symbol (prompt-for-variable "Kill Local Variable"))))
+ "vKill local variable"
+ (lambda (name)
+ (unmake-local-binding! (name->variable name))))
\f
;;;; Other Stuff
-(define-command ("View Lossage")
+(define-command view-lossage
"Print the keyboard history."
- (with-output-to-help-display
- (lambda ()
- (for-each (lambda (char)
- (write-string (string-append (char-name char) " ")))
- (reverse (ring-list (current-char-history)))))))
+ ()
+ (lambda ()
+ (with-output-to-help-display
+ (lambda ()
+ (for-each (lambda (char)
+ (write-string (string-append (char-name char) " ")))
+ (reverse (ring-list (current-char-history))))))))
-(define-command ("Describe Mode")
+(define-command describe-mode
"Print the documentation for the current mode."
- (with-output-to-help-display
- (lambda ()
- (write-description (mode-description (current-major-mode))))))
+ ()
+ (lambda ()
+ (with-output-to-help-display
+ (lambda ()
+ (write-description (mode-description (current-major-mode)))))))
-(define-command ("Teach Emacs")
+(define-command help-with-tutorial
"Visit the Emacs learn-by-doing tutorial."
- (delete-other-windows (current-window))
- (let ((pathname
- (merge-pathnames (string->pathname "TUTORIAL")
- (home-directory-pathname))))
- (let ((buffer (pathname->buffer pathname)))
- (if buffer
- (select-buffer buffer)
- (let ((buffer (new-buffer (pathname->buffer-name pathname))))
- (read-buffer buffer edwin-tutorial-pathname)
- (set-buffer-pathname! buffer pathname)
- (set-buffer-truename! buffer false)
+ ()
+ (lambda ()
+ (delete-other-windows (current-window))
+ (let ((pathname
+ (merge-pathnames (string->pathname "TUTORIAL")
+ (home-directory-pathname))))
+ (let ((buffer (pathname->buffer pathname)))
+ (if buffer
(select-buffer buffer)
- (set-current-major-mode! fundamental-mode)
- (disable-buffer-auto-save! buffer)
- (let ((mark
- (mark1+
- (line-end (search-forward "\n<<" (buffer-start buffer))
- 0))))
- (delete-string mark (line-end mark 0))
- (insert-newlines (- (window-y-size (current-window))
- (+ 4 (region-count-lines
- (make-region (buffer-start buffer)
- mark))))
- mark))
- (set-buffer-point! buffer (buffer-start buffer))
- (buffer-not-modified! buffer))))))
+ (let ((buffer (new-buffer (pathname->buffer-name pathname))))
+ (read-buffer buffer edwin-tutorial-pathname) (set-buffer-pathname! buffer pathname)
+ (set-buffer-truename! buffer false)
+ (select-buffer buffer)
+ (set-current-major-mode! (ref-mode-object fundamental))
+ (disable-buffer-auto-save! buffer)
+ (let ((mark
+ (mark1+
+ (line-end (search-forward "\n<<" (buffer-start buffer))
+ 0))))
+ (delete-string mark (line-end mark 0))
+ (insert-newlines (- (window-y-size (current-window))
+ (+ 4 (region-count-lines
+ (make-region (buffer-start buffer)
+ mark))))
+ mark))
+ (set-buffer-point! buffer (buffer-start buffer))
+ (buffer-not-modified! buffer)))))))
\f
(define (with-output-to-help-display thunk)
(with-output-to-temporary-buffer "*Help*" thunk))
", "
(char-list-string (cdr xchars)))))
(define (print-variable-binding variable)
- (write-string " which is ")
- (cond ((variable-unbound? variable)
- (write-string "unbound"))
- ((variable-unassigned? variable)
- (write-string "unassigned"))
- (else
- (write-string "bound to: ")
- (write (variable-ref variable))))
+ (write-string " which is bound to: ")
+ (write (variable-value variable))
(newline))
(define (print-short-description description)
(define (command->key-name command)
(let ((bindings (comtab-key-bindings (current-comtabs) command)))
(if (null? bindings)
- (string-append "M-X " (command-name command))
+ (string-append "M-x " (command-name-string command))
(xchar->name (car bindings)))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/input.scm,v 1.77 1989/03/14 08:01:01 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/input.scm,v 1.78 1989/04/15 00:50:08 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(set-command-prompt! (string-append (command-prompt) string))))
(define (message . args)
- (%message (apply string-append args) false))
+ (%message (message-args->string args) false))
(define (temporary-message . args)
- (%message (apply string-append args) true))
+ (%message (message-args->string args) true))
(define (%message string temporary?)
(if command-prompt-displayed?
(set! message-should-be-erased? temporary?)
(set-message! string))
+(define (message-args->string args)
+ (apply string-append
+ (map (lambda (x) (if (string? x) x (write-to-string x)))
+ args)))
+
(define (append-message . args)
(if (not message-string)
(error "Attempt to append to nonexistent message"))
- (let ((string (string-append message-string (apply string-append args))))
+ (let ((string (string-append message-string (message-args->string args))))
(set! message-string string)
(set-message! string)))
(remap-alias-char (peek-char editor-input-port)))))
(define (keyboard-read-char)
+ (set! keyboard-chars-read (1+ keyboard-chars-read))
(if *executing-keyboard-macro?*
(keyboard-macro-read-char)
(begin
(if (not (keyboard-active? 0))
(begin
(update-screens! false)
- (if (let ((interval (ref-variable "Auto Save Interval"))
+ (if (let ((interval (ref-variable auto-save-interval))
(count *auto-save-keystroke-count*))
(and (positive? interval)
(> count interval)
(cond ((within-typein-edit?)
(if message-string
(begin
- (keyboard-active?
- (if message-should-be-erased?
- read-char-timeout/fast
- read-char-timeout/slow))
+ (keyboard-active? read-char-timeout/slow)
(set! message-string false)
(set! message-should-be-erased? false)
(clear-message!))))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/intmod.scm,v 1.31 1989/03/30 16:39:58 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/intmod.scm,v 1.32 1989/04/15 00:50:13 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define-major-mode "Interaction" "Scheme"
+(define-major-mode interaction scheme "Interaction"
"Major mode for evaluating Scheme expressions interactively.
Same as Scheme mode, except for
-\\[^R Interaction Execute] evaluates the current expression.
-\\[^R Interaction Refresh] deletes the contents of the buffer.
-\\[^R Interaction Yank] yanks the last expression.
-\\[^R Interaction Yank Pop] yanks an earlier expression, replacing a yank."
- (local-set-variable! "Interaction Prompt"
- (ref-variable "Interaction Prompt"))
- (local-set-variable! "Interaction Kill Ring" (make-ring 32))
- (local-set-variable! "Scheme Environment"
- (ref-variable "Scheme Environment"))
- (local-set-variable! "Scheme Syntax-table"
- (ref-variable "Scheme Syntax-table")))
-
-(define-key "Interaction" #\Return "^R Interaction Execute")
-(define-prefix-key "Interaction" #\C-C "^R Prefix Character")
-(define-key "Interaction" '(#\C-C #\Page) "^R Interaction Refresh")
-(define-key "Interaction" '(#\C-C #\C-Y) "^R Interaction Yank")
-(define-key "Interaction" '(#\C-C #\C-R) "^R Interaction Yank Pop")
-
-(define-command ("Interaction Mode")
+\\[interaction-execute] evaluates the current expression.
+\\[interaction-refresh] deletes the contents of the buffer.
+\\[interaction-yank] yanks the last expression.
+\\[interaction-yank-pop] yanks an earlier expression, replacing a yank."
+ (local-set-variable! interaction-prompt (ref-variable interaction-prompt))
+ (local-set-variable! interaction-kill-ring (make-ring 32))
+ (local-set-variable! scheme-environment (ref-variable scheme-environment))
+ (local-set-variable! scheme-syntax-table (ref-variable scheme-syntax-table)))
+
+(define-key 'interaction #\return 'interaction-execute)
+(define-prefix-key 'interaction #\c-c 'prefix-char)
+(define-key 'interaction '(#\c-c #\page) 'interaction-refresh)
+(define-key 'interaction '(#\c-c #\c-y) 'interaction-yank)
+(define-key 'interaction '(#\c-c #\c-r) 'interaction-yank-pop)
+
+(define-command interaction-mode
"Make the current mode be Interaction mode."
- (set-current-major-mode! Interaction-mode)
- (let ((buffer (current-buffer)))
- (if (not (mark= (buffer-start buffer) (buffer-end buffer)))
- (begin (set-current-point! (buffer-end buffer))
- (insert-interaction-prompt))
- (insert-interaction-prompt false))))
+ ()
+ (lambda ()
+ (set-current-major-mode! (ref-mode-object interaction))
+ (let ((buffer (current-buffer)))
+ (if (not (mark= (buffer-start buffer) (buffer-end buffer)))
+ (begin (set-current-point! (buffer-end buffer))
+ (insert-interaction-prompt))
+ (insert-interaction-prompt false)))))
(define (insert-interaction-prompt #!optional newlines?)
(if (or (default-object? newlines?) newlines?)
(insert-newlines 2))
(insert-string "1 ")
- (insert-string (ref-variable "Interaction Prompt"))
+ (insert-string (ref-variable interaction-prompt))
(insert-string " ")
(buffer-put! (current-buffer)
interaction-mode:buffer-mark-tag
(define interaction-mode:buffer-mark-tag
"Mark")
-(define-variable "Interaction Prompt"
+(define-variable interaction-prompt
"Prompt string used by Interaction mode."
"]=>")
-(define-variable "Interaction Kill Ring"
+(define-variable interaction-kill-ring
"Kill ring used by Interaction mode evaluation commands.")
\f
-(define-command ("^R Interaction Execute" argument)
+(define-command interaction-execute
"Evaluate the input expression.
-With an argument, calls ^R Insert Self instead.
+With an argument, calls \\[self-insert-command] instead.
If invoked in the current `editing area', evaluates the expression there.
The editing area is defined as the space between the last prompt and
editing area must be empty.
Output is inserted into the buffer at the end."
- (define (extract-expression start)
- (let ((expression (extract-string start (or (forward-one-sexp start)
- (editor-error "No Expression")))))
- (ring-push! (ref-variable "Interaction Kill Ring") expression)
- expression))
-
- (if argument
- (^r-insert-self-command argument)
- (let ((mark (or (buffer-get (current-buffer)
- interaction-mode:buffer-mark-tag)
- (error "Missing interaction buffer mark")))
- (point (current-point)))
- (if (mark< point (line-start mark 0))
- (begin
- (if (not (group-end? mark))
- (editor-error "Can't copy: unfinished expression"))
- (let ((start (backward-one-sexp (line-end point 0))))
- (if (not start) (editor-error "No previous expression"))
- (let ((expression (extract-expression start)))
- (set-current-point! mark)
- (insert-string expression mark))))
- (let ((state (parse-partial-sexp mark (group-end mark))))
- (if (or (not (zero? (parse-state-depth state)))
- (parse-state-in-string? state)
- (parse-state-in-comment? state)
- (parse-state-quoted? state))
- (editor-error "Imbalanced expression"))
- (let ((last-sexp (parse-state-last-sexp state)))
- (if (not last-sexp)
- (editor-error "No expression"))
- (extract-expression last-sexp))
- (set-current-point! (group-end point))))
- (dynamic-wind
- (lambda () 'DONE)
- (lambda ()
- (with-output-to-current-point
- (lambda ()
- (intercept-^G-interrupts
- (lambda ()
- (newline)
- (write-string "Abort!"))
- (lambda ()
- (write-line
- (eval-with-history (with-input-from-mark mark
- read)
- (evaluation-environment false))))))))
- insert-interaction-prompt))))
+ "P"
+ (lambda (argument)
+ (define (extract-expression start)
+ (let ((expression
+ (extract-string start
+ (or (forward-one-sexp start)
+ (editor-error "No Expression")))))
+ (ring-push! (ref-variable interaction-kill-ring) expression)
+ expression))
+
+ (if argument
+ ((ref-command self-insert-command) argument)
+ (let ((mark (or (buffer-get (current-buffer)
+ interaction-mode:buffer-mark-tag)
+ (error "Missing interaction buffer mark")))
+ (point (current-point)))
+ (if (mark< point (line-start mark 0))
+ (begin
+ (if (not (group-end? mark))
+ (editor-error "Can't copy: unfinished expression"))
+ (let ((start (backward-one-sexp (line-end point 0))))
+ (if (not start) (editor-error "No previous expression"))
+ (let ((expression (extract-expression start)))
+ (set-current-point! mark)
+ (insert-string expression mark))))
+ (let ((state (parse-partial-sexp mark (group-end mark))))
+ (if (or (not (zero? (parse-state-depth state)))
+ (parse-state-in-string? state)
+ (parse-state-in-comment? state)
+ (parse-state-quoted? state))
+ (editor-error "Imbalanced expression"))
+ (let ((last-sexp (parse-state-last-sexp state)))
+ (if (not last-sexp)
+ (editor-error "No expression"))
+ (extract-expression last-sexp))
+ (set-current-point! (group-end point))))
+ (dynamic-wind
+ (lambda () 'DONE)
+ (lambda ()
+ (with-output-to-current-point
+ (lambda ()
+ (intercept-^G-interrupts
+ (lambda ()
+ (newline)
+ (write-string "Abort!"))
+ (lambda ()
+ (write-line
+ (eval-with-history (with-input-from-mark mark
+ read)
+ (evaluation-environment false))))))))
+ insert-interaction-prompt)))))
\f
-(define-command ("^R Interaction Refresh")
+(define-command interaction-refresh
"Delete the contents of the buffer, then prompt for input.
Preserves the current `editing area'."
- (let ((buffer (current-buffer)))
- (let ((edit-area
- (extract-string (buffer-get buffer interaction-mode:buffer-mark-tag)
- (buffer-end buffer))))
- (region-delete! (buffer-region buffer))
- (insert-interaction-prompt false)
- (insert-string edit-area))))
+ ()
+ (lambda ()
+ (let ((buffer (current-buffer)))
+ (let ((edit-area
+ (extract-string
+ (buffer-get buffer interaction-mode:buffer-mark-tag)
+ (buffer-end buffer))))
+ (region-delete! (buffer-region buffer))
+ (insert-interaction-prompt false)
+ (insert-string edit-area)))))
(define interaction-mode:yank-command-message
"Yank")
-(define-command ("^R Interaction Yank")
+(define-command interaction-yank
"Yank the last input expression."
- (push-current-mark! (mark-right-inserting (current-point)))
- (insert-string (ring-ref (ref-variable "Interaction Kill Ring") 0))
- (set-command-message! interaction-mode:yank-command-message))
+ ()
+ (lambda ()
+ (push-current-mark! (mark-right-inserting (current-point)))
+ (insert-string (ring-ref (ref-variable interaction-kill-ring) 0))
+ (set-command-message! interaction-mode:yank-command-message)))
-(define-command ("^R Interaction Yank Pop")
+(define-command interaction-yank-pop
"Yank the last input expression."
- (command-message-receive interaction-mode:yank-command-message
- (lambda ()
- (delete-string (pop-current-mark!) (current-point))
- (push-current-mark! (mark-right-inserting (current-point)))
- (ring-pop! (ref-variable "Interaction Kill Ring"))
- (insert-string (ring-ref (ref-variable "Interaction Kill Ring") 0))
- (set-command-message! interaction-mode:yank-command-message))
- (lambda ()
- (editor-error "No previous yank to replace"))))
\ No newline at end of file
+ ()
+ (lambda ()
+ (command-message-receive interaction-mode:yank-command-message
+ (lambda ()
+ (delete-string (pop-current-mark!) (current-point))
+ (push-current-mark! (mark-right-inserting (current-point)))
+ (ring-pop! (ref-variable interaction-kill-ring))
+ (insert-string (ring-ref (ref-variable interaction-kill-ring) 0))
+ (set-command-message! interaction-mode:yank-command-message))
+ (lambda ()
+ (editor-error "No previous yank to replace")))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/iserch.scm,v 1.1 1989/03/14 08:01:07 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/iserch.scm,v 1.2 1989/04/15 00:50:19 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; without prior written consent from MIT in each case.
;;;
-;;;; Incremental Search Commands
+;;;; Incremental Search
(declare (usual-integrations))
\f
-(define-command ("^R Incremental Search")
- "Search for character string as you type it.
-C-Q quotes special characters. Rubout cancels last character.
-C-S repeats the search, forward, and C-R repeats it backward.
-C-R or C-S with search string empty changes the direction of search
- or brings back search string from previous search.
-Altmode exits the search.
-Other Control and Meta chars exit the search and then are executed.
-If not all the input string can be found, the rest is not discarded.
- You can rub it out, discard it all with C-G, exit,
- or use C-R or C-S to search the other way.
-Quitting a successful search aborts the search and moves point back;
- quitting a failing search just discards whatever input wasn't found."
- (incremental-search true))
-
-(define-command ("^R Reverse Search")
- "Incremental Search Backwards.
-Like \\[^R Incremental Search] but in reverse."
- (incremental-search false))
-
-(define-command ("^R I-Search Append Char")
- "Append this character to the current string being searched."
- (i-search-append-char (current-command-char)))
-
-(define-command ("^R I-Search Append Newline")
- "Append this character to the current string being searched."
- (i-search-append-char #\Newline))
-
-(define-command ("^R I-Search Append Word")
- "Append the next word to the current string being searched."
- (i-search-append-string
- (let ((end-point (search-state-end-point current-search-state)))
- (extract-string end-point (forward-word end-point 1 'LIMIT)))))
-
-(define-command ("^R I-Search Append Line")
- "Append the rest of the line to the current string being searched."
- (i-search-append-string
- (let ((end-point (search-state-end-point current-search-state)))
- (extract-string end-point
- (line-end end-point
- (if (line-end? end-point) 1 0)
- 'LIMIT)))))
-
-(define-command ("^R I-Search Quote Character")
- "Append a quoted character to the current string being searched."
- (i-search-append-char (with-editor-interrupts-disabled keyboard-read-char)))
-
-(define-command ("^R I-Search Editor Command")
- "Exit search and push this character back for normal processing."
- (incremental-search:terminate! current-search-state (current-command-char)))
-
-(define-command ("^R I-Search Next Occurrence")
- "Search for the next occurrence of the current search string."
- (set-current-search-state!
- (incremental-search:next-occurrence current-search-state))
- (i-search-detect-failure current-search-state))
-
-(define-command ("^R I-Search Previous Occurrence")
- "Search for the previous occurrence of the current search string."
- (set-current-search-state!
- (incremental-search:previous-occurrence current-search-state))
- (i-search-detect-failure current-search-state))
-
-(define-command ("^R I-Search Previous State")
- "Revert to the last state the search was in."
- (set-current-search-state!
- (incremental-search:delete-char current-search-state)))
-
-(define-command ("^R I-Search Previous Successful State")
- "Revert to the last successful state and exit search if there is none."
- (incremental-search:pop!))
-
-(define-command ("^R I-Search Terminate")
- "Terminates I-Search Mode."
- (incremental-search:terminate! current-search-state false))
-\f
-(define (i-search-append-char char)
- (i-search-append-string (string char)))
-
-(define (i-search-append-string string)
- (set-current-search-state!
- (incremental-search:append-string current-search-state string))
- (i-search-detect-failure current-search-state))
-
-(define (i-search-detect-failure search-state)
- (if (and (not (search-state-successful? search-state))
- (or (search-state-successful? (search-state-parent search-state))
- (not (eq? (search-state-forward? search-state)
- (search-state-forward?
- (search-state-parent search-state))))))
- (editor-failure)))
-
-(define-major-mode "Incremental Search" #F
- "Major mode for incremental search.
-See \"^R Incremental Search\" for details.")
-
-(define-default-key "Incremental Search" "^R I-Search Editor Command")
-(define-key "Incremental Search" char-set:graphic "^R I-Search Append Char")
-(define-key "Incremental Search" #\Tab "^R I-Search Append Char")
-(define-key "Incremental Search" #\Return "^R I-Search Append Newline")
-(define-key "Incremental Search" #\C-Q "^R I-Search Quote Character")
-(define-key "Incremental Search" #\C-R "^R I-Search Previous Occurrence")
-(define-key "Incremental Search" #\C-S "^R I-Search Next Occurrence")
-(define-key "Incremental Search" #\C-W "^R I-Search Append Word")
-(define-key "Incremental Search" #\C-Y "^R I-Search Append Line")
-(define-key "Incremental Search" #\Rubout "^R I-Search Previous State")
-(define-key "Incremental Search" #\C-G "^R I-Search Previous Successful State")
-(define-key "Incremental Search" #\Altmode "^R I-Search Terminate")
-
-(define incremental-search-exit)
-(define incremental-search-window)
-(define current-search-state)
-
-(define (incremental-search forward?)
- (if (typein-window? (current-window)) (editor-error))
- (let ((old-point (current-point))
- (old-window (current-window))
- (old-case-fold-search (ref-variable "Case Fold Search")))
- (let ((y-point (window-point-y old-window)))
+(define (isearch forward? regexp?)
+ (reset-command-prompt!)
+ (let ((window (current-window)))
+ (let ((point (window-point window))
+ (y-point (window-point-y window)))
(let ((result
- (call-with-current-continuation
- (lambda (continuation)
- (fluid-let ((incremental-search-exit continuation)
- (incremental-search-window old-window)
- (current-search-state false))
- (within-typein-edit
- (lambda ()
- (set-current-major-mode! incremental-search-mode)
- (local-set-variable! "Case Fold Search"
- old-case-fold-search)
- (select-cursor old-window)
- (set-current-search-state!
- (initial-search-state forward? old-point))
- (incremental-search-loop))))))))
+ (with-editor-interrupts-disabled
+ (lambda ()
+ (isearch-loop
+ (initial-search-state false forward? regexp? point))))))
(cond ((eq? result 'ABORT)
- (set-current-point! old-point)
- (window-scroll-y-absolute! (current-window) y-point))
+ (set-window-point! window point)
+ (window-scroll-y-absolute! window y-point)
+ (clear-message))
((command? result)
(dispatch-on-command result))
(else
- (push-current-mark! old-point)
- (if (char? result)
- (execute-char (current-comtabs) result))))))))
+ (push-current-mark! point)
+ (if result (execute-char (current-comtabs) result))))))))
-(define (incremental-search-loop)
- (intercept-^G-interrupts (lambda ()
- (incremental-search:pop!)
- (incremental-search-loop))
- command-reader))
+(define (isearch-loop state)
+ (if (not (keyboard-active? 0))
+ (begin
+ (set-current-point! (search-state-point state))
+ (message (search-state-message state))))
+ (let ((char (keyboard-read-char)))
+ (let ((test-for
+ (lambda (char*)
+ (char=? char (remap-alias-char char*)))))
+ (cond ((test-for (ref-variable search-quote-char))
+ (isearch-append-char
+ state
+ (prompt-for-typein
+ (string-append (search-state-message state) "^Q")
+ false
+ keyboard-read-char)))
+ ((test-for (ref-variable search-exit-char))
+ (if (string-null? (search-state-text state))
+ (if (search-state-forward? state)
+ (if (search-state-regexp? state)
+ (ref-command-object re-search-forward)
+ (ref-command-object search-forward))
+ (if (search-state-regexp? state)
+ (ref-command-object re-search-backward)
+ (ref-command-object search-backward)))
+ (begin
+ (isearch-exit state)
+ false)))
+ ((test-for #\C-g)
+ (editor-beep)
+ (isearch-pop state))
+ ((test-for (ref-variable search-repeat-char))
+ (isearch-continue (search-state-next state true)))
+ ((test-for (ref-variable search-reverse-char))
+ (isearch-continue (search-state-next state false)))
+ ((test-for (ref-variable search-delete-char))
+ (isearch-loop (or (search-state-parent state) (editor-error))))
+ ((test-for (ref-variable search-yank-word-char))
+ (isearch-append-string
+ state
+ (extract-next-word (search-state-end-point state))))
+ ((test-for (ref-variable search-yank-line-char))
+ (isearch-append-string
+ state
+ (extract-rest-of-line (search-state-end-point state))))
+ ((or (not (zero? (char-bits char)))
+ (and (ref-variable search-exit-option)
+ (ascii-controlified? char)))
+ (isearch-exit state)
+ char)
+ (else
+ (isearch-append-char state
+ (if (char=? char #\return)
+ #\newline
+ char)))))))
\f
-(define (incremental-search:append-string state string)
- (let ((text (string-append (search-state-text state) string)))
- (cond ((not (search-state-successful? state))
- (unsuccessful-search-state state text
- (search-state-forward? state)))
- ((search-state-forward? state)
- (find-next-search-state state
- text
- (search-state-start-point state)))
- (else
- (find-previous-search-state
- state text
- (let ((end (search-state-end-point state)))
- (if (or (group-end? end)
- (mark= end (search-state-initial-point state)))
- end
- (mark1+ end))))))))
-
-(define (incremental-search:delete-char state)
- (let ((parent (search-state-parent state)))
- (if (null? parent) (editor-error))
- parent))
-
-(define (incremental-search:terminate! state char)
- (if (and (not char)
- (null? (search-state-parent state)))
- (incremental-search-exit
- (name->command
- (if (search-state-forward? state)
- "Search Forward"
- "Search Backward"))))
- (save-search-state-text! state)
- (set-window-point!
- incremental-search-window
+(define (isearch-append-char state char)
+ (isearch-append-string state (string char)))
+
+(define (isearch-append-string state string)
+ (isearch-continue (search-state-append-string state string)))
+
+(define (isearch-continue state)
+ (if (and (not (search-state-successful? state))
+ (let ((parent (search-state-parent state)))
+ (or (search-state-successful? parent)
+ (not (eq? (search-state-forward? state)
+ (search-state-forward? parent))))))
+ (editor-failure))
+ (isearch-loop state))
+
+(define (isearch-pop state)
+ (let ((success (most-recent-successful-search-state state)))
+ (if (eq? success state)
+ 'ABORT
+ (isearch-loop success))))
+
+(define (isearch-exit state)
+ (set-current-point!
(search-state-point (most-recent-successful-search-state state)))
- (incremental-search-exit char))
-
-(define (incremental-search:pop!)
- (let ((success (most-recent-successful-search-state current-search-state)))
- (if (eq? success current-search-state)
- (begin (save-search-state-text! success)
- (incremental-search-exit 'ABORT))
- (set-current-search-state! success))))
-
-(define (save-search-state-text! state)
- (if (not (null? (search-state-parent state)))
- (set-variable! "Previous Search String" (search-state-text state))))
+ (if (not (string-null? (search-state-text state)))
+ (let ((text (search-state-text state)))
+ (if (search-state-regexp? state)
+ (set-variable! search-last-regexp text)
+ (set-variable! search-last-string text)))))
+
+(define (extract-next-word mark)
+ (extract-string mark (forward-word mark 1 'LIMIT)))
+
+(define (extract-rest-of-line mark)
+ (extract-string mark (line-end mark (if (line-end? mark) 1 0) 'LIMIT)))
+
+(define (search-state-message state)
+ (let ((invalid-regexp (search-state-invalid-regexp state)))
+ (let ((m
+ (string-append
+ (if (search-state-successful? state) "" "failing ")
+ (if (search-state-wrapped? state) "wrapped " "")
+ (if (search-state-regexp? state) "regexp " "")
+ "I-search"
+ (if (search-state-forward? state) "" " backward")
+ ": "
+ (image-representation (make-image (search-state-text state))) (if invalid-regexp (string-append " [" invalid-regexp "]") ""))))
+ (string-set! m 0 (char-upcase (string-ref m 0)))
+ m)))
\f
-(define (incremental-search:next-occurrence state)
- (cond ((null? (search-state-parent state))
- (let ((point (search-state-initial-point state)))
- (if (not (search-state-forward? state))
- (initial-search-state true point)
- (begin
- (insert-string (ref-variable "Previous Search String"))
- (find-next-search-state state
- (ref-variable "Previous Search String")
- point)))))
- ((search-state-successful? state)
- (find-next-search-state state
- (search-state-text state)
- ((if (search-state-forward? state)
- search-state-end-point
- search-state-start-point)
- state)))
- ((not (search-state-forward? state))
- (find-next-search-state state
- (search-state-text state)
- (search-state-point state)))
- (else
- (unsuccessful-search-state state (search-state-text state) true))))
-
-(define (incremental-search:previous-occurrence state)
- (cond ((null? (search-state-parent state))
- (let ((point (search-state-initial-point state)))
- (if (search-state-forward? state)
- (initial-search-state false point)
- (begin
- (insert-string (ref-variable "Previous Search String"))
- (find-previous-search-state
- state
- (ref-variable "Previous Search String")
- point)))))
- ((search-state-successful? state)
- (find-previous-search-state state
- (search-state-text state)
- ((if (search-state-forward? state)
- search-state-end-point
- search-state-start-point)
- state)))
- ((search-state-forward? state)
- (find-previous-search-state state
- (search-state-text state)
- (search-state-point state)))
+(define (search-state-append-string state string)
+ (let ((text (string-append (search-state-text state) string)))
+ (if (search-state-successful? state)
+ (next-search-state
+ state
+ text
+ (search-state-forward? state)
+ (cond ((and (search-state-regexp? state)
+ (string-find-next-char-in-set string regexp-retry-chars))
+ (search-state-initial-point state))
+ ((search-state-forward? state)
+ (search-state-start-point state))
+ (else
+ (let ((end
+ (mark+ (search-state-end-point state)
+ (string-length string)))
+ (initial-point (search-state-initial-point state)))
+ (if (and end (mark< end initial-point))
+ end
+ initial-point))))
+ (search-state-initial-point state))
+ (unsuccessful-search-state state
+ text
+ (search-state-forward? state)))))
+
+(define regexp-retry-chars
+ ;; If one of these characters is entered, retry the regexp search
+ ;; from the initial point since it may now match something that it
+ ;; didn't match before.
+ (char-set #\* #\? #\|))
+
+(define (search-state-next state forward?)
+ (cond ((not (string-null? (search-state-text state)))
+ (let ((start
+ (cond ((search-state-successful? state)
+ (if (search-state-forward? state)
+ (search-state-end-point state)
+ (search-state-start-point state)))
+ (forward?
+ (if (search-state-forward? state)
+ (buffer-start (current-buffer))
+ (search-state-point state)))
+ (else
+ (if (search-state-forward? state)
+ (search-state-point state)
+ (buffer-end (current-buffer)))))))
+ (next-search-state state
+ (search-state-text state)
+ forward?
+ start
+ start)))
+ ((eq? forward? (search-state-forward? state))
+ (next-search-state state
+ (if (search-state-regexp? state)
+ (ref-variable search-last-regexp)
+ (ref-variable search-last-string))
+ forward?
+ (search-state-initial-point state)
+ (search-state-initial-point state)))
(else
- (unsuccessful-search-state state (search-state-text state) false))))
+ (initial-search-state state
+ forward?
+ (search-state-regexp? state)
+ (search-state-initial-point state)))))
\f
-(define (initial-search-state forward? point)
- (make-search-state "" '() forward? true point point point point))
+(define-structure (search-state)
+ (text false read-only true)
+ (parent false read-only true)
+ (forward? false read-only true)
+ (regexp? false read-only true)
+ (successful? false read-only true)
+ (wrapped? false read-only true)
+ (invalid-regexp false read-only true)
+ (start-point false read-only true)
+ (end-point false read-only true)
+ (point false read-only true)
+ (initial-point false read-only true))
+
+(define (most-recent-successful-search-state state)
+ (if (search-state-successful? state)
+ state
+ (most-recent-successful-search-state
+ (or (search-state-parent state)
+ (error "Search state chain terminated improperly")))))
+
+(define (initial-search-state parent forward? regexp? point)
+ (make-search-state ""
+ parent
+ forward?
+ regexp?
+ true
+ false
+ false
+ point
+ point
+ point
+ point))
(define (unsuccessful-search-state parent text forward?)
(let ((start-point (search-state-start-point parent)))
- (make-search-state text parent forward? false
+ (make-search-state text
+ parent
+ forward?
+ (search-state-regexp? parent)
+ false
+ (search-state-wrapped? parent)
+ false
start-point
(mark+ start-point (string-length text))
(search-state-point parent)
(search-state-initial-point parent))))
-
-(define (find-next-search-state state text start)
- (if (search-forward text start)
- (let ((start-point (re-match-start 0))
- (end-point (re-match-end 0)))
- (make-search-state text state true true
- start-point end-point end-point
- (if (search-state-forward? state)
- (search-state-initial-point state)
- (search-state-start-point state))))
- (unsuccessful-search-state state text true)))
-
-(define (find-previous-search-state state text start)
- (if (search-backward text start)
- (let ((start-point (re-match-start 0))
- (end-point (re-match-end 0)))
- (make-search-state text state false true
- start-point end-point start-point
- (if (search-state-forward? state)
- (search-state-end-point state)
- (search-state-initial-point state))))
- (unsuccessful-search-state state text false)))
-
-(define (set-current-search-state! state)
- (let ((window (current-window)))
- (let ((point (window-point window)))
- (region-delete! (buffer-region (window-buffer window)))
- (region-insert-string!
- point
- (string-append (if (search-state-successful? state)
- "" "Failing ")
- (if (search-state-forward? state)
- "" "Reverse ")
- "I-Search: "))
- (region-insert-string!
- point
- (image-representation (make-image (search-state-text state))))
- (window-direct-update! window false)))
- (if (not (keyboard-active? 0))
- (set-window-point! incremental-search-window (search-state-point state)))
- (set! current-search-state state)
- unspecific)
-
-(define (most-recent-successful-search-state state)
- (cond ((search-state-successful? state)
- state)
- ((null? (search-state-parent state))
- (error "Search state chain terminated improperly"))
- (else
- (most-recent-successful-search-state (search-state-parent state)))))
\f
-(define-named-structure "Search-State"
- text
- parent
- forward?
- successful?
- start-point
- end-point
- point
- initial-point)
-
-(define (make-search-state text parent forward? successful?
- start-point end-point point initial-point)
- (let ((state (%make-search-state)))
- (vector-set! state search-state-index:text text)
- (vector-set! state search-state-index:parent parent)
- (vector-set! state search-state-index:forward? forward?)
- (vector-set! state search-state-index:successful? successful?)
- (vector-set! state search-state-index:start-point start-point)
- (vector-set! state search-state-index:end-point end-point)
- (vector-set! state search-state-index:point point)
- (vector-set! state search-state-index:initial-point initial-point)
- state))
\ No newline at end of file
+(define (next-search-state parent text forward? start initial-point)
+ (let ((regexp? (search-state-regexp? parent)))
+ (let ((result (perform-search forward? regexp? text start)))
+ (cond ((not result)
+ (unsuccessful-search-state parent text forward?))
+ ((eq? result 'ABORT)
+ (most-recent-successful-search-state parent))
+ ((string? result)
+ (make-search-state text
+ parent
+ forward?
+ regexp?
+ (search-state-successful? parent)
+ (search-state-wrapped? parent)
+ (if (or (string-prefix? "Premature " result)
+ (string-prefix? "Unmatched " result))
+ "incomplete input"
+ result)
+ (search-state-start-point parent)
+ (search-state-end-point parent)
+ (search-state-point parent)
+ (search-state-initial-point parent)))
+ (else
+ (make-search-state text
+ parent
+ forward?
+ regexp?
+ true
+ (or (search-state-wrapped? parent)
+ (not (search-state-successful? parent)))
+ false
+ (re-match-start 0)
+ (re-match-end 0)
+ result
+ initial-point))))))
+
+(define (perform-search forward? regexp? text start)
+ (call-with-current-continuation
+ (lambda (continuation)
+ (bind-condition-handler
+ (list error-type:re-compile-pattern)
+ (lambda (condition)
+ (continuation (car (condition/irritants condition))))
+ (lambda ()
+ (intercept-^G-interrupts (lambda () 'ABORT)
+ (lambda ()
+ (with-editor-interrupts-enabled
+ (lambda ()
+ (if forward?
+ (if regexp?
+ (re-search-forward text start)
+ (search-forward text start))
+ (if regexp?
+ (re-search-backward text start)
+ (search-backward text start))))))))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/keymap.scm,v 1.5 1989/03/14 08:01:09 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/keymap.scm,v 1.6 1989/04/15 00:50:29 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define-command ("Make Command Summary")
+(define-command make-command-summary
"Make a summary of current key bindings in the buffer *Summary*.
Previous contents of that buffer are killed first."
- (let ((buffer (temporary-buffer "*Summary*")))
- (with-output-to-mark (buffer-point buffer)
- (lambda ()
- (write-keymap
- ""
- (comtab-dispatch-alists (car (mode-comtabs fundamental-mode))))))
- (select-buffer buffer)
- (set-current-point! (buffer-start buffer))))
+ ()
+ (lambda ()
+ (let ((buffer (temporary-buffer "*Summary*")))
+ (with-output-to-mark (buffer-point buffer)
+ (lambda ()
+ (write-keymap
+ ""
+ (comtab-dispatch-alists
+ (car (mode-comtabs (ref-mode-object fundamental)))))))
+ (select-buffer buffer)
+ (set-current-point! (buffer-start buffer)))))
(define (write-keymap prefix da)
(for-each (lambda (element)
(write-string prefix)
(write-string (pad-on-right-to (char-name (car element)) 9))
(write-string " ")
- (write-string (command-name (cdr element)))
+ (write-string (command-name-string (cdr element)))
(newline))
(sort-by-char (filter-uninteresting (cdr da))))
(for-each (lambda (element)
(define (uninteresting-element? element)
(or (char-lower-case? (char-base (car element)))
- (let ((name (command-name (cdr element))))
- (or (string=? name "^R Insert Self")
- (string=? name "^R Negative Argument")
- (string=? name "^R Argument Digit")
- (string=? name "^R Auto Negative Argument")
- (string=? name "^R Autoargument Digit")
- (string=? name "^R Autoargument")))))
+ (memq (command-name (cdr element))
+ '(self-insert-command
+ negative-argument
+ digit-argument
+ auto-negative-argument
+ auto-digit-argument
+ auto-argument))))
(define (filter-uninteresting items)
(list-transform-negative items uninteresting-element?))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/kilcom.scm,v 1.56 1989/03/14 08:01:10 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/kilcom.scm,v 1.57 1989/04/15 00:50:34 cph Exp $
;;;
;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
(ring-push! ring string))))
(set-command-message! append-next-kill-tag))
-(define-command ("^R Append Next Kill")
+(define-command append-next-kill
"Cause following command, if kill, to append to previous kill."
- (set-command-message! append-next-kill-tag))
+ ()
+ (lambda ()
+ (set-command-message! append-next-kill-tag)))
\f
;;;; Deletion
-(define-command ("^R Backward Delete Character" argument)
+(define-command backward-delete-char
"Delete character before point.
With argument, kills several characters (saving them).
Negative args kill characters forward."
- (if (not argument)
- (delete-region (mark-1+ (current-point)))
- (kill-region (mark- (current-point) argument))))
+ "P"
+ (lambda (argument)
+ (if (not argument)
+ (delete-region (mark-1+ (current-point)))
+ (kill-region (mark- (current-point) argument)))))
-(define-command ("^R Delete Character" argument)
+(define-command delete-char
"Delete character after point.
With argument, kill than many characters (saving them).
Negative args kill characters backward."
- (if (not argument)
- (delete-region (mark1+ (current-point)))
- (kill-region (mark+ (current-point) argument))))
+ "P"
+ (lambda (argument)
+ (if (not argument)
+ (delete-region (mark1+ (current-point)))
+ (kill-region (mark+ (current-point) argument)))))
-(define-command ("^R Kill Line" argument)
+(define-command kill-line
"Kill to end of line, or kill an end of line.
At the end of a line (only blanks following) kill through the newline.
Otherwise, kill the rest of the line but not the newline.
With argument (positive or negative), kill specified number of lines.
An argument of zero means kill to beginning of line, nothing if at beginning.
Killed text is pushed onto the kill ring for retrieval."
- (let ((point (current-point)))
- (kill-region
- (cond ((not argument)
- (let ((end (line-end point 0)))
- (if (and (region-blank? (make-region point end))
- (not (group-end? point)))
- (mark1+ end)
- end)))
- ((positive? argument)
- (and (not (group-end? point))
- (line-start point argument 'LIMIT)))
- ((zero? argument)
- (line-start point 0))
- (else
- (and (not (group-start? point))
- (line-start point
- (if (line-start? point)
- argument
- (1+ argument))
- 'LIMIT)))))))
+ "P"
+ (lambda (argument)
+ (let ((point (current-point)))
+ (kill-region
+ (cond ((not argument)
+ (let ((end (line-end point 0)))
+ (if (and (region-blank? (make-region point end))
+ (not (group-end? point)))
+ (mark1+ end)
+ end)))
+ ((positive? argument)
+ (and (not (group-end? point))
+ (line-start point argument 'LIMIT)))
+ ((zero? argument)
+ (line-start point 0))
+ (else
+ (and (not (group-start? point))
+ (line-start point
+ (if (line-start? point)
+ argument
+ (1+ argument))
+ 'LIMIT))))))))
\f
-(define-command ("^R Backward Delete Hacking Tabs" argument)
+(define-command backward-delete-char-untabify
"Delete character before point, turning tabs into spaces.
Rather than deleting a whole tab, the tab is converted into the
appropriate number of spaces and then one space is deleted."
- (define (back n)
- (let ((m1 (mark- (current-point) n 'LIMIT)))
- (if (not (char-search-backward #\Tab (current-point) m1))
- m1
- (begin (convert-tab-to-spaces! (re-match-start 0))
- (back n)))))
- (define (forth n)
- (let ((m1 (mark+ (current-point) n 'LIMIT)))
- (if (not (char-search-forward #\Tab (current-point) m1))
- m1
- (begin (convert-tab-to-spaces! (re-match-start 0))
- (forth n)))))
- (cond ((not argument)
- (if (char-match-backward #\Tab)
- (convert-tab-to-spaces! (mark-1+ (current-point))))
- (delete-region (mark-1+ (current-point))))
- ((positive? argument)
- (kill-region (back argument)))
- ((negative? argument)
- (kill-region (forth (- argument))))))
+ "P"
+ (lambda (argument)
+ (define (back n)
+ (let ((m1 (mark- (current-point) n 'LIMIT)))
+ (if (not (char-search-backward #\Tab (current-point) m1))
+ m1
+ (begin (convert-tab-to-spaces! (re-match-start 0))
+ (back n)))))
+ (define (forth n)
+ (let ((m1 (mark+ (current-point) n 'LIMIT)))
+ (if (not (char-search-forward #\Tab (current-point) m1))
+ m1
+ (begin (convert-tab-to-spaces! (re-match-start 0))
+ (forth n)))))
+ (cond ((not argument)
+ (if (char-match-backward #\Tab)
+ (convert-tab-to-spaces! (mark-1+ (current-point))))
+ (delete-region (mark-1+ (current-point))))
+ ((positive? argument)
+ (kill-region (back argument)))
+ ((negative? argument)
+ (kill-region (forth (- argument)))))))
(define (convert-tab-to-spaces! m1)
(let ((at-point? (mark= m1 (current-point)))
\f
;;;; Un/Killing
-(define-command ("^R Kill Region")
+(define-command kill-region
"Kill from point to mark.
-Use \\[^R Un-Kill] and \\[^R Un-Kill Pop] to get it back."
- (kill-region (current-mark)))
+Use \\[yank] and \\[yank-pop] to get it back."
+ "m"
+ kill-region)
-(define-command ("^R Copy Region")
+(define-command copy-region-as-kill
"Stick region into kill-ring without killing it.
Like killing and getting back, but doesn't mark buffer modified."
- (copy-region (current-mark))
- (temporary-message "Region saved"))
+ ()
+ (lambda ()
+ (copy-region (current-mark))
+ (temporary-message "Region saved")))
(define un-kill-tag
"Un-kill")
-(define-command ("^R Un-Kill" (argument 1))
+(define-command yank
"Re-insert the last stuff killed.
Puts point after it and the mark before it.
A positive argument N says un-kill the N'th most recent
string of killed stuff (1 = most recent). A null
argument (just C-U) means leave point before, mark after."
- (let ((ring (current-kill-ring)))
- (define (pop-loop n)
- (if (> n 1)
- (begin (ring-pop! ring)
- (pop-loop (-1+ n)))))
- (if (ring-empty? ring) (editor-error "Nothing to un-kill"))
- (cond ((command-argument-multiplier-only?)
- (unkill (ring-ref ring 0)))
- ((positive? argument)
- (pop-loop argument)
- (unkill-reversed (ring-ref ring 0)))))
- (set-command-message! un-kill-tag))
-
-(define-command ("^R Un-kill Pop" (argument 1))
- "Correct after \\[^R Un-Kill] to use an earlier kill.
+ "p"
+ (lambda (argument)
+ (let ((ring (current-kill-ring)))
+ (define (pop-loop n)
+ (if (> n 1)
+ (begin (ring-pop! ring)
+ (pop-loop (-1+ n)))))
+ (if (ring-empty? ring) (editor-error "Nothing to un-kill"))
+ (cond ((command-argument-multiplier-only?)
+ (unkill (ring-ref ring 0)))
+ ((positive? argument)
+ (pop-loop argument)
+ (unkill-reversed (ring-ref ring 0)))))
+ (set-command-message! un-kill-tag)))
+
+(define-command yank-pop
+ "Correct after \\[yank] to use an earlier kill.
Requires that the region contain the most recent killed stuff,
-as it does immediately after using \\[^R Un-Kill].
+as it does immediately after using \\[yank].
It is deleted and replaced with the previous killed stuff,
which is rotated to the front of the kill ring.
With 0 as argument, just deletes the region with no replacement,
but the region must still match the last killed stuff."
- (command-message-receive un-kill-tag
- (lambda ()
- (let ((ring (current-kill-ring))
- (point (current-point)))
- (if (or (ring-empty? ring)
- (not (match-string (ring-ref ring 0) (current-mark) point)))
- (editor-error "Region does not match last kill"))
- (delete-string (pop-current-mark!) point)
- (if (not (zero? argument))
- (begin (ring-pop! ring)
- (unkill-reversed (ring-ref ring 0))))))
- (lambda ()
- (editor-error "No previous un-kill to replace")))
- (set-command-message! un-kill-tag))
+ "p"
+ (lambda (argument)
+ (command-message-receive un-kill-tag
+ (lambda ()
+ (let ((ring (current-kill-ring))
+ (point (current-point)))
+ (if (or (ring-empty? ring)
+ (not (match-string (ring-ref ring 0) (current-mark) point)))
+ (editor-error "Region does not match last kill"))
+ (delete-string (pop-current-mark!) point)
+ (if (not (zero? argument))
+ (begin (ring-pop! ring)
+ (unkill-reversed (ring-ref ring 0))))))
+ (lambda ()
+ (editor-error "No previous un-kill to replace")))
+ (set-command-message! un-kill-tag)))
\f
;;;; Marks
-(define-variable "Mark Ring Maximum"
+(define-variable mark-ring-maximum
"The maximum number of marks that are saved on the mark ring.
This variable is only noticed when a buffer is created, so changing
it later will not affect existing buffers."
16)
-(define-command ("^R Set/Pop Mark")
+(define-command set-mark-command
"Sets or pops the mark.
-With no C-U's, pushes point as the mark.
-With one C-U, pops the mark into point.
-With two C-U's, pops the mark and throws it away."
- (let ((n (command-argument-multiplier-exponent)))
- (cond ((zero? n) (push-current-mark! (current-point)))
- ((= n 1) (set-current-point! (pop-current-mark!)))
- ((= n 2) (pop-current-mark!))
- (else (editor-error)))))
-
-(define-command ("^R Mark Beginning")
+With no \\[universal-argument]'s, pushes point as the mark.
+With one \\[universal-argument], pops the mark into point.
+With two \\[universal-argument]'s, pops the mark and throws it away."
+ ()
+ (lambda ()
+ (let ((n (command-argument-multiplier-exponent)))
+ (cond ((zero? n) (push-current-mark! (current-point)))
+ ((= n 1) (set-current-point! (pop-current-mark!)))
+ ((= n 2) (pop-current-mark!))
+ (else (editor-error))))))
+
+(define-command mark-beginning-of-buffer
"Set mark at beginning of buffer."
- (push-current-mark! (buffer-start (current-buffer))))
+ ()
+ (lambda ()
+ (push-current-mark! (buffer-start (current-buffer)))))
-(define-command ("^R Mark End")
+(define-command mark-end-of-buffer
"Set mark at end of buffer."
- (push-current-mark! (buffer-end (current-buffer))))
+ ()
+ (lambda ()
+ (push-current-mark! (buffer-end (current-buffer)))))
-(define-command ("^R Mark Whole Buffer" argument)
+(define-command mark-whole-buffer
"Set point at beginning and mark at end of buffer.
Pushes the old point on the mark first, so two pops restore it.
With argument, puts point at end and mark at beginning."
- (push-current-mark! (current-point))
- ((if (not argument) set-current-region! set-current-region-reversed!)
- (buffer-region (current-buffer))))
+ "P"
+ (lambda (argument)
+ (push-current-mark! (current-point))
+ ((if (not argument) set-current-region! set-current-region-reversed!)
+ (buffer-region (current-buffer)))))
-(define-command ("^R Exchange Point and Mark")
+(define-command exchange-point-and-mark
"Exchange positions of point and mark."
- (let ((point (current-point))
- (mark (current-mark)))
- (if (not mark) (editor-error "No mark to exchange"))
- (set-current-point! mark)
- (set-current-mark! point)))
-
-;;;; Q-Registers
-
-(define-command ("^R Get Q-reg")
- "Get contents of Q-reg (reads name from tty).
-Usually leaves the pointer before, and the mark after, the text.
-With argument, puts point after and mark before."
- (not-implemented))
-
-(define-command ("^R Put Q-reg")
- "Put point to mark into Q-reg (reads name from tty).
-With an argument, the text is also deleted."
- (not-implemented))
+ ()
+ (lambda ()
+ (let ((point (current-point))
+ (mark (current-mark)))
+ (if (not mark) (editor-error "No mark to exchange"))
+ (set-current-point! mark)
+ (set-current-mark! point))))
\f
;;;; Transposition
-(define-command ("^R Transpose Characters" (argument 1))
+(define-command transpose-chars
"Transpose the characters before and after the cursor.
With a positive argument it transposes the characters before and after
the cursor, moves right, and repeats the specified number of times,
At the end of a line, with no argument, the preceding two characters
are transposed."
- (cond ((and (= argument 1) (line-end? (current-point)))
- (twiddle-characters (mark-1+ (current-point) 'ERROR)
- (current-point)))
- ((positive? argument)
- (twiddle-characters (current-point)
- (mark+ (current-point) argument 'ERROR)))
- ((negative? argument)
- (twiddle-characters (current-point)
- (mark- (current-point) (1+ (- argument)) 'ERROR)))
- (else
- (let ((m1 (mark-right-inserting (current-point)))
- (m2 (mark-right-inserting (current-mark))))
- (let ((r1 (region-extract!
- (make-region (current-point)
- (mark1+ (current-point) 'ERROR))))
- (r2 (region-extract!
- (make-region (current-mark)
- (mark1+ (current-mark) 'ERROR)))))
- (region-insert! m1 r2)
- (region-insert! m2 r1))
- (set-current-point! m1)
- (set-current-mark! m2)))))
+ "p"
+ (lambda (argument)
+ (cond ((and (= argument 1) (line-end? (current-point)))
+ (twiddle-characters (mark-1+ (current-point) 'ERROR)
+ (current-point)))
+ ((positive? argument)
+ (twiddle-characters (current-point)
+ (mark+ (current-point) argument 'ERROR)))
+ ((negative? argument)
+ (twiddle-characters
+ (current-point)
+ (mark- (current-point) (1+ (- argument)) 'ERROR)))
+ (else
+ (let ((m1 (mark-right-inserting (current-point)))
+ (m2 (mark-right-inserting (current-mark))))
+ (let ((r1 (region-extract!
+ (make-region (current-point)
+ (mark1+ (current-point) 'ERROR))))
+ (r2 (region-extract!
+ (make-region (current-mark)
+ (mark1+ (current-mark) 'ERROR)))))
+ (region-insert! m1 r2)
+ (region-insert! m2 r1))
+ (set-current-point! m1)
+ (set-current-mark! m2))))))
(define (twiddle-characters m1 m2)
(let ((m* (mark-left-inserting m2)))
(region-insert! m* (region-extract! (make-region (mark-1+ m1 'ERROR) m1)))
- (set-current-point! m*)))
-
-(define-command ("^R Transpose Regions")
- "Transpose regions defined by point and last 3 marks.
-To transpose two non-overlapping regions, set the mark successively at three
-of the four boundaries, put point at the fourth, and call this function.
-On return, the cursor and saved marks retain their original order, but are
-adjusted to delineate the interchanged regions. Thus two consecutive
-calls to this function will leave the buffer unchanged."
- (not-implemented))
\ No newline at end of file
+ (set-current-point! m*)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/kmacro.scm,v 1.28 1989/03/14 08:01:12 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/kmacro.scm,v 1.29 1989/04/15 00:50:42 cph Exp $
;;;
;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
(string-table-put! named-keyboard-macros name last-keyboard-macro)
(make-command name
"Command defined by keyboard macro"
+ "P"
(lambda (#!optional argument)
(keyboard-macro-execute macro
(if (or (default-object? argument)
1
argument)))))
\f
-(define-command ("Start Keyboard Macro" argument)
+(define-command start-kbd-macro
"Record subsequent keyboard input, defining a keyboard macro.
The commands are recorded even as they are executed.
-Use \\[End Keyboard Macro] to finish recording and make the macro available.
-Use \\[Name Last Keyboard Macro] to give it a permanent name.
+Use \\[end-kbd-macro] to finish recording and make the macro available.
+Use \\[name-last-kbd-macro] to give it a permanent name.
With argument, append to last keyboard macro defined;
this begins by re-executing that macro as if you typed it again."
- (if *defining-keyboard-macro?*
- (editor-error "Already defining keyboard macro"))
- (cond ((not argument)
- (set! keyboard-macro-buffer '())
- (set! keyboard-macro-buffer-end '())
- (set! *defining-keyboard-macro?* true)
- (keyboard-macro-event)
- (message "Defining keyboard macro..."))
- ((not last-keyboard-macro)
- (editor-error "No keyboard macro has been defined"))
- (else
- (set! *defining-keyboard-macro?* true)
- (keyboard-macro-event)
- (message "Appending to keyboard macro...")
- (keyboard-macro-execute last-keyboard-macro 1))))
+ "P"
+ (lambda (argument)
+ (if *defining-keyboard-macro?*
+ (editor-error "Already defining keyboard macro"))
+ (cond ((not argument)
+ (set! keyboard-macro-buffer '())
+ (set! keyboard-macro-buffer-end '())
+ (set! *defining-keyboard-macro?* true)
+ (keyboard-macro-event)
+ (message "Defining keyboard macro..."))
+ ((not last-keyboard-macro)
+ (editor-error "No keyboard macro has been defined"))
+ (else
+ (set! *defining-keyboard-macro?* true)
+ (keyboard-macro-event)
+ (message "Appending to keyboard macro...")
+ (keyboard-macro-execute last-keyboard-macro 1)))))
-(define-command ("End Keyboard Macro" (argument 1))
+(define-command end-kbd-macro
"Finish defining a keyboard macro.
-The definition was started by \\[Start Keyboard Macro].
-The macro is now available for use via \\[Call Last Keyboard Macro],
- or it can be given a name with \\[Name Last Keyboard Macro] and then invoked
+The definition was started by \\[start-kbd-macro].
+The macro is now available for use via \\[call-last-kbd-macro],
+ or it can be given a name with \\[name-last-kbd-macro] and then invoked
under that name.
With numeric argument, repeat macro now that many times,
counting the definition just completed as the first repetition."
- (if *defining-keyboard-macro?*
- (begin (set! *defining-keyboard-macro?* false)
- (keyboard-macro-event)
- (set! last-keyboard-macro (reverse keyboard-macro-buffer-end))
- (message "Keyboard macro defined")))
- (cond ((zero? argument)
- (keyboard-macro-execute last-keyboard-macro 0))
- ((> argument 1)
- (keyboard-macro-execute last-keyboard-macro (-1+ argument)))))
+ "p"
+ (lambda (argument)
+ (if *defining-keyboard-macro?*
+ (begin
+ (set! *defining-keyboard-macro?* false)
+ (keyboard-macro-event)
+ (set! last-keyboard-macro (reverse keyboard-macro-buffer-end))
+ (message "Keyboard macro defined")))
+ (cond ((zero? argument)
+ (keyboard-macro-execute last-keyboard-macro 0))
+ ((> argument 1)
+ (keyboard-macro-execute last-keyboard-macro (-1+ argument))))))
-(define-command ("Call Last Keyboard Macro" (argument 1))
- "Call the last keyboard macro that you defined with \\[Start Keyboard Macro].
+(define-command call-last-kbd-macro
+ "Call the last keyboard macro that you defined with \\[start-kbd-macro].
To make a macro permanent so you can call it even after
- defining others, use \\[Name Last Keyboard Macro]."
- (if *defining-keyboard-macro?*
- (editor-error "Can execute anonymous macro while defining one."))
- (if (not last-keyboard-macro)
- (editor-error "No keyboard macro has been defined"))
- (keyboard-macro-execute last-keyboard-macro argument))
+ defining others, use \\[name-last-kbd-macro]."
+ "p"
+ (lambda (argument)
+ (if *defining-keyboard-macro?*
+ (editor-error "Can execute anonymous macro while defining one."))
+ (if (not last-keyboard-macro)
+ (editor-error "No keyboard macro has been defined"))
+ (keyboard-macro-execute last-keyboard-macro argument)))
\f
-(define-command ("Name Last Keyboard Macro")
+(define-command name-last-kbd-macro
"Assign a name to the last keyboard macro defined."
- (if *defining-keyboard-macro?*
- (editor-error "Can't name a keyboard macro while defining one."))
- (if (not last-keyboard-macro)
- (editor-error "No keyboard macro has been defined"))
- (keyboard-macro-define (prompt-for-string "Name last keyboard macro" false)
- last-keyboard-macro))
+ "sName last keyboard macro"
+ (lambda (name)
+ (if *defining-keyboard-macro?*
+ (editor-error "Can't name a keyboard macro while defining one."))
+ (if (not last-keyboard-macro)
+ (editor-error "No keyboard macro has been defined"))
+ (keyboard-macro-define name last-keyboard-macro)))
-(define-command ("Write Keyboard Macro" argument)
+(define-command write-kbd-macro
"Save keyboard macro in file.
Use LOAD to load the file.
With argument, also record the keys it is bound to."
- (let ((name (prompt-for-completed-string "Write keyboard macro"
- false 'NO-DEFAULT
- named-keyboard-macros
- 'STRICT-COMPLETION)))
- (let ((pathname (prompt-for-pathname (string-append "Write keyboard macro "
- name
- " to file")
- (current-default-pathname)))
- (buffer (temporary-buffer "*Write-Keyboard-Macro-temp*")))
- (with-output-to-mark (buffer-point buffer)
- (lambda ()
- (write-string "(IN-PACKAGE EDWIN-PACKAGE")
- (newline) (write-string " (KEYBOARD-MACRO-DEFINE ") (write name)
- (newline) (write-string " '")
- (write (string-table-get named-keyboard-macros name))
- (write-string ")")
- (if argument
- (for-each (lambda (key)
- (newline)
- (write-string " (DEFINE-KEY \"Fundamental\" '")
- (write key)
- (write-string " ")
- (write name)
- (write-string ")"))
- (comtab-key-bindings (mode-comtabs fundamental-mode)
- (name->command name))))
- (newline) (write-string ")")))
- (set-buffer-pathname! buffer pathname)
- (write-buffer buffer)
- (kill-buffer buffer))))
+ "P"
+ (lambda (argument)
+ (let ((name
+ (prompt-for-string-table-name "Write keyboard macro"
+ false
+ 'NO-DEFAULT
+ named-keyboard-macros
+ true)))
+ (let ((pathname
+ (prompt-for-pathname (string-append "Write keyboard macro "
+ name
+ " to file")
+ (current-default-pathname)))
+ (buffer (temporary-buffer "*Write-Keyboard-Macro-temp*")))
+ (with-output-to-mark (buffer-point buffer)
+ (lambda ()
+ (write-string "(IN-PACKAGE EDWIN-PACKAGE")
+ (newline) (write-string " (KEYBOARD-MACRO-DEFINE ") (write name)
+ (newline) (write-string " '")
+ (write (string-table-get named-keyboard-macros name))
+ (write-string ")")
+ (if argument
+ (for-each (lambda (key)
+ (newline)
+ (write-string " (DEFINE-KEY \"Fundamental\" '")
+ (write key)
+ (write-string " ")
+ (write name)
+ (write-string ")"))
+ (comtab-key-bindings
+ (mode-comtabs (ref-mode-object fundamental))
+ (name->command name))))
+ (newline) (write-string ")")))
+ (set-buffer-pathname! buffer pathname)
+ (write-buffer buffer)
+ (kill-buffer buffer)))))
\f
-(define-command ("Keyboard Macro Query" argument)
+(define-command kbd-macro-query
"Query user during keyboard macro execution.
With prefix argument, enters recursive edit,
reading keyboard commands even within a keyboard macro.
Without argument, reads a character. Your options are:
Space -- execute the rest of the macro.
Rubout -- skip the rest of the macro; start next repetition.
- C-D -- skip the rest of the macro and don't repeat it any more.
- C-R -- Enter a recursive edit, then on exit ask again for a character
- C-L -- redisplay screen and ask again."
- (define (loop)
- (let ((char (with-keyboard-macro-disabled
- (lambda ()
- (set-command-prompt!
- "Proceed with macro? (Space, Rubout, C-D, C-R or C-L)")
- (char-upcase (keyboard-read-char))))))
- (cond ((char=? char #\Space))
- ((char=? char #\Rubout)
- (*keyboard-macro-continuation* true))
- ((char=? char #\C-D)
- (*keyboard-macro-continuation* false))
- ((char=? char #\C-R)
- (with-keyboard-macro-disabled enter-recursive-edit)
- (loop))
- ((or (char=? char #\C-L) (char=? char #\Page))
- (window-redraw! (current-window) false)
- (loop))
- (else
- (editor-beep)
- (loop)))))
- (cond (argument (with-keyboard-macro-disabled enter-recursive-edit))
- (*executing-keyboard-macro?* (loop))))
\ No newline at end of file
+ C-d -- skip the rest of the macro and don't repeat it any more.
+ C-r -- Enter a recursive edit, then on exit ask again for a character
+ C-l -- redisplay screen and ask again."
+ "P"
+ (lambda (argument)
+ (cond ((and (not *defining-keyboard-macro?*)
+ (not *executing-keyboard-macro?*))
+ (editor-error "Not defining or executing kbd macro"))
+ (argument
+ (with-keyboard-macro-disabled enter-recursive-edit))
+ (*executing-keyboard-macro?*
+ (let loop ()
+ (let ((char
+ (with-keyboard-macro-disabled
+ (lambda ()
+ (set-command-prompt!
+ "Proceed with macro? (Space, DEL, C-d, C-r or C-l)")
+ (keyboard-read-char)))))
+ (let ((test-for
+ (lambda (char*)
+ (char=? char (remap-alias-char char*)))))
+ (cond ((test-for #\space)
+ unspecific)
+ ((test-for #\rubout)
+ (*keyboard-macro-continuation* true))
+ ((test-for #\C-d)
+ (*keyboard-macro-continuation* false))
+ ((test-for #\C-r)
+ (with-keyboard-macro-disabled enter-recursive-edit)
+ (loop))
+ ((test-for #\C-l)
+ (window-redraw! (current-window) false)
+ (loop))
+ (else
+ (editor-beep)
+ (loop))))))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/lincom.scm,v 1.101 1989/03/14 08:01:14 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/lincom.scm,v 1.102 1989/04/15 00:50:49 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
\f
;;;; Lines
-(define-command ("^R Count Lines Region")
+(define-command count-lines-region
"Type number of lines from point to mark."
- (message "Region has "
- (write-to-string (region-count-lines (current-region)))
- " lines"))
+ "r"
+ (lambda (region)
+ (message "Region has "
+ (write-to-string (region-count-lines region))
+ " lines")))
-(define-command ("^R Transpose Lines" (argument 1))
+(define-command transpose-lines
"Transpose the lines before and after the cursor.
With a positive argument it transposes the lines before and after the
cursor, moves right, and repeats the specified number of times,
At the end of a buffer, with no argument, the preceding two lines are
transposed."
-
- (cond ((and (= argument 1) (group-end? (current-point)))
- (if (not (line-start? (current-point)))
- (insert-newlines 1))
- (let ((region
- (region-extract!
- (make-region (forward-line (current-point) -2 'ERROR)
- (forward-line (current-point) -1 'ERROR)))))
- (region-insert! (current-point) region)))
- (else
- (transpose-things forward-line argument))))
+ "p"
+ (lambda (argument)
+ (cond ((and (= argument 1) (group-end? (current-point)))
+ (if (not (line-start? (current-point)))
+ (insert-newlines 1))
+ (let ((region
+ (region-extract!
+ (make-region (forward-line (current-point) -2 'ERROR)
+ (forward-line (current-point) -1 'ERROR)))))
+ (region-insert! (current-point) region)))
+ (else
+ (transpose-things forward-line argument)))))
\f
;;;; Pages
-(define-command ("^R Next Page" (argument 1))
+(define-command forward-page
"Move forward to page boundary. With arg, repeat, or go back if negative.
A page boundary is any string in Page Delimiters, at a line's beginning."
- (set-current-point! (forward-page (current-point) argument 'BEEP)))
+ "p"
+ (lambda (argument)
+ (set-current-point! (forward-page (current-point) argument 'BEEP))))
-(define-command ("^R Previous Page" (argument 1))
+(define-command backward-page
"Move backward to page boundary. With arg, repeat, or go fwd if negative.
A page boundary is any string in Page Delimiters, at a line's beginning."
- (set-current-point! (backward-page (current-point) argument 'BEEP)))
+ "p"
+ (lambda (argument)
+ (set-current-point! (backward-page (current-point) argument 'BEEP))))
-(define-command ("^R Mark Page" (argument 0))
+(define-command mark-page
"Put mark at end of page, point at beginning."
- (let ((end (forward-page (current-point) (1+ argument) 'LIMIT)))
- (set-current-region! (make-region (backward-page end 1 'LIMIT) end))))
+ "P"
+ (lambda (argument)
+ (let ((end (forward-page (current-point) (1+ (or argument 0)) 'LIMIT)))
+ (set-current-region! (make-region (backward-page end 1 'LIMIT) end)))))
-(define-command ("^R Narrow Bounds to Page")
+(define-command narrow-to-page
"Make text outside current page invisible."
- (region-clip! (page-interior-region (current-point))))
+ "d"
+ (lambda (mark)
+ (region-clip! (page-interior-region mark))))
(define (page-interior-region point)
(if (and (group-end? point)
- (mark= (re-match-forward (ref-variable "Page Delimiter")
+ (mark= (re-match-forward (ref-variable page-delimiter)
(line-start point 0)
point)
point))
(if (mark< end* point)
end
end*))))))
-\f
-(define-command ("^R Count Lines Page")
+
+(define-command count-lines-page
"Report number of lines on current page."
- (let ((point (current-point)))
+ "d"
+ (lambda (point)
(let ((end
(let ((end (forward-page point 1 'LIMIT)))
(if (group-end? end) end (line-start end 0)))))
(define (count-lines-string start end)
(write-to-string (region-count-lines (make-region start end))))
-
-(define-command ("What Page")
+\f
+(define-command what-page
"Report page and line number of point."
- (without-group-clipped! (buffer-group (current-buffer))
- (lambda ()
- (message "Page " (write-to-string (current-page))
- ", Line " (write-to-string (current-line))))))
+ ()
+ (lambda ()
+ (without-group-clipped! (buffer-group (current-buffer))
+ (lambda ()
+ (message "Page " (write-to-string (current-page))
+ ", Line " (write-to-string (current-line)))))))
(define (current-page)
(region-count-pages (make-region (buffer-start (current-buffer))
\f
;;;; Indentation
-(define (indent-to-left-margin argument)
- argument ;ignore
- (maybe-change-indentation (ref-variable "Left Margin")
+(define (indent-to-left-margin)
+ (maybe-change-indentation (ref-variable left-margin)
(line-start (current-point) 0)))
-(define-variable "Indent Line Procedure"
+(define-variable indent-line-procedure
"Procedure used to indent current line.
-If this is the procedure INDENT-TO-LEFT-MARGIN,
-\\[^R Indent for Tab] will insert tab characters rather than indenting."
+If this is the procedure indent-to-left-margin,
+\\[indent-for-tab-command] will insert tab characters rather than indenting."
indent-to-left-margin)
-(define-command ("^R Indent According to Mode" argument)
+(define-command indent-according-to-mode
"Indent line in proper way for current major mode.
The exact behavior of this command is determined
-by the variable Indent Line Procedure."
- ((ref-variable "Indent Line Procedure") argument))
+by the variable indent-line-procedure."
+ ()
+ (lambda ()
+ ((ref-variable indent-line-procedure))))
-(define-command ("^R Indent for Tab" argument)
+(define-command indent-for-tab-command
"Indent line in proper way for current major mode.
The exact behavior of this command is determined
-by the variable Indent Line Procedure."
- (if (eq? (ref-variable "Indent Line Procedure") indent-to-left-margin)
- (insert-chars #\Tab (or argument 1))
- ((ref-variable "Indent Line Procedure") argument)))
-
-(define-command ("^R Tab" (argument 1))
- "Insert a tab character."
- (insert-chars #\Tab argument))
-
-(define-command ("^R Indent New Line" argument)
- "Inserts newline, then indents the second line.
-Any spaces before the inserted newline are deleted.
-Uses Indent Line Procedure to do the indentation,
-except that if there is a Fill Prefix it is used to indent.
-An argument is passed on to Indent Line Procedure."
- (delete-horizontal-space)
- (^r-newline-command)
- (if (ref-variable "Fill Prefix")
- (region-insert-string! (current-point) (ref-variable "Fill Prefix"))
- (^r-indent-according-to-mode-command argument)))
-
-(define-command ("Reindent then Newline and Indent")
- "Reindent the current line according to mode (like Tab), then insert
-a newline, and indent the new line indent according to mode."
- (delete-horizontal-space)
- (^r-indent-according-to-mode-command false)
- (^r-newline-command)
- (^r-indent-according-to-mode-command false))
+by the variable indent-line-procedure."
+ "p"
+ (lambda (argument)
+ (let ((indent-line-procedure (ref-variable indent-line-procedure)))
+ (if (eq? indent-line-procedure indent-to-left-margin)
+ (insert-chars #\Tab argument)
+ (indent-line-procedure)))))
+
+(define-command newline-and-indent
+ "Insert a newline, then indent according to major mode.
+Indentation is done using the current indent-line-procedure,
+except that if there is a fill-prefix it is used to indent.
+In programming language modes, this is the same as TAB.
+In some text modes, where TAB inserts a tab, this indents to the
+specified left-margin column."
+ ()
+ (lambda ()
+ (delete-horizontal-space)
+ (insert-newlines 1)
+ (let ((fill-prefix (ref-variable fill-prefix)))
+ (if fill-prefix
+ (region-insert-string! (current-point) fill-prefix)
+ ((ref-command indent-according-to-mode))))))
+
+(define-command reindent-then-newline-and-indent
+ "Reindent the current line according to mode (like
+\\[indent-according-to-mode]), then insert a newline,
+and indent the new line indent according to mode."
+ ()
+ (lambda ()
+ (delete-horizontal-space)
+ ((ref-command indent-according-to-mode))
+ ((ref-command newline))
+ ((ref-command indent-according-to-mode))))
\f
-(define-command ("^R Newline" argument)
+(define-command newline
"Insert newline, or move onto blank line.
A blank line is one containing only spaces and tabs
\(which are killed if we move onto it). Single blank lines
\(followed by nonblank lines) are not eaten up this way.
An argument inhibits this."
- (cond ((not argument)
- (if (line-end? (current-point))
- (let ((m1 (line-start (current-point) 1)))
- (if (and m1 (line-blank? m1)
- (let ((m2 (line-start m1 1)))
- (and m2 (line-blank? m2))))
- (begin (set-current-point! m1)
- (delete-horizontal-space))
- (insert-newlines 1)))
- (insert-newlines 1)))
- (else
- (insert-newlines argument))))
-
-(define-command ("^R Split Line" (argument 1))
+ "P"
+ (lambda (argument)
+ (cond ((not argument)
+ (if (line-end? (current-point))
+ (let ((m1 (line-start (current-point) 1)))
+ (if (and m1
+ (line-blank? m1)
+ (let ((m2 (line-start m1 1)))
+ (and m2
+ (line-blank? m2))))
+ (begin
+ (set-current-point! m1)
+ (delete-horizontal-space))
+ (insert-newlines 1)))
+ (insert-newlines 1)))
+ (else
+ (insert-newlines argument)))))
+
+(define-command split-line
"Move rest of this line vertically down.
Inserts a newline, and then enough tabs/spaces so that
what had been the rest of the current line is indented as much as
it had been. Point does not move, except to skip over indentation
that originally followed it.
With argument, makes extra blank lines in between."
- (set-current-point! (horizontal-space-end (current-point)))
- (let ((m* (mark-right-inserting (current-point))))
- (insert-newlines (max argument 1))
- (insert-horizontal-space (mark-column m*))
- (set-current-point! m*)))
-
-(define-command ("^R Back to Indentation")
+ "p"
+ (lambda (argument)
+ (set-current-point! (horizontal-space-end (current-point)))
+ (let ((m* (mark-right-inserting (current-point))))
+ (insert-newlines (max argument 1))
+ (insert-horizontal-space (mark-column m*))
+ (set-current-point! m*))))
+
+(define-command back-to-indentation
"Move to end of this line's indentation."
- (set-current-point! (horizontal-space-end (line-start (current-point) 0))))
+ ()
+ (lambda ()
+ (set-current-point!
+ (horizontal-space-end (line-start (current-point) 0)))))
-(define-command ("^R Delete Horizontal Space")
+(define-command delete-horizontal-space
"Delete all spaces and tabs around point."
- (delete-horizontal-space))
+ ()
+ delete-horizontal-space)
-(define-command ("^R Just One Space")
+(define-command just-one-space
"Delete all spaces and tabs around point, leaving just one space."
- (delete-horizontal-space)
- (insert-chars #\Space 1))
+ ()
+ (lambda ()
+ (delete-horizontal-space)
+ (insert-chars #\Space 1)))
\f
-(define-command ("^R Delete Blank Lines")
+(define-command delete-blank-lines
"Kill all blank lines around this line's end.
If done on a non-blank line, kills all spaces and tabs at the end of
it, and all following blank lines (Lines are blank if they contain
only spaces and tabs).
If done on a blank line, deletes all preceding blank lines as well."
- (define (find-first-blank m1)
- (let ((m2 (line-start m1 -1)))
- (cond ((not m2) m1)
- ((not (line-blank? m2)) m1)
- (else (find-first-blank m2)))))
- (define (find-last-blank m1)
- (let ((m2 (line-start m1 1)))
- (cond ((not m2) m1)
- ((not (line-blank? m2)) m1)
- (else (find-last-blank m2)))))
- (region-delete!
- (let ((point (current-point)))
- (make-region (if (line-blank? point)
- (find-first-blank (line-start point 0))
- (horizontal-space-start (line-end point 0)))
- (line-end (find-last-blank point) 0)))))
-
-(define-command ("^R Delete Indentation" argument)
+ ()
+ (lambda ()
+ (region-delete!
+ (let ((point (current-point)))
+ (make-region (if (line-blank? point)
+ (let loop ((m1 (line-start point 0)))
+ (let ((m2 (line-start m1 -1)))
+ (if (and m2 (line-blank? m2))
+ (loop m2)
+ m1)))
+ (horizontal-space-start (line-end point 0)))
+ (line-end (let loop ((m1 point))
+ (let ((m2 (line-start m1 1)))
+ (if (and m2 (line-blank? m2))
+ (loop m2)
+ m1)))
+ 0))))))
+
+(define-command delete-indentation
"Kill newline and indentation at front of line.
Leaves one space in place of them. With argument,
moves down one line first (killing newline after current line)."
- (set-current-point!
- (horizontal-space-start
- (line-end (current-point) (if (not argument) -1 0) 'ERROR)))
- (let ((point (current-point)))
- (region-delete! (make-region point (line-start point 1 'ERROR)))
- (if fill-prefix
- (let ((match (match-forward fill-prefix)))
- (if match (delete-string match))))
- (delete-horizontal-space)
- (if (or (line-start? point)
- (line-end? point)
- (not (or (char-set-member? delete-indentation-right-protected
- (mark-left-char point))
- (char-set-member? delete-indentation-left-protected
- (mark-right-char point)))))
- (insert-chars #\Space 1))))
-
-(define-variable "Delete Indentation Right Protected"
- "^R Delete Indentation won't insert a space to the right of these."
+ "P"
+ (lambda (argument)
+ (set-current-point!
+ (horizontal-space-start
+ (line-end (current-point) (if (not argument) -1 0) 'ERROR)))
+ (let ((point (current-point)))
+ (region-delete! (make-region point (line-start point 1 'ERROR)))
+ (if (ref-variable fill-prefix)
+ (let ((match (match-forward (ref-variable fill-prefix))))
+ (if match (delete-string match))))
+ (delete-horizontal-space)
+ (if (or (line-start? point)
+ (line-end? point)
+ (not (or (char-set-member?
+ (ref-variable delete-indentation-right-protected)
+ (mark-left-char point))
+ (char-set-member?
+ (ref-variable delete-indentation-left-protected)
+ (mark-right-char point)))))
+ (insert-chars #\Space 1)))))
+
+(define-variable delete-indentation-right-protected
+ "\\[delete-indentation] won't insert a space to the right of these."
(char-set #\( #\,))
-(define-variable "Delete Indentation Left Protected"
- "^R Delete Indentation won't insert a space to the left of these."
+(define-variable delete-indentation-left-protected
+ "\\[delete-indentation] won't insert a space to the left of these."
(char-set #\)))
\f
-(define-variable "Indent Tabs Mode"
- "If #F, do not use tabs for indentation or horizontal spacing."
+(define-variable tab-width
+ "Distance between tab stops (for display of tab characters), in columns." 8)
+
+(define-variable indent-tabs-mode
+ "If false, do not use tabs for indentation or horizontal spacing."
true)
-(define-command ("Indent Tabs Mode" argument)
+(define-command indent-tabs-mode
"Enables or disables use of tabs as indentation.
A positive argument turns use of tabs on;
zero or negative, turns it off.
With no argument, the mode is toggled."
- (set! indent-tabs-mode
- (if argument
- (positive? argument)
- (not indent-tabs-mode))))
-
-(define-command ("^R Indent Region" argument)
+ "P"
+ (lambda (argument)
+ (set-variable! indent-tabs-mode
+ (if argument
+ (positive? argument)
+ (not (ref-variable indent-tabs-mode))))))
+
+(define-command insert-tab
+ "Insert a tab character."
+ ()
+ (lambda ()
+ (if (ref-variable indent-tabs-mode)
+ (insert-char #\Tab)
+ (maybe-change-column
+ (let ((tab-width (ref-variable tab-width)))
+ (* tab-width (1+ (quotient (current-column) tab-width))))))))
+
+(define-command indent-region
"Indent all lines between point and mark.
With argument, indents each line to exactly that column.
Otherwise, does Tab on each line.
A line is processed if its first character is in the region.
The mark is left after the last line processed."
- (cond ((not argument) (not-implemented))
- ((not (negative? argument))
- (current-region-of-lines
- (lambda (start end)
- (define (loop mark)
- (change-indentation argument mark)
- (if (not (mark= mark end))
- (loop (mark-right-inserting (line-start mark 1)))))
- (loop start))))))
-
-(define-command ("^R Indent Rigidly" argument)
+ "P"
+ (lambda (argument)
+ (cond ((not argument)
+ (not-implemented))
+ ((not (negative? argument))
+ (current-region-of-lines
+ (lambda (start end)
+ (let loop ((mark start))
+ (change-indentation argument mark)
+ (if (not (mark= mark end))
+ (loop (mark-right-inserting (line-start mark 1)))))))))))
+\f
+(define-command indent-rigidly
"Shift text in region sideways as a unit.
All the lines in the region (first character between point and mark)
have their indentation incremented by the numeric argument
of this command (which may be negative).
Exception: lines containing just spaces and tabs become empty."
- (if argument
- (current-region-of-lines
- (lambda (start end)
- (define (loop mark)
- (if (line-blank? mark)
- (delete-horizontal-space mark)
- (change-indentation (max (+ argument (current-indentation mark))
- 0)
- mark))
- (if (not (mark= mark end))
- (loop (mark-right-inserting (line-start mark 1)))))
- (loop start)))))
+ "P"
+ (lambda (argument)
+ (if argument
+ (current-region-of-lines
+ (lambda (start end)
+ (define (loop mark)
+ (if (line-blank? mark)
+ (delete-horizontal-space mark)
+ (change-indentation
+ (max (+ argument (current-indentation mark)) 0)
+ mark))
+ (if (not (mark= mark end))
+ (loop (mark-right-inserting (line-start mark 1)))))
+ (loop start))))))
(define (current-region-of-lines receiver)
(let ((r (current-region)))
(mark-right-inserting
(line-start (region-end r)
(if (line-start? (region-end r)) -1 0))))))))
-\f
-(define-variable "Tab Width"
- "Distance between tab stops (for display of tab characters), in columns."
- 8)
-
-(define-command ("Untabify")
- "Convert all tabs in region to multiple spaces, preserving column.
-The variable Tabs Width controls action."
- (untabify-region (current-region)))
(define (untabify-region region)
(let ((end (region-end region)))
- (define (loop start)
+ (let loop ((start (region-start region)))
(if (char-search-forward #\Tab start end)
(let ((tab (re-match-start 0))
(next (mark-left-inserting (re-match-end 0))))
(let ((n-spaces (- (mark-column next) (mark-column tab))))
(delete-string tab next)
(insert-chars #\Space n-spaces next))
- (loop next))))
- (loop (region-start region))))
-
-(define-command ("Tabify")
- ""
- (not-implemented))
-\f
-(define-command ("^R Indent Relative")
+ (loop next))))))
+
+(define-command untabify
+ "Convert all tabs in region to multiple spaces, preserving columns.
+The variable tab-width controls the action."
+ "r"
+ untabify-region)
+
+(define-command tabify
+ "Convert multiple spaces in region to tabs when possible.
+A group of spaces is partially replaced by tabs
+when this can be done without changing the column they end at.
+The variable tab-width controls the action."
+ ()
+ (lambda ()
+ (not-implemented)))
+
+(define-command indent-relative
"Indents the current line directly below the previous non blank line."
- (let ((point (current-point)))
+ "d"
+ (lambda (point)
(let ((indentation (indentation-of-previous-non-blank-line point)))
(cond ((not (= indentation (current-indentation point)))
(change-indentation indentation point))
(define (indentation-of-previous-non-blank-line mark)
(let ((start (find-previous-non-blank-line mark)))
- (if start (current-indentation start) 0)))
-
-(define-command ("^R Tab to Tab Stop")
- ""
- (not-implemented))
-
-(define-command ("Edit Indented Text")
- ""
- (not-implemented))
-
-(define-command ("Edit Tab Stops")
- ""
- (not-implemented))
-
-(define-command ("Edit Tabular Text")
- ""
- (not-implemented))
\ No newline at end of file
+ (if start (current-indentation start) 0)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/linden.scm,v 1.115 1989/03/14 08:01:17 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/linden.scm,v 1.116 1989/04/15 00:51:00 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define-variable "Lisp Indent Offset"
+(define-variable lisp-indent-offset
"If not false, the number of extra columns to indent a subform."
false)
-(define-variable "Lisp Indent Hook"
+(define-variable lisp-indent-hook
"If not false, a procedure for modifying lisp indentation."
false)
-(define-variable "Lisp Indent Methods"
+(define-variable lisp-indent-methods
"String table identifying special forms for lisp indentation.")
-(define-variable "Lisp Body Indent"
+(define-variable lisp-body-indent
"Number of extra columns to indent the body of a special form."
2)
(define (simple-indent state container last-sexp indent-point)
(cond ((parse-state-in-string? state)
(mark-column (horizontal-space-end indent-point)))
- ((and (integer? (ref-variable "Lisp Indent Offset")) container)
- (+ (ref-variable "Lisp Indent Offset") (mark-column container)))
+ ((and (integer? (ref-variable lisp-indent-offset)) container)
+ (+ (ref-variable lisp-indent-offset) (mark-column container)))
((positive? (parse-state-depth state))
(if (not last-sexp)
(mark-column (mark1+ container))
;; the indent hook.
(mark-column (backward-prefix-chars normal-indent))
(let ((normal-indent (backward-prefix-chars normal-indent)))
- (or (and (ref-variable "Lisp Indent Hook")
- ((ref-variable "Lisp Indent Hook")
+ (or (and (ref-variable lisp-indent-hook)
+ ((ref-variable lisp-indent-hook)
state indent-point normal-indent))
(mark-column normal-indent)))))))
\f
(let ((name (extract-string first-sexp
(forward-one-sexp first-sexp))))
(let ((method
- (string-table-get (ref-variable "Lisp Indent Methods")
+ (string-table-get (ref-variable lisp-indent-methods)
name)))
(cond ((or (eq? method 'DEFINITION)
(and (not method)
indent-point normal-indent ;ignore
(let ((container (parse-state-containing-sexp state)))
(and (mark> (line-end container 0) (parse-state-last-sexp state))
- (+ (ref-variable "Lisp Body Indent") (mark-column container)))))
+ (+ (ref-variable lisp-body-indent) (mark-column container)))))
;;; Indent the first N subforms normally, but then indent the
;;; remaining forms at the body-indent. If this is one of the first
(define (lisp-indent-special-form n state indent-point normal-indent)
(if (negative? n) (error "Special form indent hook negative" n))
(let ((container (parse-state-containing-sexp state)))
- (let ((body-indent (+ (ref-variable "Lisp Body Indent")
+ (let ((body-indent (+ (ref-variable lisp-body-indent)
(mark-column container)))
(normal-indent (mark-column normal-indent)))
(let ((second-sexp
((zero? n)
body-indent)
(else
- (cons normal-indent container)))))))
+ (cons (if (< n 3)
+ (+ body-indent (ref-variable lisp-body-indent))
+ normal-indent)
+ container)))))))
\f
;;;; Indent Line
(if (pair? indentation) (car indentation) indentation)))
(else
(max (1+ (mark-column (horizontal-space-start mark)))
- comment-column))))
+ (ref-variable comment-column)))))
\f
;;;; Indent Expression
(maybe-change-indentation
(cond ((match-forward ";;;" mark) (mark-column mark))
((match-forward ";;" mark) (compute-indentation start stack))
- (else comment-column))
+ (else (ref-variable comment-column)))
mark)
true))))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/loadef.scm,v 1.1 1989/03/14 08:08:54 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/loadef.scm,v 1.2 1989/04/15 00:51:06 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(define-library 'INFO
'("info" (EDWIN INFO)))
-(define-variable "Info Enable Edit"
- "If true, the \\[^R Info Edit] command in Info can edit the current node."
+(define-variable info-enable-edit
+ "If true, the \\[info-edit] command in Info can edit the current node."
false)
-(define-variable "Info Enable Active Nodes"
+(define-variable info-enable-active-nodes
"If true, allows Info to execute Scheme code associated with nodes.
The Scheme code is executed when the node is selected."
true)
-(define-variable "Info Directory"
+(define-variable info-directory
"Default directory pathname for Info documentation files."
edwin-info-directory)
-(define-variable "Info Previous Search"
- "Default search string for Info \\[^R Info Search] command to search for."
+(define-variable info-previous-search
+ "Default search string for Info \\[info-search] command to search for."
false)
-(define-variable "Info Tag Table Start" "")
-(define-variable "Info Tag Table End" "")
-
-(define-autoload-command "Info" 'INFO
+(define-variable info-tag-table-start "")
+(define-variable info-tag-table-end "")
+(define-autoload-command 'info 'INFO
"Create a buffer for Info, the documentation browser program.")
(define-library 'DIRED
'("dired" (EDWIN DIRED)))
-(define-variable "List Directory Unpacked"
- "If not false, \\[List Directory] puts one file on each line.
+(define-variable list-directory-unpacked
+ "If not false, \\[list-directory] puts one file on each line.
Normally it packs many onto a line.
-This has no effect if \\[List Directory] is invoked with an argument."
+This has no effect if \\[list-directory] is invoked with an argument."
false)
-(define-autoload-command "Dired" 'DIRED
+(define-autoload-command 'dired 'DIRED
"Edit a directory. You type the directory name.")
-(define-autoload-command "Dired Other Window" 'DIRED
+(define-autoload-command 'dired-other-window 'DIRED
"Edit a directory in another window. You type the directory name.")
-(define-autoload-command "List Directory" 'DIRED
+(define-autoload-command 'list-directory 'DIRED
"Generate a directory listing.")
+
+(define-autoload-procedure 'make-dired-buffer '(EDWIN DIRED) 'DIRED)
\f
(define-library 'RECTANGLE-COMMANDS
'("reccom" (EDWIN RECTANGLE)))
-(define-autoload-command "Kill Rectangle" 'RECTANGLE-COMMANDS
+(define-autoload-command 'kill-rectangle 'RECTANGLE-COMMANDS
"Delete rectangle with corners at point and mark; save as last killed one.")
-(define-autoload-command "Delete Rectangle" 'RECTANGLE-COMMANDS
+(define-autoload-command 'delete-rectangle 'RECTANGLE-COMMANDS
"Delete (don't save) text in rectangle with point and mark as corners.
The same range of columns is deleted in each line
starting with the line where the region begins
and ending with the line where the region ends.")
-(define-autoload-command "Open Rectangle" 'RECTANGLE-COMMANDS
+(define-autoload-command 'open-rectangle 'RECTANGLE-COMMANDS
"Blank out rectangle with corners at point and mark, shifting text right.
The text previously in the region is not overwritten by the blanks,
but instead winds up to the right of the rectangle.")
-(define-autoload-command "Clear Rectangle" 'RECTANGLE-COMMANDS
+(define-autoload-command 'clear-rectangle 'RECTANGLE-COMMANDS
"Blank out rectangle with corners at point and mark.
The text previously in the region is overwritten by the blanks.")
-(define-autoload-command "Yank Rectangle" 'RECTANGLE-COMMANDS
+(define-autoload-command 'yank-rectangle 'RECTANGLE-COMMANDS
"Yank the last killed rectangle with upper left corner at point.")
-(define-autoload-procedure '(EDWIN RECTANGLE) 'delete-rectangle
+(define-autoload-procedure 'delete-rectangle '(EDWIN RECTANGLE)
'RECTANGLE-COMMANDS)
-(define-autoload-procedure '(EDWIN RECTANGLE) 'yank-rectangle
+(define-autoload-procedure 'yank-rectangle '(EDWIN RECTANGLE)
'RECTANGLE-COMMANDS)
(define-library 'COMMAND-SUMMARY
'("keymap" (EDWIN COMMAND-SUMMARY)))
-(define-autoload-command "Make Command Summary" 'COMMAND-SUMMARY
+(define-autoload-command 'make-command-summary 'COMMAND-SUMMARY
"Make a summary of current key bindings in the buffer *Summary*.
-Previous contents of that buffer are killed first.")\f
+Previous contents of that buffer are killed first.")
+(define-library 'RESTRICT-SCREEN
+ '("rescrn" (EDWIN WINDOW)))
+
+(define-autoload-command 'toggle-screen-width 'RESTRICT-SCREEN
+ "Restrict the editor's width on the screen.
+With no argument, restricts the width to 80 columns,
+ unless it is already restricted, in which case it undoes the restriction.
+With \\[universal-argument] only, undoes all restrictions.
+Otherwise, the argument is the number of columns desired.")
+\f
;;;; Tags Package
(define-library 'TAGS
'("tags" (EDWIN TAGS)))
-(define-variable "Tags Table Pathname"
+(define-variable tags-table-pathname
"Pathname of current tags table."
false)
-(define-autoload-command "Visit Tags Table" 'TAGS
+(define-autoload-command 'visit-tags-table 'TAGS
"Tell tags commands to use a given tags table file.")
-(define-autoload-command "Find Tag" 'TAGS
+(define-autoload-command 'find-tag 'TAGS
"Find tag (in current tags table) whose name contains a given string.
Selects the buffer that the tag is contained in
and puts point at its definition.
With argument, searches for the next tag in the tags table that matches
the string used in the previous Find Tag.")
-(define-autoload-command "Find Tag Other Window" 'TAGS
- "Like \\[Find Tag], but selects buffer in another window.")
-
-(define-autoload-command "Generate Tags Table" 'TAGS
- "Generate a tags table from a files list of Scheme files.
- A files list is a file containing only strings which are file names.
- The generated tags table has the same name as the files list, except that
-the file type is TAG.")
+(define-autoload-command 'find-tag-other-window 'TAGS
+ "Like \\[find-tag], but selects buffer in another window.")
-(define-autoload-command "Tags Search" 'TAGS
+(define-autoload-command 'tags-search 'TAGS
"Search through all files listed in tag table for a given string.
Stops when a match is found.
-To continue searching for next match, use command \\[Tags Loop Continue].")
+To continue searching for next match, use command \\[tags-loop-continue].")
-(define-autoload-command "RE Tags Search" 'TAGS
+(define-autoload-command 're-tags-search 'TAGS
"Search through all files listed in tag table for a given regexp.
Stops when a match is found.
-To continue searching for next match, use command \\[Tags Loop Continue].")
+To continue searching for next match, use command \\[tags-loop-continue].")
-(define-autoload-command "Tags Query Replace" 'TAGS
+(define-autoload-command 'tags-query-replace 'TAGS
"Query replace a given string with another one though all files listed
in tag table. If you exit (C-G or Altmode), you can resume the query
-replace with the command \\[Tags Loop Continue].")
+replace with the command \\[tags-loop-continue].")
-(define-autoload-command "Tags Loop Continue" 'TAGS
- "Continue last \\[Tags Search] or \\[Tags Query Replace] command.")
+(define-autoload-command 'tags-loop-continue 'TAGS
+ "Continue last \\[tags-search] or \\[tags-query-replace] command.")
\f
;;;; Major Mode Libraries
(define-library 'MIDAS-MODE
'("midas" (EDWIN)))
-(define-autoload-major-mode "Midas" "Fundamental" 'MIDAS-MODE
+(define-autoload-major-mode 'midas 'fundamental "Midas" 'MIDAS-MODE
"Major mode for editing assembly code.")
-(define-autoload-command "Midas Mode" 'MIDAS-MODE
+(define-autoload-command 'midas-mode 'MIDAS-MODE
"Enter Midas mode.")
-(define-variable "Midas Mode Hook"
+(define-variable midas-mode-hook
"If not false, a thunk to call when entering Midas mode."
false)
(define-library 'PASCAL-MODE
'("pasmod" (EDWIN)))
-(define-autoload-major-mode "Pascal" "Fundamental" 'PASCAL-MODE
+(define-autoload-major-mode 'pascal 'fundamental "Pascal" 'PASCAL-MODE
"Major mode specialized for editing Pascal code.")
-(define-autoload-command "Pascal Mode" 'PASCAL-MODE
+(define-autoload-command 'pascal-mode 'PASCAL-MODE
"Enter Pascal mode.")
-(define-variable "Pascal Mode Hook"
+(define-variable pascal-mode-hook
"If not false, a thunk to call when entering Pascal mode."
false)
-(define-variable "Pascal Shift Increment"
+(define-variable pascal-shift-increment
"Indentation increment for Pascal Shift commands."
2)
-(define-variable "Pascal Indentation Keywords"
+(define-variable pascal-indentation-keywords
"These keywords cause the lines below them to be indented to the right.
This must be a regular expression, or #F to disable the option."
false)
(define-library 'TEXINFO-MODE
'("tximod" (EDWIN)))
-(define-autoload-major-mode "Texinfo" "Text" 'TEXINFO-MODE
+(define-autoload-major-mode 'texinfo 'text "Texinfo" 'TEXINFO-MODE
"Major mode for editing texinfo files.
These are files that are input for TeX and also to be turned
-into Info files by \\[Texinfo Format Buffer].
+into Info files by \\[texinfo-format-buffer].
These files must be written in a very restricted and
modified version of TeX input format.")
-(define-autoload-command "Texinfo Mode" 'TEXINFO-MODE
+(define-autoload-command 'texinfo-mode 'TEXINFO-MODE
"Make the current mode be Texinfo mode.")
-(define-variable "Texinfo Mode Hook"
+(define-variable texinfo-mode-hook
"A procedure to be called when Texinfo mode is entered, or false."
false)
\f
'("c-mode" (EDWIN))
'("cinden" (EDWIN C-INDENTATION)))
-(define-autoload-major-mode "C" "Fundamental" 'C-MODE
+(define-autoload-major-mode 'c 'fundamental "C" 'C-MODE
"Major mode for editing C code.
Expression and list commands understand all C brackets.
Tab indents for C code.
The characters { } ; : correct indentation when typed.
Variables controlling indentation style:
- C Auto Newline
+ c-auto-newline
Non-false means automatically newline before and after braces,
and after colons and semicolons, inserted in C code.
- C Indent Level
+ c-indent-level
Indentation of C statements within surrounding block.
The surrounding block's indentation is the indentation
of the line on which the open-brace appears.
- C Continued Statement Offset
+ c-continued-statement-offset
Extra indentation given to a substatement, such as the
then-clause of an if or body of a while.
- C Brace Offset
+ c-brace-offset
Extra indentation for line if it starts with an open brace.
- C Brace Imaginary Offset
+ c-brace-imaginary-offset
An open brace following other text is treated as if it were
this far to the right of the start of its line.
- C Argdecl Indent
+ c-argdecl-indent
Indentation level of declarations of C function arguments.
- C Label Offset
+ c-label-offset
Extra indentation for line that is a label, or case or default.")
-(define-autoload-command "C Mode" 'C-MODE
+(define-autoload-command 'c-mode 'C-MODE
"Enter C mode.")
-(define-variable "C Mode Hook"
+(define-variable c-mode-hook
"If not false, a thunk to call when entering C mode."
false)
-(define-variable "C Indent Level"
+(define-variable c-indent-level
"Indentation of C statements with respect to containing block."
2)
-(define-variable "C Brace Offset"
+(define-variable c-brace-offset
"Extra indentation for braces, compared with other text in same context."
0)
-(define-variable "C Brace Imaginary Offset"
+(define-variable c-brace-imaginary-offset
"Imagined indentation of a C open brace that actually follows a statement."
0)
-(define-variable "C Argdecl Indent"
+(define-variable c-argdecl-indent
"Indentation level of declarations of C function arguments."
5)
-(define-variable "C Label Offset"
+(define-variable c-label-offset
"Offset of C label lines and case statements relative to usual indentation."
-2)
-(define-variable "C Continued Statement Offset"
+(define-variable c-continued-statement-offset
"Extra indent for lines not starting new statements."
2)
-(define-variable "C Auto Newline"
+(define-variable c-auto-newline
"Non-false means automatically newline before and after braces,
and after colons and semicolons, inserted in C code."
false)
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/lspcom.scm,v 1.148 1989/03/14 08:01:23 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/lspcom.scm,v 1.149 1989/04/15 00:51:12 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
\f
;;;; S-expression Commands
-(define-command ("^R Forward Sexp" (argument 1))
+(define-command forward-sexp
"Move forward across one balanced expression.
With argument, do this that many times."
- (move-thing forward-sexp argument))
+ "p"
+ (lambda (argument)
+ (move-thing forward-sexp argument)))
-(define-command ("^R Backward Sexp" (argument 1))
+(define-command backward-sexp
"Move backward across one balanced expression.
With argument, do this that many times."
- (move-thing backward-sexp argument))
+ "p"
+ (lambda (argument)
+ (move-thing backward-sexp argument)))
-(define-command ("^R Flash Forward Sexp" (argument 1))
+(define-command flash-sexp
"Flash the char which ends the expression to the right of point.
-Shows you where \\[^R Forward Sexp] would go."
- (mark-flash (forward-sexp (current-point) argument)
- (if (negative? argument) 'RIGHT 'LEFT)))
+Shows you where \\[forward-sexp] would go."
+ "p"
+ (lambda (argument)
+ (mark-flash (forward-sexp (current-point) argument)
+ (if (negative? argument) 'RIGHT 'LEFT))))
-(define-command ("^R Flash Backward Sexp" (argument 1))
+(define-command backward-flash-sexp
"Flash the char which starts the expression to the left of point.
-Shows you where \\[^R Backward Sexp] would go."
- (mark-flash (backward-sexp (current-point) argument)
- (if (negative? argument) 'LEFT 'RIGHT)))
+Shows you where \\[backward-sexp] would go."
+ "p"
+ (lambda (argument)
+ (mark-flash (backward-sexp (current-point) argument)
+ (if (negative? argument) 'LEFT 'RIGHT))))
-(define-command ("^R Kill Sexp" (argument 1))
+(define-command kill-sexp
"Kill the syntactic expression following the cursor.
With argument, kill that many expressions after (or before) the cursor."
- (kill-thing forward-sexp argument))
+ "p"
+ (lambda (argument)
+ (kill-thing forward-sexp argument)))
-(define-command ("^R Backward Kill Sexp" (argument 1))
+(define-command backward-kill-sexp
"Kill the syntactic expression preceding the cursor.
With argument, kill that many expressions before (or after) the cursor."
- (kill-thing backward-sexp argument))
+ "p"
+ (lambda (argument)
+ (kill-thing backward-sexp argument)))
-(define-command ("^R Transpose Sexps" (argument 1))
+(define-command transpose-sexps
"Transpose the sexps before and after point.
-See ^R Transpose Words, reading 'sexp' for 'word'."
- (transpose-things forward-sexp argument))
+See \\[transpose-words], reading 'sexp' for 'word'."
+ "p"
+ (lambda (argument)
+ (transpose-things forward-sexp argument)))
-(define-command ("^R Mark Sexp" (argument 1))
+(define-command mark-sexp
"Mark one or more sexps from point."
- (mark-thing forward-sexp argument))
+ "p"
+ (lambda (argument)
+ (mark-thing forward-sexp argument)))
\f
;;;; List Commands
-(define-command ("^R Forward List" (argument 1))
+(define-command forward-list
"Move forward across one balanced group of parentheses.
With argument, do this that many times."
- (move-thing forward-list argument))
+ "p"
+ (lambda (argument)
+ (move-thing forward-list argument)))
-(define-command ("^R Backward List" (argument 1))
+(define-command backward-list
"Move backward across one balanced group of parentheses.
With argument, do this that many times."
- (move-thing backward-list argument))
+ "p"
+ (lambda (argument)
+ (move-thing backward-list argument)))
-(define-command ("^R Forward Down List" (argument 1))
+(define-command down-list
"Move forward down one level of parentheses.
With argument, do this that many times.
A negative argument means move backward but still go down a level."
- (move-thing forward-down-list argument))
+ "p"
+ (lambda (argument)
+ (move-thing forward-down-list argument)))
-(define-command ("^R Backward Down List" (argument 1))
+(define-command backward-down-list
"Move backward down one level of parentheses.
With argument, do this that many times.
A negative argument means move forward but still go down a level."
- (move-thing backward-down-list argument))
+ "p"
+ (lambda (argument)
+ (move-thing backward-down-list argument)))
-(define-command ("^R Forward Up List" (argument 1))
+(define-command up-list
"Move forward out one level of parentheses.
With argument, do this that many times.
A negative argument means move backward but still to a less deep spot."
- (move-thing forward-up-list argument))
+ "p"
+ (lambda (argument)
+ (move-thing forward-up-list argument)))
-(define-command ("^R Backward Up List" (argument 1))
+(define-command backward-up-list
"Move backward out one level of parentheses.
With argument, do this that many times.
A negative argument means move forward but still to a less deep spot."
- (move-thing backward-up-list argument))
-
+ "p"
+ (lambda (argument)
+ (move-thing backward-up-list argument)))
+\f
;;;; Definition Commands
-(define-command ("^R Beginning of Definition" (argument 1))
+(define-command beginning-of-definition
"Move to beginning of this or previous definition.
Leaves the mark behind, in case typed by accident.
With a negative argument, moves forward to the beginning of a definition.
The beginning of a definition is determined by Definition Start."
- (move-thing backward-definition-start argument))
+ "p"
+ (lambda (argument)
+ (move-thing backward-definition-start argument)))
-(define-command ("^R End of Definition" (argument 1))
+(define-command end-of-definition
"Move to end of this or next definition.
Leaves the mark behind, in case typed by accident.
With argument of 2, finds end of following definition.
With argument of -1, finds end of previous definition, etc."
- (move-thing forward-definition-end (if (zero? argument) 1 argument)))
+ "p"
+ (lambda (argument)
+ (move-thing forward-definition-end (if (zero? argument) 1 argument))))
-(define-command ("^R Mark Definition")
+(define-command mark-definition
"Put mark at end of definition, point at beginning."
- (let ((point (current-point)))
- (let ((end (forward-definition-end point 1 'ERROR)))
- (let ((start (backward-definition-start end 1 'ERROR)))
- (push-current-mark! point)
- (push-current-mark! end)
- (set-current-point!
- (or (re-search-backward "^\n" start (mark-1+ start))
- start))))))
-
-(define-command ("^R Reposition Window")
+ ()
+ (lambda ()
+ (let ((point (current-point)))
+ (let ((end (forward-definition-end point 1 'ERROR)))
+ (let ((start (backward-definition-start end 1 'ERROR)))
+ (push-current-mark! point)
+ (push-current-mark! end)
+ (set-current-point!
+ (or (re-search-backward "^\n" start (mark-1+ start))
+ start)))))))
+
+(define-command align-definition
"Reposition window so current definition is at the top.
If this would place point off screen, nothing happens."
- (reposition-window-top (current-definition-start)))
+ ()
+ (lambda ()
+ (reposition-window-top (current-definition-start))))
(define (current-definition-start)
(let ((point (current-point)))
\f
;;;; Miscellaneous Commands
-(define-command ("^R Lisp Insert Paren" (argument 1))
+(define-command lisp-insert-paren
"Insert one or more close parens, flashing the matching open paren."
- (insert-chars (current-command-char) argument)
- (if (positive? argument)
- (let ((point (current-point)))
- (if (and (not (mark-left-char-quoted? point))
- (not (keyboard-active? 5)))
- (mark-flash (backward-one-sexp point) 'RIGHT)))))
-
-(define-command ("^R Indent for Lisp" argument)
+ "p"
+ (lambda (argument)
+ (insert-chars (current-command-char) argument)
+ (if (positive? argument)
+ (let ((point (current-point)))
+ (if (and (not (mark-left-char-quoted? point))
+ (not (keyboard-active? 5)))
+ (mark-flash (backward-one-sexp point) 'RIGHT))))))
+
+(define-command lisp-indent-line
"Indent current line as lisp code.
With argument, indent any additional lines of the same expression
rigidly along with this one."
- (lisp-indent-line argument))
+ "P"
+ (lambda (#!optional argument)
+ (lisp-indent-line (and (not (default-object? argument)) argument))))
-(define-command ("^R Indent Sexp")
+(define-command indent-sexp
"Indent each line of the expression starting just after the point."
- (lisp-indent-sexp (current-point)))
+ "d"
+ (lambda (mark)
+ (lisp-indent-sexp mark)))
;;;; Motion Covers
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/macros.scm,v 1.43 1989/03/14 08:01:25 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/macros.scm,v 1.44 1989/04/15 00:51:18 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
,@(selector-loop selector-names 1)))))))
\f
(syntax-table-define edwin-syntax-table 'DEFINE-COMMAND
- (lambda (bvl description . body)
- (let ((name (car bvl))
- (bvl (cdr bvl)))
- (let ((pname (symbol-append (canonicalize-name name) '-COMMAND)))
- `(BEGIN
- ,(if (null? bvl)
- (let ((argument (string->uninterned-symbol "ARGUMENT")))
- `(DEFINE (,pname #!OPTIONAL ,argument)
- ,argument ;ignore
- ,@body))
- (let ((arg-names
- (map (lambda (arg) (if (pair? arg) (car arg) arg))
- bvl)))
- `(DEFINE (,pname #!OPTIONAL ,@arg-names)
- (LET* ,(map (lambda (name arg)
- (let ((init (and (pair? arg) (cadr arg))))
- `(,name
- (IF ,(if (not init)
- `(DEFAULT-OBJECT? ,name)
- `(OR (DEFAULT-OBJECT? ,name)
- (NOT ,name)))
- ,init
- ,name))))
- arg-names
- bvl)
- ,@body))))
- (MAKE-COMMAND ',name ',description ,pname))))))
+ (lambda (name description interactive procedure)
+ (let ((name (canonicalize-name name)))
+ `(BEGIN
+ (DEFINE ,(command-name->scheme-name name)
+ (MAKE-COMMAND ',name
+ ',description
+ ,(if (null? interactive)
+ `'()
+ interactive)
+ ,procedure))
+ ',name))))
+
+(syntax-table-define edwin-syntax-table 'REF-COMMAND-OBJECT
+ (lambda (name)
+ (command-name->scheme-name (canonicalize-name name))))
+
+(syntax-table-define edwin-syntax-table 'REF-COMMAND
+ (lambda (name)
+ `(COMMAND-PROCEDURE
+ ,(command-name->scheme-name (canonicalize-name name)))))
+
+(define (command-name->scheme-name name)
+ (symbol-append 'EDWIN-COMMAND$ name))
(syntax-table-define edwin-syntax-table 'DEFINE-VARIABLE
- (lambda (name description . tail)
- (let ((variable-name (canonicalize-name name)))
+ (lambda (name description #!optional value)
+ (let ((name (canonicalize-name name)))
`(BEGIN
- (DEFINE ,variable-name ,@tail)
- (MAKE-VARIABLE ',name ',description ',variable-name)))))
+ (DEFINE ,(variable-name->scheme-name name)
+ (MAKE-VARIABLE ',name
+ ',description
+ ,(if (default-object? value) '#F value)))
+ ',name))))
+(syntax-table-define edwin-syntax-table 'REF-VARIABLE-OBJECT
+ (lambda (name)
+ (variable-name->scheme-name (canonicalize-name name))))
(syntax-table-define edwin-syntax-table 'REF-VARIABLE
(lambda (name)
- (canonicalize-name name)))
+ `(VARIABLE-VALUE
+ ,(variable-name->scheme-name (canonicalize-name name)))))
(syntax-table-define edwin-syntax-table 'SET-VARIABLE!
- (lambda (name . tail)
- `(BEGIN
- (SET! ,(canonicalize-name name) ,@tail)
- UNSPECIFIC)))
-
-(syntax-table-define edwin-syntax-table 'GLOBAL-SET-VARIABLE!
- (lambda (name . tail)
- (let ((variable-name (canonicalize-name name)))
- `(BEGIN
- (UNMAKE-LOCAL-BINDING! ',variable-name)
- (SET! ,variable-name ,@tail)
- UNSPECIFIC))))
+ (lambda (name #!optional value)
+ `(SET-VARIABLE-VALUE!
+ ,(variable-name->scheme-name (canonicalize-name name))
+ ,(if (default-object? value) '#F value))))
(syntax-table-define edwin-syntax-table 'LOCAL-SET-VARIABLE!
- (lambda (name . tail)
- `(MAKE-LOCAL-BINDING! ',(canonicalize-name name) ,@tail)))
+ (lambda (name #!optional value)
+ `(MAKE-LOCAL-BINDING!
+ ,(variable-name->scheme-name (canonicalize-name name))
+ ,(if (default-object? value) '#F value))))
+
+(define (variable-name->scheme-name name)
+ (symbol-append 'EDWIN-VARIABLE$ name))
\f
(syntax-table-define edwin-syntax-table 'DEFINE-MAJOR-MODE
- (lambda (name super-mode-name description . initialization)
- (let ((vname (mode-name->variable name)))
- `(DEFINE ,vname
- (MAKE-MODE ',name
- TRUE
- ,(if super-mode-name
- `(MODE-COMTABS (NAME->MODE ',super-mode-name))
- ''())
- ',description
- (LAMBDA ()
- ,@(let ((initialization
- (if super-mode-name
- `(((MODE-INITIALIZATION
- ,(mode-name->variable super-mode-name)))
- ,@initialization)
- initialization)))
- (if (null? initialization)
- `(',unspecific)
- initialization))))))))
+ (lambda (name super-mode-name display-name description . initialization)
+ (let ((name (canonicalize-name name))
+ (super-mode-name
+ (and super-mode-name (canonicalize-name super-mode-name))))
+ `(BEGIN
+ (DEFINE ,(mode-name->scheme-name name)
+ (MAKE-MODE ',name
+ TRUE
+ ',(or display-name (symbol->string name))
+ ,(if super-mode-name
+ `(MODE-COMTABS (NAME->MODE ',super-mode-name))
+ ''())
+ ',description
+ (LAMBDA ()
+ ,@(let ((initialization
+ (if super-mode-name
+ `(((MODE-INITIALIZATION
+ ,(mode-name->scheme-name
+ super-mode-name)))
+ ,@initialization)
+ initialization)))
+ (if (null? initialization)
+ `(',unspecific)
+ initialization)))))
+ ',name))))
(syntax-table-define edwin-syntax-table 'DEFINE-MINOR-MODE
- (lambda (name description . initialization)
- (let ((vname (mode-name->variable name)))
- `(DEFINE ,vname
- (MAKE-MODE ',name
- FALSE
- '()
- ',description
- (LAMBDA ()
- ,@(if (null? initialization)
- `(',unspecific)
- initialization)))))))
-
-(define-integrable (mode-name->variable name)
- (symbol-append (canonicalize-name name) '-MODE))
+ (lambda (name display-name description . initialization)
+ (let ((name (canonicalize-name name)))
+ `(BEGIN
+ (DEFINE ,(mode-name->scheme-name name)
+ (MAKE-MODE ',name
+ FALSE
+ ',(or display-name (symbol->string name))
+ '()
+ ',description
+ (LAMBDA ()
+ ,@(if (null? initialization)
+ `(',unspecific)
+ initialization))))
+ ',name))))
+
+(syntax-table-define edwin-syntax-table 'REF-MODE-OBJECT
+ (lambda (name)
+ (mode-name->scheme-name (canonicalize-name name))))
+
+(define (mode-name->scheme-name name)
+ (symbol-append 'EDWIN-MODE$ name))
(define (canonicalize-name name)
(cond ((symbol? name) name)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/midas.scm,v 1.12 1989/03/14 08:01:31 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/midas.scm,v 1.13 1989/04/15 00:51:24 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define-command ("Midas Mode")
+(define-command midas-mode
"Enter Midas mode."
- (set-current-major-mode! midas-mode))
+ ()
+ (lambda ()
+ (set-current-major-mode! (ref-mode-object midas))))
-(define-major-mode "Midas" "Fundamental"
+(define-major-mode midas fundamental "Midas"
"Major mode for editing assembly code."
- (local-set-variable! "Syntax Table" midas-mode:syntax-table)
- (local-set-variable! "Comment Column" 40)
- (local-set-variable! "Comment Locator Hook" lisp-comment-locate)
- (local-set-variable! "Comment Indent Hook" midas-comment-indentation)
- (local-set-variable! "Comment Start" ";")
- (local-set-variable! "Comment End" "")
- (local-set-variable! "Paragraph Start" "^$")
- (local-set-variable! "Paragraph Separate" (ref-variable "Paragraph Start"))
- (local-set-variable! "Indent Line Procedure" ^r-tab-command)
- (if (ref-variable "Midas Mode Hook") ((ref-variable "Midas Mode Hook"))))
+ (local-set-variable! syntax-table midas-mode:syntax-table)
+ (local-set-variable! comment-column 40)
+ (local-set-variable! comment-locator-hook lisp-comment-locate)
+ (local-set-variable! comment-indent-hook midas-comment-indentation)
+ (local-set-variable! comment-start ";")
+ (local-set-variable! comment-end "")
+ (local-set-variable! paragraph-start "^$")
+ (local-set-variable! paragraph-separate (ref-variable paragraph-start))
+ (local-set-variable! indent-line-procedure (ref-command insert-tab))
+ (if (ref-variable midas-mode-hook) ((ref-variable midas-mode-hook))))
(define midas-mode:syntax-table (make-syntax-table))
(modify-syntax-entry! midas-mode:syntax-table #\; "< ")
(if (match-forward ";;;" mark)
0
(max (1+ (mark-column (horizontal-space-start mark)))
- comment-column)))
\ No newline at end of file
+ (ref-variable comment-column))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modefs.scm,v 1.114 1989/03/14 08:01:33 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modefs.scm,v 1.115 1989/04/15 00:51:28 cph Exp $
;;;
;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define-command ("Fundamental Mode")
+(define-command fundamental-mode
"Make the current mode be Fundamental Mode.
All normal editing modes are defined relative to this mode."
- (set-current-major-mode! fundamental-mode))
+ ()
+ (lambda ()
+ (set-current-major-mode! (ref-mode-object fundamental))))
-(define-major-mode "Fundamental" #F
+(define-major-mode fundamental #f "Fundamental"
"Major mode not specialized for anything in particular.
Most other major modes are defined by comparison to this one."
- (if (ref-variable "Fundamental Mode Hook")
- ((ref-variable "Fundamental Mode Hook"))))
+ (if (ref-variable fundamental-mode-hook)
+ ((ref-variable fundamental-mode-hook))))
-(define-variable "Fundamental Mode Hook"
+(define-variable fundamental-mode-hook
"If not false, a thunk to call when entering Fundamental mode."
false)
-(define-variable "Editor Default Mode"
+(define-variable editor-default-mode
"The default major mode for new buffers."
- fundamental-mode)
+ (ref-mode-object fundamental))
-(define-variable "File Type to Major Mode"
+(define-variable file-type-to-major-mode
"Specifies the major mode for new buffers based on file type.
This is an alist, the cars of which are pathname types,
and the cdrs of which are major modes."
- `(("ASM" . ,(name->mode "Midas"))
- ("C" . ,(name->mode "C"))
- ("PAS" . ,(name->mode "Pascal"))
- ("S" . ,(name->mode "Scheme"))
- ("SCM" . ,(name->mode "Scheme"))
- ("TXI" . ,(name->mode "Texinfo"))
- ("TXT" . ,(name->mode "Text"))))
+ `(("ASM" . midas)
+ ("C" . c)
+ ("PAS" . pascal)
+ ("S" . scheme)
+ ("SCM" . scheme)
+ ("TXI" . texinfo)
+ ("TXT" . text)))
-(define-default-key "Fundamental" "^R Bad Command")
+(define-default-key 'fundamental '^r-bad-command)
-(define-key "Fundamental" char-set:graphic "^R Insert Self")
-(define-key "Fundamental" char-set:numeric "^R Autoargument Digit")
-(define-key "Fundamental" #\- "^R Auto Negative Argument")
+(define-key 'fundamental char-set:graphic 'self-insert-command)
+(define-key 'fundamental char-set:numeric 'auto-digit-argument)
+(define-key 'fundamental #\- 'auto-negative-argument)
-(define-key "Fundamental" #\Tab "^R Indent for Tab")
-(define-key "Fundamental" #\Linefeed "^R Indent New Line")
-(define-key "Fundamental" #\Page "^R New Window")
-(define-key "Fundamental" #\Return "^R Newline")
-(define-key "Fundamental" #\Altmode "^R Prefix Meta")
-(define-key "Fundamental" #\Rubout "^R Backward Delete Character")
+(define-key 'fundamental #\tab 'indent-for-tab-command)
+(define-key 'fundamental #\linefeed 'newline-and-indent)
+(define-key 'fundamental #\page 'recenter)
+(define-key 'fundamental #\return 'newline)
+(define-key 'fundamental #\altmode 'meta-prefix)
+(define-key 'fundamental #\rubout 'backward-delete-char)
+
+(define-prefix-key 'fundamental #\backspace 'help-prefix)
+(define-key 'fundamental '(#\backspace #\a) 'command-apropos)
+(define-key 'fundamental '(#\backspace #\c) 'describe-key-briefly)
+(define-key 'fundamental '(#\backspace #\d) 'describe-command)
+(define-key 'fundamental '(#\backspace #\i) 'info)
+(define-key 'fundamental '(#\backspace #\k) 'describe-key)
+(define-key 'fundamental '(#\backspace #\l) 'view-lossage)
+(define-key 'fundamental '(#\backspace #\m) 'describe-mode)
+(define-key 'fundamental '(#\backspace #\t) 'help-with-tutorial)
+(define-key 'fundamental '(#\backspace #\v) 'describe-variable)
+(define-key 'fundamental '(#\backspace #\w) 'where-is)
\f
-(define-key "Fundamental" #\C-Space "^R Set/Pop Mark")
+(define-key 'fundamental #\c-space 'set-mark-command)
;!"#$
-(define-key "Fundamental" #\C-% "Replace String")
+(define-key 'fundamental #\c-% 'replace-string)
;'()*+,
-(define-key "Fundamental" #\C-- "^R Negative Argument")
-(define-key "Fundamental" #\C-. "Tags Loop Continue")
-;/
-(define-key "Fundamental" #\C-0 "^R Argument Digit")
-(define-key "Fundamental" #\C-1 "^R Argument Digit")
-(define-key "Fundamental" #\C-2 "^R Argument Digit")
-(define-key "Fundamental" #\C-3 "^R Argument Digit")
-(define-key "Fundamental" #\C-4 "^R Argument Digit")
-(define-key "Fundamental" #\C-5 "^R Argument Digit")
-(define-key "Fundamental" #\C-6 "^R Argument Digit")
-(define-key "Fundamental" #\C-7 "^R Argument Digit")
-(define-key "Fundamental" #\C-8 "^R Argument Digit")
-(define-key "Fundamental" #\C-9 "^R Argument Digit")
+(define-key 'fundamental #\c-- 'negative-argument)
+;./
+(define-key 'fundamental #\c-0 'digit-argument)
+(define-key 'fundamental #\c-1 'digit-argument)
+(define-key 'fundamental #\c-2 'digit-argument)
+(define-key 'fundamental #\c-3 'digit-argument)
+(define-key 'fundamental #\c-4 'digit-argument)
+(define-key 'fundamental #\c-5 'digit-argument)
+(define-key 'fundamental #\c-6 'digit-argument)
+(define-key 'fundamental #\c-7 'digit-argument)
+(define-key 'fundamental #\c-8 'digit-argument)
+(define-key 'fundamental #\c-9 'digit-argument)
;:
-(define-key "Fundamental" #\C-\; "^R Indent for Comment")
-(define-key "Fundamental" #\C-< "^R Mark Beginning")
-(define-key "Fundamental" #\C-= "What Cursor Position")
-(define-key "Fundamental" #\C-> "^R Mark End")
+(define-key 'fundamental #\c-\; 'indent-for-comment)
+(define-key 'fundamental #\c-< 'mark-beginning-of-buffer)
+(define-key 'fundamental #\c-= 'what-cursor-position)
+(define-key 'fundamental #\c-> 'mark-end-of-buffer)
;?
-(define-key "Fundamental" #\C-@ "^R Set/Pop Mark")
-(define-key "Fundamental" #\C-A "^R Beginning of Line")
-(define-key "Fundamental" #\C-B "^R Backward Character")
-;C
-(define-key "Fundamental" #\C-D "^R Delete Character")
-(define-key "Fundamental" #\C-E "^R End of Line")
-(define-key "Fundamental" #\C-F "^R Forward Character")
-;GHIJ
-(define-key "Fundamental" #\C-K "^R Kill Line")
-;LM
-(define-key "Fundamental" #\C-N "^R Down Real Line")
-(define-key "Fundamental" #\C-O "^R Open Line")
-(define-key "Fundamental" #\C-P "^R Up Real Line")
-(define-key "Fundamental" #\C-Q "^R Quoted Insert")
-(define-key "Fundamental" #\C-R "^R Reverse Search")
-(define-key "Fundamental" #\C-S "^R Incremental Search")
-(define-key "Fundamental" #\C-T "^R Transpose Characters")
-(define-key "Fundamental" #\C-U "^R Universal Argument")
-(define-key "Fundamental" #\C-V "^R Next Screen")
-(define-key "Fundamental" #\C-W "^R Kill Region")
-(define-prefix-key "Fundamental" #\C-X "^R Prefix Character")
-(define-key "Fundamental" #\C-Y "^R Un-Kill")
-(define-key "Fundamental" #\C-Z "^R Prefix Control-Meta")
-;[\
-(define-key "Fundamental" #\C-\] "Abort Recursive Edit")
-(define-key "Fundamental" #\C-^ "^R Prefix Control")
-(define-key "Fundamental" #\C-_ "Undo")
+(define-key 'fundamental #\c-@ 'set-mark-command)
+(define-key 'fundamental #\c-a 'beginning-of-line)
+(define-key 'fundamental #\c-b 'backward-char)
+(define-prefix-key 'fundamental #\c-c 'prefix-char)
+(define-key 'fundamental #\c-d 'delete-char)
+(define-key 'fundamental #\c-e 'end-of-line)
+(define-key 'fundamental #\c-f 'forward-char)
+(define-key 'fundamental #\c-g 'keyboard-quit)
+;(define-prefix-key 'fundamental #\c-h 'help-prefix)
+;(define-key 'fundamental #\c-i 'indent-for-tab-command)
+;(define-key 'fundamental #\c-j 'newline-and-indent)
+(define-key 'fundamental #\c-k 'kill-line)
+;(define-key 'fundamental #\c-l 'recenter)
+;(define-key 'fundamental #\c-m 'newline)
+(define-key 'fundamental #\c-n 'next-line)
+(define-key 'fundamental #\c-o 'open-line)
+(define-key 'fundamental #\c-p 'previous-line)
+(define-key 'fundamental #\c-q 'quoted-insert)
+(define-key 'fundamental #\c-r 'isearch-backward)
+(define-key 'fundamental #\c-s 'isearch-forward)
+(define-key 'fundamental #\c-t 'transpose-chars)
+(define-key 'fundamental #\c-u 'universal-argument)
+(define-key 'fundamental #\c-v 'scroll-up)
+(define-key 'fundamental #\c-w 'kill-region)
+(define-prefix-key 'fundamental #\c-x 'prefix-char)
+(define-key 'fundamental #\c-y 'yank)
+(define-key 'fundamental #\c-z 'control-meta-prefix)
+;(define-key 'fundamental #\c-\[ 'meta-prefix)
+;\
+(define-key 'fundamental #\c-\] 'abort-recursive-edit)
+(define-key 'fundamental #\c-^ 'control-prefix)
+(define-key 'fundamental #\c-_ 'undo)
;`{|}~
-(define-key "Fundamental" #\C-Rubout "^R Backward Delete Hacking Tabs")
+(define-key 'fundamental #\c-rubout 'backward-delete-char-untabify)
\f
-(define-key "Fundamental" #\M-Backspace "^R Mark Definition")
-(define-key "Fundamental" #\M-Tab "^R Tab")
-(define-key "Fundamental" #\M-Linefeed "^R Indent New Comment Line")
-(define-key "Fundamental" #\M-Page "^R Twiddle Buffers")
-(define-key "Fundamental" #\M-Return "^R Back to Indentation")
-;Altmode
-(define-key "Fundamental" #\M-Space "^R Just One Space")
+(define-key 'fundamental #\m-backspace 'mark-definition)
+;(define-key 'fundamental #\m-tab 'insert-tab)
+(define-key 'fundamental #\m-linefeed 'indent-new-comment-line)
+(define-key 'fundamental #\m-page 'twiddle-buffers)
+;(define-key 'fundamental #\m-return 'back-to-indentation)
+(define-key 'fundamental #\m-altmode 'eval-expression)
+(define-key 'fundamental #\m-space 'just-one-space)
;!"#$
-(define-key "Fundamental" #\M-% "Query Replace")
-;'()*
-(define-key "Fundamental" #\M-+ "Pascal Filer")
-(define-key "Fundamental" #\M-, "Pascal Emulator")
-(define-key "Fundamental" #\M-- "^R Autoargument")
-(define-key "Fundamental" #\M-. "Find Tag")
-(define-key "Fundamental" #\M-/ "Describe Command")
-(define-key "Fundamental" #\M-0 "^R Autoargument")
-(define-key "Fundamental" #\M-1 "^R Autoargument")
-(define-key "Fundamental" #\M-2 "^R Autoargument")
-(define-key "Fundamental" #\M-3 "^R Autoargument")
-(define-key "Fundamental" #\M-4 "^R Autoargument")
-(define-key "Fundamental" #\M-5 "^R Autoargument")
-(define-key "Fundamental" #\M-6 "^R Autoargument")
-(define-key "Fundamental" #\M-7 "^R Autoargument")
-(define-key "Fundamental" #\M-8 "^R Autoargument")
-(define-key "Fundamental" #\M-9 "^R Autoargument")
+(define-key 'fundamental #\m-% 'query-replace)
+;'()*+
+(define-key 'fundamental #\m-, 'tags-loop-continue)
+(define-key 'fundamental #\m-- 'auto-argument)
+(define-key 'fundamental #\m-. 'find-tag)
+;(define-key 'fundamental #\m-/ 'describe-command)
+(define-key 'fundamental #\m-0 'auto-argument)
+(define-key 'fundamental #\m-1 'auto-argument)
+(define-key 'fundamental #\m-2 'auto-argument)
+(define-key 'fundamental #\m-3 'auto-argument)
+(define-key 'fundamental #\m-4 'auto-argument)
+(define-key 'fundamental #\m-5 'auto-argument)
+(define-key 'fundamental #\m-6 'auto-argument)
+(define-key 'fundamental #\m-7 'auto-argument)
+(define-key 'fundamental #\m-8 'auto-argument)
+(define-key 'fundamental #\m-9 'auto-argument)
;:
-(define-key "Fundamental" #\M-\; "^R Indent for Comment")
-(define-key "Fundamental" #\M-< "^R Goto Beginning")
-(define-key "Fundamental" #\M-= "^R Count Lines Region")
-(define-key "Fundamental" #\M-> "^R Goto End")
-(define-key "Fundamental" #\M-? "Describe Command")
-(define-key "Fundamental" #\M-@ "^R Mark Word")
-(define-key "Fundamental" #\M-A "^R Backward Sentence")
-(define-key "Fundamental" #\M-B "^R Backward Word")
-(define-key "Fundamental" #\M-C "^R Uppercase Initial")
-(define-key "Fundamental" #\M-D "^R Kill Word")
-(define-key "Fundamental" #\M-E "^R Forward Sentence")
-(define-key "Fundamental" #\M-F "^R Forward Word")
-;(define-key "Fundamental" #\M-G "^R Fill Region")
-(define-key "Fundamental" #\M-H "^R Mark Paragraph")
-(define-key "Fundamental" #\M-I "^R Tab to Tab Stop")
-(define-key "Fundamental" #\M-J "^R Indent New Comment Line")
-(define-key "Fundamental" #\M-K "^R Kill Sentence")
-(define-key "Fundamental" #\M-L "^R Lowercase Word")
-(define-key "Fundamental" #\M-M "^R Back to Indentation")
-;NOP
-(define-key "Fundamental" #\M-Q "^R Fill Paragraph")
-(define-key "Fundamental" #\M-R "^R Move to Screen Edge")
-;S
-(define-key "Fundamental" #\M-T "^R Transpose Words")
-(define-key "Fundamental" #\M-U "^R Uppercase Word")
-(define-key "Fundamental" #\M-V "^R Previous Screen")
-(define-key "Fundamental" #\M-W "^R Copy Region")
-(define-key "Fundamental" #\M-X "^R Extended Command")
-(define-key "Fundamental" #\M-Y "^R Un-Kill Pop")
-;Z
-(define-key "Fundamental" #\M-\[ "^R Backward Paragraph")
-(define-key "Fundamental" #\M-\\ "^R Delete Horizontal Space")
-(define-key "Fundamental" #\M-\] "^R Forward Paragraph")
-(define-key "Fundamental" #\M-^ "^R Delete Indentation")
-;_`{|}
-(define-key "Fundamental" #\M-~ "^R Buffer Not Modified")
-(define-key "Fundamental" #\M-Rubout "^R Backward Kill Word")
+(define-key 'fundamental #\m-\; 'indent-for-comment)
+(define-key 'fundamental #\m-< 'beginning-of-buffer)
+(define-key 'fundamental #\m-= 'count-lines-region)
+(define-key 'fundamental #\m-> 'end-of-buffer)
+;?
+(define-key 'fundamental #\m-@ 'mark-word)
+(define-key 'fundamental #\m-\[ 'backward-paragraph)
+(define-key 'fundamental #\m-\\ 'delete-horizontal-space)
+(define-key 'fundamental #\m-\] 'forward-paragraph)
+(define-key 'fundamental #\m-^ 'delete-indentation)
+;_`
+(define-key 'fundamental #\m-a 'backward-sentence)
+(define-key 'fundamental #\m-b 'backward-word)
+(define-key 'fundamental #\m-c 'capitalize-word)
+(define-key 'fundamental #\m-d 'kill-word)
+(define-key 'fundamental #\m-e 'forward-sentence)
+(define-key 'fundamental #\m-f 'forward-word)
+(define-key 'fundamental #\m-g 'fill-region)
+(define-key 'fundamental #\m-h 'mark-paragraph)
+(define-key 'fundamental #\m-i 'tab-to-tab-stop)
+(define-key 'fundamental #\m-j 'indent-new-comment-line)
+(define-key 'fundamental #\m-k 'kill-sentence)
+(define-key 'fundamental #\m-l 'downcase-word)
+(define-key 'fundamental #\m-m 'back-to-indentation)
+;nop
+(define-key 'fundamental #\m-q 'fill-paragraph)
+(define-key 'fundamental #\m-r 'move-to-window-line)
+;s
+(define-key 'fundamental #\m-t 'transpose-words)
+(define-key 'fundamental #\m-u 'upcase-word)
+(define-key 'fundamental #\m-v 'scroll-down)
+(define-key 'fundamental #\m-w 'copy-region-as-kill)
+(define-key 'fundamental #\m-x 'execute-extended-command)
+(define-key 'fundamental #\m-y 'yank-pop)
+(define-key 'fundamental #\m-z 'zap-to-char)
+;{|}
+(define-key 'fundamental #\m-~ 'not-modified)
+(define-key 'fundamental #\m-rubout 'backward-kill-word)
\f
-(define-key "Fundamental" #\C-M-Space "^R Mark Sexp")
-(define-key "Fundamental" #\C-M-0 "^R Argument Digit")
-(define-key "Fundamental" #\C-M-1 "^R Argument Digit")
-(define-key "Fundamental" #\C-M-2 "^R Argument Digit")
-(define-key "Fundamental" #\C-M-3 "^R Argument Digit")
-(define-key "Fundamental" #\C-M-4 "^R Argument Digit")
-(define-key "Fundamental" #\C-M-5 "^R Argument Digit")
-(define-key "Fundamental" #\C-M-6 "^R Argument Digit")
-(define-key "Fundamental" #\C-M-7 "^R Argument Digit")
-(define-key "Fundamental" #\C-M-8 "^R Argument Digit")
-(define-key "Fundamental" #\C-M-9 "^R Argument Digit")
-(define-key "Fundamental" #\C-M-- "^R Negative Argument")
+(define-key 'fundamental #\c-m-space 'mark-sexp)
+(define-key 'fundamental #\c-m-0 'digit-argument)
+(define-key 'fundamental #\c-m-1 'digit-argument)
+(define-key 'fundamental #\c-m-2 'digit-argument)
+(define-key 'fundamental #\c-m-3 'digit-argument)
+(define-key 'fundamental #\c-m-4 'digit-argument)
+(define-key 'fundamental #\c-m-5 'digit-argument)
+(define-key 'fundamental #\c-m-6 'digit-argument)
+(define-key 'fundamental #\c-m-7 'digit-argument)
+(define-key 'fundamental #\c-m-8 'digit-argument)
+(define-key 'fundamental #\c-m-9 'digit-argument)
+(define-key 'fundamental #\c-m-- 'negative-argument)
-(define-key "Fundamental" #\C-M-\\ "^R Indent Region")
-(define-key "Fundamental" #\C-M-^ "^R Delete Indentation")
-(define-key "Fundamental" #\C-M-\( "^R Backward Up List")
-(define-key "Fundamental" #\C-M-\) "^R Forward Up List")
-(define-key "Fundamental" #\C-M-@ "^R Mark Sexp")
-(define-key "Fundamental" #\C-M-\; "^R Kill Comment")
+(define-key 'fundamental #\c-m-\\ 'indent-region)
+(define-key 'fundamental #\c-m-^ 'delete-indentation)
+(define-key 'fundamental #\c-m-\( 'backward-up-list)
+(define-key 'fundamental #\c-m-\) 'up-list)
+(define-key 'fundamental #\c-m-@ 'mark-sexp)
+(define-key 'fundamental #\c-m-\; 'kill-comment)
-(define-key "Fundamental" #\C-M-A "^R Beginning of Definition")
-(define-key "Fundamental" #\C-M-B "^R Backward Sexp")
-(define-key "Fundamental" #\C-M-C "^R Exit")
-(define-key "Fundamental" #\C-M-D "^R Forward Down List")
-(define-key "Fundamental" #\C-M-E "^R End of Definition")
-(define-key "Fundamental" #\C-M-F "^R Forward Sexp")
-;GHIJ
-(define-key "Fundamental" #\C-M-K "^R Kill Sexp")
-;LM
-(define-key "Fundamental" #\C-M-N "^R Forward List")
-(define-key "Fundamental" #\C-M-O "^R Split Line")
-(define-key "Fundamental" #\C-M-P "^R Backward List")
+(define-key 'fundamental #\c-m-a 'beginning-of-definition)
+(define-key 'fundamental #\c-m-b 'backward-sexp)
+(define-key 'fundamental #\c-m-c 'exit-recursive-edit)
+(define-key 'fundamental #\c-m-d 'down-list)
+(define-key 'fundamental #\c-m-e 'end-of-definition)
+(define-key 'fundamental #\c-m-f 'forward-sexp)
+;G
+(define-key 'fundamental #\c-m-h 'mark-definition)
+;I
+;(define-key 'fundamental #\c-m-j 'indent-new-comment-line)
+(define-key 'fundamental #\c-m-k 'kill-sexp)
+;(define-key 'fundamental #\c-m-l 'twiddle-buffers)
+;M
+(define-key 'fundamental #\c-m-n 'forward-list)
+(define-key 'fundamental #\c-m-o 'split-line)
+(define-key 'fundamental #\c-m-p 'backward-list)
;Q
-(define-key "Fundamental" #\C-M-R "^R Reposition Window")
-;S
-(define-key "Fundamental" #\C-M-T "^R Transpose Sexps")
-(define-key "Fundamental" #\C-M-U "^R Backward Up List")
-(define-key "Fundamental" #\C-M-V "^R Scroll Other Window")
-(define-key "Fundamental" #\C-M-W "^R Append Next Kill")
+(define-key 'fundamental #\c-m-r 'align-definition)
+(define-key 'fundamental #\c-m-s 'isearch-forward-regexp)
+(define-key 'fundamental #\c-m-t 'transpose-sexps)
+(define-key 'fundamental #\c-m-u 'backward-up-list)
+(define-key 'fundamental #\c-m-v 'scroll-other-window)
+(define-key 'fundamental #\c-m-w 'append-next-kill)
;XYZ
-(define-key "Fundamental" #\C-M-Rubout "^R Backward Kill Sexp")
-\f
-;Backspace
-(define-key "Fundamental" '(#\C-X #\Tab) "^R Indent Rigidly")
-;Linefeed
-(define-key "Fundamental" '(#\C-X #\Page) "^R Lowercase Region")
-;Return,Altmode
+(define-key 'fundamental #\c-m-rubout 'backward-kill-sexp)
+\f;backspace
+(define-key 'fundamental '(#\c-x #\tab) 'indent-rigidly)
+;linefeed
+(define-key 'fundamental '(#\c-x #\page) 'downcase-region)
+;return
+(define-key 'fundamental '(#\c-x #\altmode) 'repeat-complex-command)
;A
-(define-key "Fundamental" '(#\C-X #\C-B) "List Buffers")
+(define-key 'fundamental '(#\c-x #\c-b) 'list-buffers)
;C
-(define-key "Fundamental" '(#\C-X #\C-D) "List Directory")
-(define-key "Fundamental" '(#\C-X #\C-E) "^R Evaluate Previous Sexp")
-(define-key "Fundamental" '(#\C-X #\C-F) "Find File")
-;GHIJKLM
-(define-key "Fundamental" '(#\C-X #\C-N) "^R Set Goal Column")
-(define-key "Fundamental" '(#\C-X #\C-O) "^R Delete Blank Lines")
-(define-key "Fundamental" '(#\C-X #\C-P) "^R Mark Page")
-(define-key "Fundamental" '(#\C-X #\C-Q) "Toggle Read Only")
+(define-key 'fundamental '(#\c-x #\c-d) 'list-directory)
+(define-key 'fundamental '(#\c-x #\c-e) 'eval-previous-sexp)
+(define-key 'fundamental '(#\c-x #\c-f) 'find-file)
+;GH
+;(define-key 'fundamental '(#\c-x #\c-i) 'indent-rigidly)
+;JK
+;(define-key 'fundamental '(#\c-x #\c-l) 'downcase-region)
+;M
+(define-key 'fundamental '(#\c-x #\c-n) 'set-goal-column)
+(define-key 'fundamental '(#\c-x #\c-o) 'delete-blank-lines)
+(define-key 'fundamental '(#\c-x #\c-p) 'mark-page)
+(define-key 'fundamental '(#\c-x #\c-q) 'toggle-read-only)
;R
-(define-key "Fundamental" '(#\C-X #\C-S) "^R Save File")
-(define-key "Fundamental" '(#\C-X #\C-T) "^R Transpose Lines")
-(define-key "Fundamental" '(#\C-X #\C-U) "^R Uppercase Region")
-(define-key "Fundamental" '(#\C-X #\C-V) "^R Find Alternate File")
-(define-key "Fundamental" '(#\C-X #\C-W) "Write File")
-(define-key "Fundamental" '(#\C-X #\C-X) "^R Exchange Point and Mark")
-(define-key "Fundamental" '(#\C-X #\C-Z) "^R Return to Superior")
+(define-key 'fundamental '(#\c-x #\c-s) 'save-buffer)
+(define-key 'fundamental '(#\c-x #\c-t) 'transpose-lines)
+(define-key 'fundamental '(#\c-x #\c-u) 'upcase-region)
+(define-key 'fundamental '(#\c-x #\c-v) 'find-alternate-file)
+(define-key 'fundamental '(#\c-x #\c-w) 'write-file)
+(define-key 'fundamental '(#\c-x #\c-x) 'exchange-point-and-mark)
+(define-key 'fundamental '(#\c-x #\c-z) 'suspend-scheme)
;!"#$%&'
-(define-key "Fundamental" '(#\C-X #\() "Start Keyboard Macro")
-(define-key "Fundamental" '(#\C-X #\)) "End Keyboard Macro")
+(define-key 'fundamental '(#\c-x #\() 'start-kbd-macro)
+(define-key 'fundamental '(#\c-x #\)) 'end-kbd-macro)
;*+,-
-(define-key "Fundamental" '(#\C-X #\.) "^R Set Fill Prefix")
-(define-key "Fundamental" '(#\C-X #\/) "Point to Register")
-(define-key "Fundamental" '(#\C-X #\0) "^R Delete Window")
-(define-key "Fundamental" '(#\C-X #\1) "^R Delete Other Windows")
-(define-key "Fundamental" '(#\C-X #\2) "^R Split Window Vertically")
-(define-key "Fundamental" '(#\C-X #\3) "Kill Pop Up Buffer")
-(define-prefix-key "Fundamental" '(#\C-X #\4) "^R Prefix Character")
-(define-key "Fundamental" '(#\C-X #\4 #\.) "Find Tag Other Window")
-(define-key "Fundamental" '(#\C-X #\4 #\B) "Select Buffer Other Window")
-(define-key "Fundamental" '(#\C-X #\4 #\D) "Dired Other Window")
-(define-key "Fundamental" '(#\C-X #\4 #\F) "Find File Other Window")
-(define-key "Fundamental" '(#\C-X #\5) "^R Split Window Horizontally")
+(define-key 'fundamental '(#\c-x #\.) 'set-fill-prefix)
+(define-key 'fundamental '(#\c-x #\/) 'point-to-register)
+(define-key 'fundamental '(#\c-x #\0) 'delete-window)
+(define-key 'fundamental '(#\c-x #\1) 'delete-other-windows)
+(define-key 'fundamental '(#\c-x #\2) 'split-window-vertically)
+;(define-key 'fundamental '(#\c-x #\3) 'kill-pop-up-buffer)
+(define-prefix-key 'fundamental '(#\c-x #\4) 'prefix-char)
+(define-key 'fundamental '(#\c-x #\4 #\c-f) 'find-file-other-window)
+(define-key 'fundamental '(#\c-x #\4 #\.) 'find-tag-other-window)
+(define-key 'fundamental '(#\c-x #\4 #\b) 'switch-to-buffer-other-window)
+(define-key 'fundamental '(#\c-x #\4 #\d) 'dired-other-window)
+(define-key 'fundamental '(#\c-x #\4 #\f) 'find-file-other-window)
+(define-key 'fundamental '(#\c-x #\5) 'split-window-horizontally)
;:
-(define-key "Fundamental" '(#\C-X #\;) "^R Set Comment Column")
+(define-key 'fundamental '(#\c-x #\;) 'set-comment-column)
;<
-(define-key "Fundamental" '(#\C-X #\=) "What Cursor Position")
-;>?A
-(define-key "Fundamental" '(#\C-X #\B) "Select Buffer")
-;C
-(define-key "Fundamental" '(#\C-X #\D) "Dired")
-(define-key "Fundamental" '(#\C-X #\E) "Call Last Keyboard Macro")
-(define-key "Fundamental" '(#\C-X #\F) "^R Set Fill Column")
-(define-key "Fundamental" '(#\C-X #\G) "Insert Register")
-(define-key "Fundamental" '(#\C-X #\H) "^R Mark Whole Buffer")
-(define-key "Fundamental" '(#\C-X #\I) "Insert File")
-(define-key "Fundamental" '(#\C-X #\J) "Register to Point")
-(define-key "Fundamental" '(#\C-X #\K) "Kill Buffer")
-(define-key "Fundamental" '(#\C-X #\L) "^R Count Lines Page")
-;M
-;(define-key "Fundamental" '(#\C-X #\N) "^R Narrow Bounds to Region")
-(define-key "Fundamental" '(#\C-X #\O) "^R Other Window")
-;(define-key "Fundamental" '(#\C-X #\P) "^R Narrow Bounds to Page")
-(define-key "Fundamental" '(#\C-X #\Q) "Keyboard Macro Query")
-(define-key "Fundamental" '(#\C-X #\R) "Copy Rectangle to Register")
-(define-key "Fundamental" '(#\C-X #\S) "Save Some Buffers")
-;(define-key "Fundamental" '(#\C-X #\T) "^R Transpose Regions")
-(define-key "Fundamental" '(#\C-X #\U) "Undo")
-(define-key "Fundamental" '(#\C-X #\V) "^R Screen Video")
-(define-key "Fundamental" '(#\C-X #\W) "^R Widen Bounds")
-(define-key "Fundamental" '(#\C-X #\X) "Copy to Register")
-;Y
-(define-key "Fundamental" '(#\C-X #\Z) "^R Scheme")
-(define-key "Fundamental" '(#\C-X #\[) "^R Previous Page")
+(define-key 'fundamental '(#\c-x #\=) 'what-cursor-position)
+;>?
+(define-key 'fundamental '(#\c-x #\[) 'backward-page)
;\
-(define-key "Fundamental" '(#\C-X #\]) "^R Next Page")
-(define-key "Fundamental" '(#\C-X #\^) "^R Enlarge Window Vertically")
+(define-key 'fundamental '(#\c-x #\]) 'forward-page)
+(define-key 'fundamental '(#\c-x #\^) 'enlarge-window)
;_`
-(define-key "Fundamental" '(#\C-X #\{) "^R Shrink Window Horizontally")
+;a
+(define-key 'fundamental '(#\c-x #\b) 'switch-to-buffer);c
+(define-key 'fundamental '(#\c-x #\d) 'dired)
+(define-key 'fundamental '(#\c-x #\e) 'call-last-kbd-macro)
+(define-key 'fundamental '(#\c-x #\f) 'set-fill-column)
+(define-key 'fundamental '(#\c-x #\g) 'insert-register)
+(define-key 'fundamental '(#\c-x #\h) 'mark-whole-buffer)
+(define-key 'fundamental '(#\c-x #\i) 'insert-file)
+(define-key 'fundamental '(#\c-x #\j) 'register-to-point)
+(define-key 'fundamental '(#\c-x #\k) 'kill-buffer)
+(define-key 'fundamental '(#\c-x #\l) 'count-lines-page)
+;m
+(define-key 'fundamental '(#\c-x #\n) 'narrow-to-region)
+(define-key 'fundamental '(#\c-x #\o) 'other-window)
+(define-key 'fundamental '(#\c-x #\p) 'narrow-to-page)
+(define-key 'fundamental '(#\c-x #\q) 'kbd-macro-query)
+(define-key 'fundamental '(#\c-x #\r) 'copy-rectangle-to-register)
+(define-key 'fundamental '(#\c-x #\s) 'save-some-buffers)
+;(define-key 'fundamental '(#\c-x #\t) 'transpose-regions)
+(define-key 'fundamental '(#\c-x #\u) 'undo)
+;v
+(define-key 'fundamental '(#\c-x #\w) 'widen)
+(define-key 'fundamental '(#\c-x #\x) 'copy-to-register)
+;y
+(define-key 'fundamental '(#\c-x #\z) 'suspend-edwin)
+(define-key 'fundamental '(#\c-x #\{) 'shrink-window-horizontally)
;|
-(define-key "Fundamental" '(#\C-X #\}) "^R Enlarge Window Horizontally")
-;~
-(define-key "Fundamental" '(#\C-X #\Rubout) "^R Backward Kill Sentence")
\ No newline at end of file
+(define-key 'fundamental '(#\c-x #\}) 'enlarge-window-horizontally)
+;~(define-key 'fundamental '(#\c-x #\rubout) 'backward-kill-sentence)
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modes.scm,v 1.21 1989/03/14 08:01:35 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modes.scm,v 1.22 1989/04/15 00:51:38 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
\f
(define-named-structure "Mode"
name
+ display-name
major?
comtabs
description
initialization
alist
)
-(define (make-mode name major? comtabs description initialization)
- (let ((mode (or (string-table-get editor-modes name)
- (let ((mode (%make-mode)))
- (vector-set! mode mode-index:comtabs (list (make-comtab)))
- (string-table-put! editor-modes name mode)
- mode))))
+(define (make-mode name major? display-name comtabs description initialization)
+ (let ((mode
+ (let ((name (symbol->string name)))
+ (or (string-table-get editor-modes name)
+ (let ((mode (%make-mode)))
+ (vector-set! mode mode-index:comtabs (list (make-comtab)))
+ (string-table-put! editor-modes name mode)
+ mode)))))
(vector-set! mode mode-index:name name)
+ (vector-set! mode mode-index:display-name display-name)
(vector-set! mode mode-index:major? major?)
(set-cdr! (vector-ref mode mode-index:comtabs) comtabs)
(vector-set! mode mode-index:description description)
(make-string-table))
(define (name->mode name)
- (or (string-table-get editor-modes name)
- (make-mode name
- true
- '()
- ""
- (lambda () (error "Undefined mode" name)))))
\ No newline at end of file
+ (let ((name (canonicalize-name name)))
+ (or (string-table-get editor-modes (symbol->string name))
+ (make-mode name
+ true
+ (symbol->string name)
+ '()
+ ""
+ (lambda () (error "Undefined mode" name))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modwin.scm,v 1.27 1989/03/14 08:01:37 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modwin.scm,v 1.28 1989/04/15 00:51:42 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
xl xu yl yu display-style)
display-style ;ignore
(if (< yl yu)
- (with-inverse-video! screen (ref-variable "Mode Line Inverse Video")
+ (with-inverse-video! screen (ref-variable mode-line-inverse-video)
(lambda ()
(screen-write-substring!
screen x-start y-start
"("
(let loop ((modes (buffer-modes buffer)))
(if (null? (cdr modes))
- (string-append (mode-name (car modes))
+ (string-append (mode-display-name (car modes))
(if *defining-keyboard-macro?* " Def" "")
(if (group-clipped? (buffer-group buffer))
" Narrow" ""))
- (string-append (mode-name (car modes))
+ (string-append (mode-display-name (car modes))
" "
(loop (cdr modes)))))
")"
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/motcom.scm,v 1.37 1989/03/14 08:01:39 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/motcom.scm,v 1.38 1989/04/15 00:51:47 cph Exp $
;;;
;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define-command ("^R Beginning of Line" (argument 1))
+(define-command beginning-of-line
"Move point to beginning of line."
- (set-current-point! (line-start (current-point) (-1+ argument) 'LIMIT)))
+ "p"
+ (lambda (argument)
+ (set-current-point! (line-start (current-point) (-1+ argument) 'LIMIT))))
-(define-command ("^R Backward Character" (argument 1))
+(define-command backward-char
"Move back one character.
With argument, move that many characters backward.
Negative arguments move forward."
- (move-thing mark- argument))
+ "p"
+ (lambda (argument)
+ (move-thing mark- argument)))
-(define-command ("^R End of Line" (argument 1))
+(define-command end-of-line
"Move point to end of line."
- (set-current-point! (line-end (current-point) (-1+ argument) 'LIMIT)))
+ "p"
+ (lambda (argument)
+ (set-current-point! (line-end (current-point) (-1+ argument) 'LIMIT))))
-(define-command ("^R Forward Character" (argument 1))
+(define-command forward-char
"Move forward one character.
With argument, move that many characters forward.
Negative args move backward."
- (move-thing mark+ argument))
+ "p"
+ (lambda (argument)
+ (move-thing mark+ argument)))
-(define-command ("^R Goto Beginning" argument)
+(define-command beginning-of-buffer
"Go to beginning of buffer (leaving mark behind).
With arg from 0 to 10, goes that many tenths of the file
-down from the beginning. Just C-U as arg means go to end."
- (push-current-mark! (current-point))
- (cond ((not argument)
- (set-current-point! (buffer-start (current-buffer))))
- ((command-argument-multiplier-only?)
- (set-current-point! (buffer-end (current-buffer))))
- ((<= 0 argument 10)
- (set-current-point! (region-10ths (buffer-region (current-buffer))
- argument)))))
+down from the beginning. Just \\[universal-argument] as arg means go to end."
+ "P"
+ (lambda (argument)
+ (push-current-mark! (current-point))
+ (cond ((not argument)
+ (set-current-point! (buffer-start (current-buffer))))
+ ((command-argument-multiplier-only?)
+ (set-current-point! (buffer-end (current-buffer))))
+ ((<= 0 argument 10)
+ (set-current-point! (region-10ths (buffer-region (current-buffer))
+ argument))))))
-(define-command ("^R Goto End" argument)
+(define-command end-of-buffer
"Go to end of buffer (leaving mark behind).
With arg from 0 to 10, goes up that many tenths of the file from the end."
- (push-current-mark! (current-point))
- (cond ((not argument)
- (set-current-point! (buffer-end (current-buffer))))
- ((<= 0 argument 10)
- (set-current-point! (region-10ths (buffer-region (current-buffer))
- (- 10 argument))))))
+ "P"
+ (lambda (argument)
+ (push-current-mark! (current-point))
+ (cond ((not argument)
+ (set-current-point! (buffer-end (current-buffer))))
+ ((<= 0 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)))
\f
-(define-command ("Goto Char" (argument 0))
- "Goto the Nth character from the start of the buffer.
-A negative argument goes to the -Nth character from the end of the buffer."
- (let ((mark (mark+ ((if (negative? argument) buffer-end buffer-start)
- (current-buffer))
- argument)))
- (if mark
- (set-current-point! mark)
- (editor-error))))
+(define-command goto-char
+ "Goto the Nth character from the start of the buffer."
+ "p"
+ (lambda (argument)
+ (let ((mark (mark+ (buffer-start (current-buffer)) (-1+ argument))))
+ (if mark
+ (set-current-point! mark)
+ (editor-error)))))
-(define-command ("Goto Line" (argument 0))
- "Goto the Nth line from the start of the buffer.
-A negative argument goes to the -Nth line from the end of the buffer."
- (let ((mark (line-start ((if (negative? argument) buffer-end buffer-start)
- (current-buffer))
- argument)))
- (if mark
- (set-current-point! mark)
- (editor-error))))
+(define-command goto-line
+ "Goto the Nth line from the start of the buffer."
+ "p"
+ (lambda (argument)
+ (let ((mark (line-start (buffer-start (current-buffer)) (-1+ argument))))
+ (if mark
+ (set-current-point! mark)
+ (editor-error)))))
-(define-command ("Goto Page" (argument 1))
- "Goto the Nth page from the start of the buffer.
-A negative argument goes to the -Nth page from the end of the buffer."
- (let ((mark (forward-page ((if (negative? argument) buffer-end buffer-start)
- (current-buffer))
- (cond ((negative? argument) argument)
- ((positive? argument) (-1+ argument))
- (else 1)))))
- (if mark
- (set-current-point! mark)
- (editor-error))))
+(define-command goto-page
+ "Goto the Nth page from the start of the buffer."
+ "p"
+ (lambda (argument)
+ (let ((mark (forward-page (buffer-start (current-buffer)) (-1+ argument))))
+ (if mark
+ (set-current-point! mark)
+ (editor-error)))))
\f
-(define-variable "Goal Column"
+(define-variable goal-column
"Semipermanent goal column for vertical motion,
-as set by \\[^R Set Goal Column], or false, indicating no goal column."
+as set by \\[set-goal-column], or false, indicating no goal column."
false)
(define temporary-goal-column-tag
"Temporary Goal Column")
-(define-command ("^R Set Goal Column" argument)
+(define-command set-goal-column
"Set (or flush) a permanent goal for vertical motion.
With no argument, makes the current column the goal for vertical
motion commands. They will always try to go to that column.
With argument, clears out any previously set goal.
-Only \\[^R Up Real Line] and \\[^R Down Real Line] are affected."
- (set! goal-column
- (and (not argument)
- (current-column))))
+Only \\[previous-line] and \\[next-line] are affected."
+ "P"
+ (lambda (argument)
+ (set-variable! goal-column (and (not argument) (current-column)))))
(define (current-goal-column)
- (or goal-column
+ (or (ref-variable goal-column)
(command-message-receive temporary-goal-column-tag
identity-procedure
current-column)))
-(define-command ("^R Down Real Line" argument)
+(define-command next-line
"Move down vertically to next real line.
Continuation lines are skipped. If given after the
last newline in the buffer, makes a new one at the end."
- (let ((column (current-goal-column)))
- (cond ((not argument)
- (let ((mark (line-start (current-point) 1 false)))
- (if mark
- (set-current-point! (move-to-column mark column))
- (begin (set-current-point! (group-end (current-point)))
- (insert-newlines 1)))))
- ((not (zero? argument))
- (set-current-point!
- (move-to-column (line-start (current-point) argument 'FAILURE)
- column))))
- (set-command-message! temporary-goal-column-tag column)))
+ "P"
+ (lambda (argument)
+ (let ((column (current-goal-column)))
+ (cond ((not argument)
+ (let ((mark (line-start (current-point) 1 false)))
+ (if mark
+ (set-current-point! (move-to-column mark column))
+ (begin (set-current-point! (group-end (current-point)))
+ (insert-newlines 1)))))
+ ((not (zero? argument))
+ (set-current-point!
+ (move-to-column (line-start (current-point) argument 'FAILURE)
+ column))))
+ (set-command-message! temporary-goal-column-tag column))))
-(define-command ("^R Up Real Line" (argument 1))
+(define-command previous-line
"Move up vertically to next real line.
Continuation lines are skipped."
- (let ((column (current-goal-column)))
- (if (not (zero? argument))
- (set-current-point!
- (move-to-column (line-start (current-point) (- argument) 'FAILURE)
- column)))
- (set-command-message! temporary-goal-column-tag column)))
\ No newline at end of file
+ "p"
+ (lambda (argument)
+ (let ((column (current-goal-column)))
+ (if (not (zero? argument))
+ (set-current-point!
+ (move-to-column (line-start (current-point) (- argument) 'FAILURE)
+ column)))
+ (set-command-message! temporary-goal-column-tag column))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/pasmod.scm,v 1.40 1989/03/14 08:01:46 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/pasmod.scm,v 1.41 1989/04/15 00:51:52 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define-command ("Pascal Mode")
+(define-command pascal-mode
"Enter Pascal mode."
- (set-current-major-mode! pascal-mode))
+ ()
+ (lambda ()
+ (set-current-major-mode! (ref-mode-object pascal))))
-(define-major-mode "Pascal" "Fundamental"
+(define-major-mode pascal fundamental "Pascal"
"Major mode specialized for editing Pascal code."
- (local-set-variable! "Syntax Table" pascal-mode:syntax-table)
- (local-set-variable! "Syntax Ignore Comments Backwards" true)
- (local-set-variable! "Indent Line Procedure" ^r-pascal-indent-command)
- (local-set-variable! "Comment Column" 32)
- (local-set-variable! "Comment Locator Hook" pascal-comment-locate)
- (local-set-variable! "Comment Indent Hook" pascal-comment-indentation)
- (local-set-variable! "Comment Start" "(* ")
- (local-set-variable! "Comment End" " *)")
- (local-set-variable! "Paragraph Start" "^$")
- (local-set-variable! "Paragraph Separate" (ref-variable "Paragraph Start"))
- (local-set-variable! "Delete Indentation Right Protected" (char-set #\( #\[))
- (local-set-variable! "Delete Indentation Left Protected" (char-set #\) #\]))
- (if (ref-variable "Pascal Mode Hook")
- ((ref-variable "Pascal Mode Hook"))))
+ (local-set-variable! syntax-table pascal-mode:syntax-table)
+ (local-set-variable! syntax-ignore-comments-backwards true)
+ (local-set-variable! indent-line-procedure (ref-command pascal-indent-line))
+ (local-set-variable! comment-column 32)
+ (local-set-variable! comment-locator-hook pascal-comment-locate)
+ (local-set-variable! comment-indent-hook pascal-comment-indentation)
+ (local-set-variable! comment-start "(* ")
+ (local-set-variable! comment-end " *)")
+ (local-set-variable! paragraph-start "^$")
+ (local-set-variable! paragraph-separate (ref-variable "Paragraph Start"))
+ (local-set-variable! delete-indentation-right-protected (char-set #\( #\[))
+ (local-set-variable! delete-indentation-left-protected (char-set #\) #\]))
+ (if (ref-variable pascal-mode-hook) ((ref-variable pascal-mode-hook))))
(define pascal-mode:syntax-table (make-syntax-table))
(modify-syntax-entry! pascal-mode:syntax-table #\( "()1 ")
(if (line-start? start)
(indentation-of-previous-non-blank-line mark)
(max (1+ (mark-column start))
- (ref-variable "Comment Column")))))
+ (ref-variable comment-column)))))
-(define-key "Pascal" #\C-\( "^R Pascal Shift Left")
-(define-key "Pascal" #\C-\) "^R Pascal Shift Right")
-(define-key "Pascal" #\Rubout "^R Backward Delete Hacking Tabs")
+(define-key 'pascal #\c-\( 'pascal-shift-left)
+(define-key 'pascal #\c-\) 'pascal-shift-right)
+(define-key 'pascal #\rubout 'backward-delete-char-untabify)
+(define-key 'pascal #\tab 'pascal-indent-line)
\f
-(define-command ("^R Pascal Indent")
+(define-command pascal-indent-line
"Indents the current line for Pascal code."
- (let ((point (current-point)))
- (let ((indentation (calculate-pascal-indentation point)))
- (cond ((not (= indentation (current-indentation point)))
- (change-indentation indentation point))
- ((line-start? (horizontal-space-start point))
- (set-current-point! (horizontal-space-end point)))))))
+ ()
+ (lambda ()
+ (let ((point (current-point)))
+ (let ((indentation (calculate-pascal-indentation point)))
+ (cond ((not (= indentation (current-indentation point)))
+ (change-indentation indentation point))
+ ((line-start? (horizontal-space-start point))
+ (set-current-point! (horizontal-space-end point))))))))
-(define-command ("^R Pascal Shift Right" (argument 1))
+(define-command pascal-shift-right
"Shift the current line right by Pascal Shift Increment.
With an argument, shifts right that many times."
- (if (not (zero? argument))
- (let ((mark (line-start (current-point) 0)))
- (change-indentation (+ (current-indentation mark)
- (* argument
- (ref-variable "Pascal Shift Increment")))
- mark))))
+ "p"
+ (lambda (argument)
+ (if (not (zero? argument))
+ (let ((mark (line-start (current-point) 0)))
+ (change-indentation (+ (current-indentation mark)
+ (* argument
+ (ref-variable pascal-shift-increment)))
+ mark)))))
-(define-command ("^R Pascal Shift Left" (argument 1))
+(define-command pascal-shift-left
"Shift the current line left by Pascal Shift Increment.
With an argument, shifts left that many times."
- (if (not (zero? argument))
- (let ((mark (line-start (current-point) 0)))
- (change-indentation (- (current-indentation mark)
- (* argument
- (ref-variable "Pascal Shift Increment")))
- mark))))
+ "p"
+ (lambda (argument)
+ (if (not (zero? argument))
+ (let ((mark (line-start (current-point) 0)))
+ (change-indentation (- (current-indentation mark)
+ (* argument
+ (ref-variable pascal-shift-increment)))
+ mark)))))
\f
(define (calculate-pascal-indentation mark)
(let ((def-start
0
(let ((start (horizontal-space-end start)))
(let ((indentation (mark-column start)))
- (if (and (ref-variable "Pascal Indentation Keywords")
+ (if (and (ref-variable pascal-indentation-keywords)
(re-match-forward
- (ref-variable "Pascal Indentation Keywords")
+ (ref-variable pascal-indentation-keywords)
start))
(+ indentation
- (ref-variable "Pascal Shift Increment"))
+ (ref-variable pascal-shift-increment))
indentation))))))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/prompt.scm,v 1.130 1989/03/14 08:01:48 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/prompt.scm,v 1.131 1989/04/15 00:51:58 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define-variable "Enable Recursive Minibuffers"
+(define-variable enable-recursive-minibuffers
"If true, allow minibuffers to invoke commands which use
recursive minibuffers."
false)
+(define-variable completion-auto-help
+ "*True means automatically provide help for invalid completion input."
+ true)
+
(define typein-edit-abort-flag "Abort")
(define typein-edit-continuation)
(define typein-edit-depth)
(define typein-saved-buffers)
(define typein-saved-window)
+(define map-name/internal->external)
+(define map-name/external->internal)
(define (initialize-typein!)
(set! typein-edit-continuation false)
(set! typein-edit-depth -1)
(set! typein-saved-buffers '())
(set! typein-saved-window)
+ (set! map-name/internal->external identity-procedure)
+ (set! map-name/external->internal identity-procedure)
unspecific)
(define (within-typein-edit thunk)
- (if (and (not (ref-variable "Enable Recursive Minibuffers"))
- (typein-window? (current-window)))
- (editor-error "Command attempted to use minibuffer while in minibuffer"))
(let ((value
(call-with-current-continuation
(lambda (continuation)
(define-integrable (within-typein-edit?)
(not (false? typein-edit-continuation)))
\f
-;;; The following are used by MESSAGE and friends.
-
-(define (set-message! message)
- (let ((window (typein-window)))
- (window-set-override-message! window message)
- (window-direct-update! window true)))
-
-(define (clear-message!)
- (let ((window (typein-window)))
- (window-clear-override-message! window)
- (window-direct-update! window true)))
-
-(define (update-typein!)
- (window-direct-update! (typein-window) false))
-
-(define (prompt-for-typein prompt-string thunk)
+(define (prompt-for-typein prompt-string check-recursion? thunk)
+ (if (and check-recursion?
+ (not (ref-variable enable-recursive-minibuffers))
+ (typein-window? (current-window)))
+ (editor-error "Command attempted to use minibuffer while in minibuffer"))
(within-typein-edit
(lambda ()
(insert-string prompt-string)
(typein-edit-continuation (buffer-string (window-buffer window)))))
(define-integrable (typein-string)
- (buffer-string (current-buffer)))
+ (map-name/external->internal (buffer-string (current-buffer))))
(define (set-typein-string! string #!optional update?)
(let ((dont-update?
(or (not (or (default-object? update?) update?))
(window-needs-redisplay? (typein-window)))))
(region-delete! (buffer-region (current-buffer)))
- (insert-string string)
+ (insert-string (map-name/internal->external string))
(if (not dont-update?) (update-typein!))))
+\f
+;;; The following are used by MESSAGE and friends.
-(define (set-typein-substring! string start end #!optional update?)
- (let ((dont-update?
- (or (not (or (default-object? update?) update?))
- (window-needs-redisplay? (typein-window)))))
- (region-delete! (buffer-region (current-buffer)))
- (insert-substring string start end)
- (if (not dont-update?) (update-typein!))))
+(define (set-message! message)
+ (let ((window (typein-window)))
+ (window-set-override-message! window message)
+ (window-direct-update! window true)))
+
+(define (clear-message!)
+ (let ((window (typein-window)))
+ (window-clear-override-message! window)
+ (window-direct-update! window true)))
+
+(define (update-typein!)
+ (window-direct-update! (typein-window) false))
+(define (temporary-typein-message string)
+ (let ((point) (start) (end))
+ (dynamic-wind (lambda ()
+ (set! point (current-point))
+ (set! end (buffer-end (current-buffer)))
+ (set! start (mark-right-inserting end))
+ (insert-string string start)
+ (set-current-point! start))
+ (lambda ()
+ (sit-for 2000))
+ (lambda ()
+ (delete-string start end)
+ (set-current-point! point)
+ (set! point)
+ (set! start)
+ (set! end)
+ unspecific))))
\f
;;;; String Prompt
(define *default-string*)
(define *default-type*)
-(define *completion-string-table*)
-(define *completion-type*)
-(define *pop-up-window*)
+(define completion-procedure/complete-string)
+(define completion-procedure/list-completions)
+(define completion-procedure/verify-final-value?)
+(define *completion-confirm?*)
+
+(define (prompt-for-string prompt default-string #!optional default-type mode)
+ (fluid-let ((*default-string* default-string)
+ (*default-type*
+ (if (default-object? default-type)
+ 'VISIBLE-DEFAULT
+ default-type)))
+ (%prompt-for-string prompt
+ (if (default-object? mode)
+ (ref-mode-object minibuffer-local)
+ mode))))
(define (prompt-for-completed-string prompt
default-string
default-type
- completion-string-table
- completion-type
- #!optional mode)
+ complete-string
+ list-completions
+ verify-final-value?
+ require-match?)
(fluid-let ((*default-string* default-string)
(*default-type* default-type)
- (*completion-string-table* completion-string-table)
- (*completion-type* completion-type)
- (*pop-up-window* false))
- (dynamic-wind
- (lambda () unspecific)
+ (completion-procedure/complete-string complete-string)
+ (completion-procedure/list-completions list-completions)
+ (completion-procedure/verify-final-value? verify-final-value?)
+ (*completion-confirm?* (not (eq? require-match? true))))
+ (cleanup-pop-up-buffers
(lambda ()
- (prompt-for-typein
- (string-append
- prompt
- (if (or (memq default-type
- '(NO-DEFAULT NULL-DEFAULT
- INVISIBLE-DEFAULT
- INSERTED-DEFAULT))
- (not default-string))
- ""
- (string-append " (Default is: \"" default-string "\")"))
- ": ")
- (let ((thunk
- (typein-editor-thunk
- (if (default-object? mode) prompt-for-string-mode mode))))
- (if (eq? default-type 'INSERTED-DEFAULT)
- (begin
- (set! *default-string* false)
- (lambda ()
- (insert-string default-string)
- ((thunk))))
- thunk))))
- (lambda ()
- (if (and *pop-up-window* (window-visible? *pop-up-window*))
- (window-delete! *pop-up-window*)
- (let ((buffer (find-buffer " *Completions*")))
- (if buffer
- (let ((windows (buffer-windows buffer)))
- (if (not (null? windows))
- (let ((replacement (other-buffer buffer)))
- (for-each (lambda (window)
- (set-window-buffer! window
- replacement
- false))
- windows)
- (bury-buffer buffer)))))))))))
-
-(define (prompt-for-string prompt default-string #!optional default-type)
- (prompt-for-completed-string prompt
- default-string
- (if (default-object? default-type)
- 'VISIBLE-DEFAULT
- default-type)
- false
- 'NO-COMPLETION))
-
-(define (prompt-for-string-table-value prompt string-table)
+ (%prompt-for-string
+ prompt
+ (if require-match?
+ (ref-mode-object minibuffer-local-must-match)
+ (ref-mode-object minibuffer-local-completion)))))))
+
+(define (%prompt-for-string prompt mode)
+ (prompt-for-typein
+ (string-append
+ prompt
+ (if (and *default-string* (eq? *default-type* 'VISIBLE-DEFAULT))
+ (string-append " (default is: \"" *default-string* "\")")
+ "")
+ ": ")
+ true
+ (let ((thunk (typein-editor-thunk mode)))
+ (if (eq? *default-type* 'INSERTED-DEFAULT)
+ (let ((string *default-string*))
+ (set! *default-string* false)
+ (lambda ()
+ (insert-string string)
+ ((thunk))))
+ thunk))))
+\f
+(define (prompt-for-number prompt default)
+ (let ((string
+ (prompt-for-string prompt
+ (and default (number->string default)))))
+ (or (string->number string)
+ (editor-error "Input string not a number: \"" string "\""))))
+
+(define (prompt-for-string-table-name prompt
+ default-string
+ default-type
+ string-table
+ require-match?)
+ (prompt-for-completed-string
+ prompt
+ default-string
+ default-type
+ (lambda (string if-unique if-not-unique if-not-found)
+ (string-table-complete string-table
+ string
+ if-unique
+ if-not-unique
+ if-not-found))
+ (lambda (string)
+ (string-table-completions string-table string))
+ (lambda (string)
+ (string-table-get string-table string))
+ require-match?))
+
+(define (prompt-for-string-table-value prompt
+ default-string
+ default-type
+ string-table
+ require-match?)
(string-table-get string-table
- (prompt-for-completed-string prompt
- false
- 'NO-DEFAULT
- string-table
- 'STRICT-COMPLETION)))
+ (prompt-for-string-table-name prompt
+ default-string
+ default-type
+ string-table
+ require-match?)))
(define (prompt-for-alist-value prompt alist)
- (prompt-for-string-table-value prompt (alist->string-table alist)))
+ (fluid-let ((map-name/external->internal identity-procedure)
+ (map-name/internal->external identity-procedure))
+ (prompt-for-string-table-value prompt
+ false
+ 'NO-DEFAULT
+ (alist->string-table alist)
+ true)))
(define (prompt-for-command prompt)
- (prompt-for-string-table-value prompt editor-commands))
+ (fluid-let ((map-name/external->internal editor-name/external->internal)
+ (map-name/internal->external editor-name/internal->external))
+ (prompt-for-string-table-value prompt
+ false
+ 'NO-DEFAULT
+ editor-commands
+ true)))
(define (prompt-for-variable prompt)
- (prompt-for-string-table-value prompt editor-variables))
+ (fluid-let ((map-name/external->internal editor-name/external->internal)
+ (map-name/internal->external editor-name/internal->external))
+ (prompt-for-string-table-value prompt
+ false
+ 'NO-DEFAULT
+ editor-variables
+ true)))
\f
-;;;; PROMPT-FOR-STRING Mode
+;;;; String Prompt Modes
-(define-major-mode "Prompt for String" "Fundamental"
+(define-major-mode minibuffer-local fundamental #f
"Major mode for editing solicited input strings.
-Depending on what is being solicited, either defaulting or completion
-may be available. The following commands are special to this mode:
-
-\\[^R Terminate Input] terminates the input.
-\\[^R Yank Default String] yanks the default string, if there is one.
-\\[^R Complete Input] completes as much of the input as possible.
-\\[^R Complete Input Space] completes up to the next space.
-\\[^R List Completions] displays possible completions of the input.")
-
-(define-key "Prompt for String" #\Return "^R Terminate Input")
-(define-key "Prompt for String" #\C-M-Y "^R Yank Default String")
-(define-key "Prompt for String" #\Tab "^R Complete Input")
-(define-key "Prompt for String" #\Space "^R Complete Input Space")
-(define-key "Prompt for String" #\? "^R List Completions")
-
-(define-command ("^R Yank Default String")
- "Insert the default string at point."
- (if *default-string*
- (insert-string *default-string*)
- (editor-failure)))
-
-(define-command ("^R Complete Input")
- "Attempt to complete the current input string."
- (cond ((not *completion-string-table*)
- ;; Effectively, this means do what would be done if this
- ;; command was not defined by this mode.
- (dispatch-on-command (comtab-entry (cdr (current-comtabs))
- (current-command-char))))
- ((not (complete-input-string *completion-string-table* true))
- (editor-failure))))
-
-(define-command ("^R Complete Input Space")
- "Attempt to complete the input string, up to the next space."
- (cond ((not *completion-string-table*)
- (dispatch-on-command (comtab-entry (cdr (current-comtabs))
- (current-command-char))))
- ((not (complete-input-string-to-char *completion-string-table*
- #\Space))
- (editor-failure))))
-\f
-(define-command ("^R List Completions")
- "List the possible completions for the given input."
- (if *completion-string-table*
- (list-completions
- (string-table-completions *completion-string-table* (typein-string)))
- (^r-insert-self-command)))
-
-(define (list-completions strings)
- (let ((window
- (with-output-to-temporary-buffer " *Completions*"
- (lambda ()
- (if (null? strings)
- (write-string
- "There are no valid completions for this input.")
- (begin
- (write-string "Possible completions:")
- (newline)
- (write-strings-densely strings)))))))
- (if (not *pop-up-window*)
- (set! *pop-up-window* window)))
- unspecific)
+The following commands are special to this mode:
+
+\\[exit-minibuffer] terminates the input.
+\\[minibuffer-yank-default] yanks the default string, if there is one.")
-(define-command ("^R Terminate Input")
- "Terminate the input string.
-If defaulting is in effect, and there is no input, use the default.
-If completion is in effect, then:
- If completion is cautious, return only if the input is completed.
- If completion is strict, don't return unless the input completes."
- (let ((string (typein-string)))
- (cond ((string-null? string)
- (cond ((eq? *default-type* 'NULL-DEFAULT)
- (exit-typein-edit))
- ((or (eq? *default-type* 'NO-DEFAULT)
- (not *default-string*))
- (if (and (eq? *completion-type* 'STRICT-COMPLETION)
- (complete-input-string *completion-string-table*
- false))
- (exit-typein-edit)
- (begin
- (update-typein!)
- (editor-failure))))
- (else
- (set-typein-string! *default-string* false)
- (exit-typein-edit))))
- ((eq? *completion-type* 'CAUTIOUS-COMPLETION)
- (if (string-table-get *completion-string-table* string)
- (exit-typein-edit)
- (editor-failure)))
- ((eq? *completion-type* 'STRICT-COMPLETION)
- (if (complete-input-string *completion-string-table* false)
- (exit-typein-edit)
- (begin
- (update-typein!)
- (editor-failure))))
+(define-key 'minibuffer-local #\return 'exit-minibuffer)
+(define-key 'minibuffer-local #\linefeed 'exit-minibuffer)
+(define-key 'minibuffer-local #\c-m-y 'minibuffer-yank-default)
+
+(define-major-mode minibuffer-local-completion fundamental #f
+ "Major mode for editing solicited input strings.
+The following commands are special to this mode:
+
+\\[exit-minibuffer] terminates the input.
+\\[minibuffer-yank-default] yanks the default string, if there is one.
+\\[minibuffer-complete] completes as much of the input as possible.
+\\[minibuffer-complete-word] completes up to the next space.
+\\[minibuffer-completion-help] displays possible completions of the input.")
+
+(define-key 'minibuffer-local-completion #\return 'exit-minibuffer)
+(define-key 'minibuffer-local-completion #\linefeed 'exit-minibuffer)
+(define-key 'minibuffer-local-completion #\c-m-y 'minibuffer-yank-default)
+(define-key 'minibuffer-local-completion #\tab 'minibuffer-complete)
+(define-key 'minibuffer-local-completion #\space 'minibuffer-complete-word)
+(define-key 'minibuffer-local-completion #\? 'minibuffer-completion-help)
+
+(define-major-mode minibuffer-local-must-match fundamental #f
+ "Major mode for editing solicited input strings.
+The following commands are special to this mode:
+
+\\[minibuffer-complete-and-exit] terminates the input.
+\\[minibuffer-yank-default] yanks the default string, if there is one.
+\\[minibuffer-complete] completes as much of the input as possible.
+\\[minibuffer-complete-word] completes up to the next space.
+\\[minibuffer-completion-help] displays possible completions of the input.")
+
+(define-key 'minibuffer-local-must-match #\return
+ 'minibuffer-complete-and-exit)
+(define-key 'minibuffer-local-must-match #\linefeed
+ 'minibuffer-complete-and-exit)
+(define-key 'minibuffer-local-must-match #\c-m-y 'minibuffer-yank-default)
+(define-key 'minibuffer-local-must-match #\tab 'minibuffer-complete)
+(define-key 'minibuffer-local-must-match #\space 'minibuffer-complete-word)
+(define-key 'minibuffer-local-must-match #\? 'minibuffer-completion-help)
+
+(define-command exit-minibuffer
+ "Terminate this minibuffer argument."
+ ()
+ (lambda ()
+ (cond ((or (not (string-null? (typein-string)))
+ (memq *default-type* '(NULL-DEFAULT INSERTED-DEFAULT)))
+ (exit-typein-edit))
+ ((or (not *default-string*)
+ (eq? *default-type* 'NO-DEFAULT))
+ (editor-failure))
(else
+ (if (and (memq *default-type* '(INVISIBLE-DEFAULT VISIBLE-DEFAULT))
+ *default-string*)
+ (set-typein-string! *default-string* false))
(exit-typein-edit)))))
+
+(define-command minibuffer-yank-default
+ "Insert the default string at point."
+ ()
+ (lambda ()
+ (if *default-string*
+ (insert-string *default-string*)
+ (editor-failure))))
\f
-;;;; Completion Primitives
+(define-command minibuffer-complete
+ "Complete the minibuffer contents as far as possible."
+ ()
+ (lambda ()
+ (case (complete-input-string completion-procedure/complete-string true)
+ ((WAS-ALREADY-EXACT-AND-UNIQUE-COMPLETION)
+ (temporary-typein-message " [Sole completion]"))
+ ((WAS-ALREADY-EXACT-COMPLETION)
+ (temporary-typein-message " [Complete, but not unique]")))))
+
+(define-command minibuffer-complete-word
+ "Complete the minibuffer contents at most a single word."
+ ()
+ (lambda ()
+ (case (complete-input-string completion-procedure/complete-word true)
+ ((WAS-ALREADY-EXACT-AND-UNIQUE-COMPLETION)
+ (temporary-typein-message " [Sole completion]"))
+ ((WAS-ALREADY-EXACT-COMPLETION)
+ (temporary-typein-message " [Complete, but not unique]")))))
+
+(define-command minibuffer-completion-help
+ "Display a list of possible completions of the current minibuffer contents."
+ ()
+ (lambda ()
+ (minibuffer-completion-help
+ (lambda ()
+ (completion-procedure/list-completions (typein-string))))))
-(define (complete-input-string string-table update?)
- (string-table-complete string-table (typein-string)
- (lambda (string) (set-typein-string! string update?))
- (lambda (string limit) (set-typein-substring! string 0 limit update?))
- (lambda () unspecific))
- (string-table-get string-table (typein-string)))
+(define (minibuffer-completion-help list-completions)
+ (let ((window (typein-window)))
+ (window-set-override-message! window "Making completion list...")
+ (window-direct-update! window true)
+ (let ((completions (list-completions)))
+ (window-clear-override-message! window)
+ (if (null? completions)
+ (begin
+ (editor-beep)
+ (temporary-typein-message " [No completions]"))
+ (write-completions-list
+ (map map-name/internal->external completions))))))
+
+(define-command minibuffer-complete-and-exit
+ "Complete the minibuffer contents, and maybe exit.
+Exit if the name is valid with no completion needed.
+If name was completed to a valid match,
+a repetition of this command will exit."
+ ()
+ (lambda ()
+ (let ((string (typein-string)))
+ (if (and (string-null? string)
+ (memq *default-type* '(INVISIBLE-DEFAULT VISIBLE-DEFAULT))
+ *default-string*)
+ (set-typein-string! *default-string* false))
+ (case (complete-input-string completion-procedure/complete-string false)
+ ((WAS-ALREADY-EXACT-AND-UNIQUE-COMPLETION
+ WAS-ALREADY-EXACT-COMPLETION)
+ (exit-typein-edit))
+ ((COMPLETED-TO-EXACT-AND-UNIQUE-COMPLETION
+ COMPLETED-TO-EXACT-COMPLETION)
+ (if *completion-confirm?*
+ (temporary-typein-message " [Confirm]")
+ (exit-typein-edit)))
+ (else
+ (update-typein!)
+ (editor-failure))))))
+\f
+;;;; Completion Primitives
-(define (complete-input-string-to-char string-table char)
+(define (complete-input-string complete-string update?)
(let ((original (typein-string)))
- (string-table-complete-to-char string-table original char
- (lambda (string limit)
- (if (> limit (string-length original))
- (set-typein-substring! string 0 limit))
- true)
- (lambda (string limit)
- (and (> limit (string-length original))
- (begin
- (set-typein-substring! string 0 limit)
- true)))
- (lambda () false))))
-
-(define (string-table-complete-to-char string-table string char if-unambiguous
- if-ambiguous if-not-found)
- (string-table-complete string-table string
- (lambda (new-string)
- (if-unambiguous
- new-string
- (let ((end (string-length new-string)))
- (let ((index
- (substring-find-next-char new-string (string-length string)
- end char)))
- (if index
- (1+ index)
- end)))))
- (lambda (new-string limit)
- (let ((index (substring-find-next-char new-string (string-length string)
- limit char)))
- (if index
- (if-unambiguous new-string (1+ index))
- (let ((string (string-append-char string char)))
- (string-table-complete string-table string
- (lambda (new-string)
- (if-unambiguous new-string (string-length string)))
- (lambda (new-string limit)
- limit ;ignore
- (if-ambiguous new-string (string-length string)))
- (lambda ()
- (if-ambiguous new-string limit)))))))
- if-not-found))
+ (complete-string original
+ (lambda (string)
+ (if (not (string=? string original))
+ (set-typein-string! string update?))
+ (if (string-ci=? string original)
+ 'WAS-ALREADY-EXACT-AND-UNIQUE-COMPLETION
+ 'COMPLETED-TO-EXACT-AND-UNIQUE-COMPLETION))
+ (lambda (string list-completions)
+ (if (not (string=? string original))
+ (set-typein-string! string update?))
+ (if (completion-procedure/verify-final-value? string)
+ (if (string-ci=? string original)
+ 'WAS-ALREADY-EXACT-COMPLETION
+ 'COMPLETED-TO-EXACT-COMPLETION)
+ (if (string-ci=? string original)
+ (begin
+ (if (ref-variable completion-auto-help)
+ (minibuffer-completion-help list-completions)
+ (temporary-typein-message " [Next char not unique]"))
+ 'NO-COMPLETION-HAPPENED)
+ 'SOME-COMPLETION-HAPPENED)))
+ (lambda ()
+ (editor-beep)
+ (temporary-typein-message " [No match]")
+ 'NO-MATCH))))
+
+(define (write-completions-list strings)
+ (with-output-to-temporary-buffer " *Completions*"
+ (lambda ()
+ (if (null? strings)
+ (write-string
+ "There are no possible completions of what you have typed.")
+ (begin
+ (write-string "Possible completions are:\n")
+ (write-strings-densely (sort strings string<?)))))))
+\f
+(define (completion-procedure/complete-word string
+ if-unique
+ if-not-unique
+ if-not-found)
+ (let ((truncate-string
+ (lambda (new-string)
+ (let ((end (string-length new-string)))
+ (let ((index
+ (substring-find-next-char-not-of-syntax
+ new-string
+ (string-length string)
+ end
+ #\w))) (if index
+ (substring new-string 0 (1+ index))
+ new-string))))))
+ (let ((if-unique
+ (lambda (new-string)
+ (if-unique (truncate-string new-string))))
+ (if-not-unique
+ (lambda (new-string list-completions)
+ (if-not-unique (truncate-string new-string) list-completions))))
+ (completion-procedure/complete-string string
+ if-unique
+ (lambda (new-string list-completions)
+ (if (= (string-length new-string) (string-length string))
+ (let ((completions (list-completions)))
+ (let ((try-suffix
+ (lambda (suffix if-not-found)
+ (let ((completions
+ (list-transform-positive completions
+ (let ((prefix (string-append string suffix)))
+ (lambda (completion)
+ (string-prefix? prefix completion))))))
+ (cond ((null? completions)
+ (if-not-found))
+ ((null? (cdr completions))
+ (if-unique (car completions)))
+ (else
+ (if-not-unique
+ (string-greatest-common-prefix completions)
+ (lambda () completions))))))))
+ (try-suffix "-"
+ (lambda ()
+ (try-suffix " "
+ (lambda ()
+ (if-not-unique string (lambda () completions))))))))
+ (if-not-unique new-string list-completions)))
+ if-not-found))))
\f
;;;; Character Prompts
(define (prompt-for-char prompt)
- (set-command-prompt! (string-append prompt ": "))
- (let ((char (keyboard-read-char)))
- (set-command-prompt! (string-append (command-prompt) (char-name char)))
- char))
-
-(define (prompt-for-char-without-interrupts prompt)
- (with-editor-interrupts-disabled (lambda () (prompt-for-char prompt))))
+ (with-editor-interrupts-disabled
+ (lambda ()
+ (prompt-for-typein (string-append prompt ": ") false
+ (lambda ()
+ (let ((char (keyboard-read-char)))
+ (set-typein-string! (char-name char))
+ char))))))
(define (prompt-for-key prompt #!optional comtab)
- (let ((comtab (if (default-object? comtab) (current-comtabs) comtab))
- (string (string-append prompt ": ")))
- (set-command-prompt! string)
- (let outer-loop ((prefix '()))
- (let inner-loop ((char (keyboard-read-char)))
- (let ((chars (append! prefix (list char))))
- (set-command-prompt! (string-append string (xchar->name chars)))
- (if (prefix-char-list? comtab chars)
- (outer-loop chars)
- (let ((command (comtab-entry comtab chars)))
- (if (memq command extension-commands)
- (inner-loop (fluid-let ((execute-extended-chars? false))
- (dispatch-on-command command)))
- chars))))))))
+ (let ((comtab (if (default-object? comtab) (current-comtabs) comtab)))
+ (prompt-for-typein (string-append prompt ": ") false
+ (lambda ()
+ (with-editor-interrupts-disabled
+ (lambda ()
+ (let outer-loop ((prefix '()))
+ (let inner-loop ((char (keyboard-read-char)))
+ (let ((chars (append! prefix (list char))))
+ (set-typein-string! (xchar->name chars))
+ (if (prefix-char-list? comtab chars)
+ (outer-loop chars)
+ (let ((command (comtab-entry comtab chars)))
+ (if (memq command extension-commands)
+ (inner-loop
+ (fluid-let ((execute-extended-chars? false))
+ (dispatch-on-command command)))
+ chars))))))))))))
;;;; Confirmation Prompts
(define (prompt-for-confirmation? prompt)
- (set-command-prompt! (string-append prompt " (y or n)? "))
- (let loop ()
- (let ((char (char-upcase (keyboard-read-char))))
- (cond ((or (char=? char #\Y)
- (char=? char #\Space))
- (set-command-prompt! (string-append (command-prompt) "Yes"))
- (sit-for 500)
- true)
- ((or (char=? char #\N)
- (char=? char #\Rubout))
- (set-command-prompt! (string-append (command-prompt) "No"))
- (sit-for 500)
- false)
- (else
- (editor-failure)
- (loop))))))
+ (prompt-for-typein (string-append prompt " (y or n)? ") false
+ (lambda ()
+ (let loop ()
+ (let ((char (char-upcase (keyboard-read-char))))
+ (cond ((or (char=? char #\Y)
+ (char=? char #\Space))
+ (set-typein-string! "Yes")
+ true)
+ ((or (char=? char #\N)
+ (char=? char #\Rubout))
+ (set-typein-string! "No")
+ false)
+ (else
+ (editor-failure)
+ (loop))))))))
(define (prompt-for-yes-or-no? prompt)
(string-ci=?
"Yes"
- (prompt-for-typein (string-append prompt " (yes or no)? ")
- (typein-editor-thunk prompt-for-yes-or-no-mode))))
-
-(define-major-mode "Prompt for Yes or No" "Fundamental"
- "Enter either ``Yes'' or ``No''.")
-
-(define-key "Prompt for Yes or No" #\Return "^R Terminate Yes or No")
-
-(define-command ("^R Terminate Yes or No")
- "Like ^R Terminate Input, but insists on ``Yes'' or ``No'' as an answer."
- (let ((string (typein-string)))
- (if (or (string-ci=? "Yes" string)
- (string-ci=? "No" string))
- (exit-typein-edit)
- (editor-error "Please enter ``Yes'' or ``No''"))))
\ No newline at end of file
+ (prompt-for-typein (string-append prompt " (yes or no)? ") true
+ (typein-editor-thunk (ref-mode-object minibuffer-local-yes-or-no)))))
+
+(define-major-mode minibuffer-local-yes-or-no fundamental #f
+ "Enter either \"Yes\" or \"No\".")
+
+(define-key 'minibuffer-local-yes-or-no #\return 'exit-minibuffer-yes-or-no)
+
+(define-command exit-minibuffer-yes-or-no
+ "Like \\[exit-minibuffer], but insists on \"Yes\" or \"No\" as an answer."
+ ()
+ (lambda ()
+ (let ((string (typein-string)))
+ (if (or (string-ci=? "yes" string)
+ (string-ci=? "no" string))
+ (exit-typein-edit)
+ (editor-error "Please enter \"Yes\" or \"No\"")))))
+\f
+;;;; Command History Prompt
+
+(define-command repeat-complex-command
+ "Edit and re-evaluate last complex command, or ARGth from last.
+A complex command is one which used the minibuffer.
+The command is placed in the minibuffer as a Scheme form for editing.
+The result is executed, repeating the command as changed.
+If the command has been changed or is not the most recent previous command
+it is added to the front of the command history.
+Whilst editing the command, the following commands are available:
+\\{repeat-complex-command}"
+ "p"
+ (lambda (argument)
+ (fluid-let ((*command-history* (command-history-list))
+ (*command-history-index* argument))
+ (if (not (< 0 argument (length *command-history*)))
+ (editor-error "argument out of range: " argument))
+ (execute-command-history-entry
+ (read-from-string
+ (prompt-for-string "Redo"
+ (write-to-string
+ (list-ref *command-history* (-1+ argument)))
+ 'INSERTED-DEFAULT
+ (ref-mode-object repeat-complex-command)))))))
+
+(define *command-history*)
+(define *command-history-index*)
+
+(define-major-mode repeat-complex-command minibuffer-local #f
+ "Major mode for editing command history.")
+
+(define-key 'repeat-complex-command #\M-n 'next-complex-command)
+(define-key 'repeat-complex-command #\M-p 'previous-complex-command)
+
+(define-command next-complex-command
+ "Inserts the next element of `command-history' into the minibuffer."
+ "p"
+ (lambda (argument)
+ (let ((index
+ (min (max 1 (- *command-history-index* argument))
+ (length *command-history*))))
+ (if (and (not (zero? argument))
+ (= index *command-history-index*))
+ (editor-error (if (= index 1)
+ "No following item in command history"
+ "No preceeding item in command history")))
+ (set! *command-history-index* index)
+ (set-typein-string!
+ (write-to-string (list-ref *command-history* (-1+ index)))) (set-current-point! (buffer-start (current-buffer))))))
+
+(define-command previous-complex-command
+ "Inserts the next element of `command-history' into the minibuffer."
+ "p"
+ (lambda (argument)
+ ((ref-command next-complex-command) (- argument))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/reccom.scm,v 1.10 1989/03/14 08:01:58 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/reccom.scm,v 1.11 1989/04/15 00:52:11 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(iter (line-start perm-mark 1) (append ring-list (list line$)))))))
(iter first (list spacenum)))))
-(define-command ("Kill Rectangle")
+(define-command kill-rectangle
"Delete rectangle with corners at point and mark; save as last killed one."
- (set-cdr! rectangle-ring (delete-rectangle (current-mark) (current-point))))
+ ()
+ (lambda ()
+ (set-cdr! rectangle-ring (delete-rectangle (current-mark) (current-point)))))
-(define-command ("Delete Rectangle")
+(define-command delete-rectangle
"Delete (don't save) text in rectangle with point and mark as corners.
The same range of columns is deleted in each line
starting with the line where the region begins
and ending with the line where the region ends."
- (delete-rectangle (current-mark) (current-point)))
+ ()
+ (lambda ()
+ (delete-rectangle (current-mark) (current-point))))
-(define-command ("Open Rectangle")
+(define-command open-rectangle
"Blank out rectangle with corners at point and mark, shifting text right.
The text previously in the region is not overwritten by the blanks,
but instead winds up to the right of the rectangle."
- (delete-rectangle (current-mark) (current-point) true true))
+ ()
+ (lambda ()
+ (delete-rectangle (current-mark) (current-point) true true)))
-(define-command ("Clear Rectangle")
+(define-command clear-rectangle
"Blank out rectangle with corners at point and mark.
The text previously in the region is overwritten by the blanks."
- (delete-rectangle (current-mark) (current-point) true))
+ ()
+ (lambda ()
+ (delete-rectangle (current-mark) (current-point) true)))
(define (make-space-to-column column mark) ;new make-space-to-column
(mark-permanent! mark)
(cdr insert$)))))
(iter (line-end point 0) point (cddr rectangle))))))
-(define-command ("Yank Rectangle")
+(define-command yank-rectangle
"Yank the last killed rectangle with upper left corner at point."
- (yank-rectangle rectangle-ring (current-point)))
\ No newline at end of file
+ ()
+ (lambda ()
+ (yank-rectangle rectangle-ring (current-point))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/regcom.scm,v 1.15 1989/03/14 08:02:00 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/regcom.scm,v 1.16 1989/04/15 00:52:16 cph Exp $
;;;
;;; Copyright (c) 1987, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define-command ("Point to Register")
+(define-command point-to-register
"Store current location of point in a register."
- (set-register! (prompt-for-char "Point to Register")
- (make-buffer-position (current-point) (current-buffer))))
+ "cPoint to register"
+ (lambda (register)
+ (set-register! register
+ (make-buffer-position (current-point) (current-buffer)))))
-(define-command ("Register to Point")
+(define-command register-to-point
"Move point to location stored in a register."
- (let ((register (prompt-for-char "Register to Point")))
+ "cRegister to Point"
+ (lambda (register)
(let ((value (get-register register)))
(if (not (buffer-position? value))
(register-error register "does not contain a buffer position."))
"points to a buffer which has been deleted")))
(set-current-point! (buffer-position-mark value)))))
-(define-command ("Number to Register" argument)
+(define-command number-to-register
"Store a number in a given register.
With prefix arg, stores that number in the register.
Otherwise, reads digits from the buffer starting at point."
- (set-register! (prompt-for-char "Number to Register")
- (or argument
- (let ((start (current-point))
- (end (skip-chars-forward "[0-9]")))
- (if (mark= start end)
- 0
- (with-input-from-region (make-region start end)
- read))))))
-
-(define-command ("Increment Register" (argument 1))
+ "cNumber to Register\nP"
+ (lambda (register argument)
+ (set-register! register
+ (or argument
+ (let ((start (current-point))
+ (end (skip-chars-forward "[0-9]")))
+ (if (mark= start end)
+ 0
+ (with-input-from-region (make-region start end)
+ read)))))))
+
+(define-command increment-register
"Add the prefix arg to the contents of a given register.
The prefix defaults to one."
- (let ((register (prompt-for-char "Increment Register")))
+ "cIncrement register\np"
+ (lambda (register argument)
(let ((value (get-register register)))
(if (not (integer? value))
(register-error register "does not contain a number"))
(set-register! register (+ value argument)))))
-(define-command ("Copy to Register" argument)
+(define-command copy-to-register
"Copy region into given register.
With prefix arg, delete as well."
- (let ((region (current-region)))
- (set-register! (prompt-for-char "Copy to Register")
- (region->string region))
- (if argument (region-delete! region))))
+ "cCopy to register\nr\nP"
+ (lambda (register region delete?)
+ (set-register! register (region->string region))
+ (if delete? (region-delete! region))))
-(define-command ("Insert Register" argument)
+(define-command insert-register
"Insert contents of given register at point.
Normally puts point before and mark after the inserted text.
With prefix arg, puts mark before and point after."
- ((if argument unkill-reversed unkill)
- (let ((value (get-register (prompt-for-char "Insert Register"))))
- (cond ((string? value) value)
- ((integer? value) (write-to-string value))
- (else (register-error "does not contain text"))))))
+ "cInsert Register\nP"
+ (lambda (register argument)
+ ((if argument unkill-reversed unkill)
+ (let ((value (get-register register)))
+ (cond ((string? value) value)
+ ((integer? value) (write-to-string value))
+ (else (register-error "does not contain text")))))))
\f
-(define-command ("Append to Register" argument)
+(define-command append-to-register
"Append region to text in given register.
With prefix arg, delete as well."
- (let ((region (current-region))
- (register (prompt-for-char "Append to Register")))
+ "cAppend to register\nr\nP"
+ (lambda (register region argument)
(let ((value (get-register register)))
(if (not (string? value))
(register-error register "does not contain text"))
(set-register! register (string-append value (region->string region))))
(if argument (region-delete! region))))
-(define-command ("Prepend to Register" argument)
+(define-command prepend-to-register
"Prepend region to text in given register.
With prefix arg, delete as well."
- (let ((region (current-region))
- (register (prompt-for-char "Prepend to Register")))
+ "cPrepend to register\nr\nP"
+ (lambda (register region argument)
(let ((value (get-register register)))
(if (not (string? value))
(editor-error register "does not contain text"))
(set-register! register (string-append (region->string region) value)))
(if argument (region-delete! region))))
-(define-command ("View Register")
+(define-command view-register
"Display what is contained in a given register."
- (let ((register (prompt-for-char "View Register")))
+ "cView register"
+ (lambda (register)
(let ((value (get-register register)))
(if (not value)
(message "Register " (char-name register) " is empty")
(if (not buffer)
(write-string "an invalid buffer position")
(begin
- (write-string "a buffer position:\nbuffer ")
- (write-string (buffer-name buffer))
- (write-string ", position ")
- (write
- (mark-index (buffer-position-mark value)))))))
+ (write-string "a buffer position:\nbuffer ")
+ (write-string (buffer-name buffer))
+ (write-string ", position ")
+ (write
+ (mark-index (buffer-position-mark value)))))))
(else
(write-string "a random object:\n")
(write value)))))))))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/regexp.scm,v 1.46 1989/03/14 08:02:02 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/regexp.scm,v 1.47 1989/04/15 00:52:21 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(define (compile-pattern regexp)
;; Incredible hair here to prevent excessive consing.
- ((if (ref-variable "Case Fold Search") cdr car)
+ ((if (ref-variable case-fold-search) cdr car)
(cdr (or (assq regexp pattern-cache)
(let ((entry
(cons regexp
entry)))))
(define (compile-char char)
- (re-compile-char char (ref-variable "Case Fold Search")))
+ (re-compile-char char (ref-variable case-fold-search)))
(define (compile-string string)
- (re-compile-string string (ref-variable "Case Fold Search")))
+ (re-compile-string string (ref-variable case-fold-search)))
\f
;;;; Search
(%re-finish group
((ucode-primitive re-search-buffer-forward)
pattern
- (re-translation-table (ref-variable "Case Fold Search"))
- (syntax-table/entries (ref-variable "Syntax Table"))
+ (re-translation-table (ref-variable case-fold-search))
+ (syntax-table/entries (ref-variable syntax-table))
registers
group start end)))
(%re-finish group
((ucode-primitive re-search-buffer-backward)
pattern
- (re-translation-table (ref-variable "Case Fold Search"))
- (syntax-table/entries (ref-variable "Syntax Table"))
+ (re-translation-table (ref-variable case-fold-search))
+ (syntax-table/entries (ref-variable syntax-table))
registers
group end start)))
\f
(%re-finish group
((ucode-primitive re-match-buffer)
pattern
- (re-translation-table (ref-variable "Case Fold Search"))
- (syntax-table/entries (ref-variable "Syntax Table"))
+ (re-translation-table (ref-variable case-fold-search))
+ (syntax-table/entries (ref-variable syntax-table))
registers
group start end)))
\f
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/replaz.scm,v 1.63 1989/03/14 08:02:12 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/replaz.scm,v 1.64 1989/04/15 00:52:27 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define-variable "Replace String Search"
+(define-variable replace-string-search
"The last string that a replacement command searched for."
false)
-(define-variable "Replace String Replace"
+(define-variable replace-string-replace
"The last string that a replacement command replaced with."
false)
-(define-variable "Case Replace"
+(define-variable case-replace
"If not false, means replacement commands should preserve case."
true)
-(define-command ("Replace String" argument)
+(define (replace-string-arguments name)
+ (let ((source
+ (prompt-for-string name
+ (ref-variable replace-string-search)
+ 'NULL-DEFAULT)))
+ (let ((target
+ (prompt-for-string (string-append name " " source " with")
+ (ref-variable replace-string-replace)
+ 'NULL-DEFAULT)))
+ (set-variable! replace-string-search source)
+ (set-variable! replace-string-replace target)
+ (list source target (command-argument-standard-value)))))
+
+(define-command replace-string
"Replace occurrences of a given string with another one.
Preserve case in each match if Case Replace and Case Fold Search
are true and the given strings have no uppercase letters.
With an argument, replace only matches surrounded by word boundaries."
- (interactive-replace-string "Replace String" argument false))
+ (lambda () (replace-string-arguments "Replace string"))
+ (lambda (source target replace-words-only?)
+ ((replace-string 'replace-string replace-words-only? false true)
+ source target)))
-(define-command ("Query Replace" argument)
+(define-command query-replace
"Replace some occurrences of a given string with another one.
As each match is found, the user must type a character saying
what to do with it.
-Type C-H within Query Replace for directions.
+Type C-H within query-replace for directions.
Preserve case in each match if Case Replace and Case Fold Search
are true and the given strings have no uppercase letters.
With an argument, replace only matches surrounded by word boundaries."
- (interactive-replace-string "Query Replace" argument true))
-
-(define (interactive-replace-string name replace-words-only? query?)
- (replace-string-arguments name
- (replace-string name replace-words-only? query?
- true)))
-
-(define (replace-string-arguments name receiver)
- (let ((source
- (prompt-for-string name
- (ref-variable "Replace String Search")
- 'VISIBLE-DEFAULT)))
- (let ((target
- (prompt-for-string "Replace with"
- (ref-variable "Replace String Replace")
- 'NULL-DEFAULT)))
- (set-variable! "Replace String Search" source)
- (set-variable! "Replace String Replace" target)
- (receiver source target))))
+ (lambda () (replace-string-arguments "Query replace"))
+ (lambda (source target replace-words-only?)
+ ((replace-string 'query-replace replace-words-only? true true)
+ source target)))
\f
(define ((replace-string name replace-words-only? query? clear-on-exit?)
source target)
;; Returns TRUE iff the query loop was exited at the user's request,
;; FALSE iff the loop finished by failing to find an occurrence.
- (let ((preserve-case? (and (ref-variable "Case Replace")
- (ref-variable "Case Fold Search")
+ (let ((preserve-case? (and (ref-variable case-replace)
+ (ref-variable case-fold-search)
(string-lower-case? source)
(not (string-null? target))
(string-lower-case? target)))
(words-only-source
(delay (string-append "\\b" (re-quote-string source) "\\b")))
(message-string
- (string-append name ": " (write-to-string source)
+ (string-append (editor-name/internal->external (symbol->string name))
+ ": " (write-to-string source)
" => " (write-to-string target)))
- (old-notification (ref-variable "Auto Push Point Notification")))
+ (old-notification (ref-variable auto-push-point-notification)))
(define (find-next-occurrence start receiver)
(if (if replace-words-only?
end)))
(define (edit)
- (fluid-let (((ref-variable "Auto Push Point Notification")
- old-notification))
- (clear-message)
- (enter-recursive-edit)
- (set-message)))
-
- (define (set-message)
- (message message-string))
+ (with-variable-value! (ref-variable-object auto-push-point-notification)
+ old-notification
+ (lambda ()
+ (clear-message)
+ (enter-recursive-edit))))
\f
(define (perform-query start end replaced?)
- (let ((char (char-upcase (keyboard-read-char))))
- (cond ((char=? #\Space char)
- (if (not replaced?) (perform-replacement start end))
- (query-loop start end))
- ((char=? #\Rubout char)
- (query-loop start end))
- ((char=? #\Altmode char)
- (if clear-on-exit? (clear-message))
- true)
- ((char=? #\. char)
- (if (not replaced?) (perform-replacement start end))
- (if clear-on-exit? (clear-message))
- true)
- ((char=? #\, char)
- (if (not replaced?) (perform-replacement start end))
- (perform-query start end true))
- ((char=? #\C-R char)
- (edit)
- (perform-query start end replaced?))
- ((char=? #\C-W char)
- (if (not replaced?) (delete-string start end))
- (edit)
- (query-loop start end))
- ((char=? #\! char)
- (if (not replaced?) (perform-replacement start end))
- (replacement-loop end))
- ((char=? #\^ char)
- (set-current-point! (pop-current-mark!))
- (perform-query (current-mark) (current-mark) true))
- ((or (char=? #\C-H char) (char=? #\Backspace char))
- (with-output-to-help-display
- (lambda ()
- (write-string "Query replacing ")
- (write source)
- (write-string " with ")
- (write target)
- (write-string ".
+ (message message-string)
+ (let ((char (with-editor-interrupts-disabled keyboard-read-char)))
+ (let ((test-for
+ (lambda (char*)
+ (char=? char (remap-alias-char char*)))))
+ (cond ((test-for #\space)
+ (if (not replaced?) (perform-replacement start end))
+ (query-loop start end))
+ ((test-for #\rubout)
+ (query-loop start end))
+ ((test-for #\altmode)
+ (if clear-on-exit? (clear-message))
+ true)
+ ((test-for #\.)
+ (if (not replaced?) (perform-replacement start end))
+ (if clear-on-exit? (clear-message))
+ true)
+ ((test-for #\,)
+ (if (not replaced?) (perform-replacement start end))
+ (perform-query start end true))
+ ((test-for #\C-r)
+ (edit)
+ (perform-query start end replaced?))
+ ((test-for #\C-w)
+ (if (not replaced?) (delete-string start end))
+ (edit)
+ (query-loop start end))
+ ((test-for #\!)
+ (if (not replaced?) (perform-replacement start end))
+ (replacement-loop end))
+ ((test-for #\^)
+ (set-current-point! (pop-current-mark!))
+ (perform-query (current-mark) (current-mark) true))
+ ((test-for #\C-h)
+ (with-output-to-help-display
+ (lambda ()
+ (write-string "Query replacing ")
+ (write source)
+ (write-string " with ")
+ (write target)
+ (write-string ".
Type space to replace one match, Rubout to skip to next,
Altmode to exit, Period to replace one match and exit,
C-R to enter recursive edit, C-W to delete match and recursive edit,
! to replace all remaining matches with no more questions,
^ to move point back to previous match.")))
- (perform-query start end replaced?))
- (else
- (if clear-on-exit? (clear-message))
- (execute-char (current-comtabs) char)
- true))))
+ (perform-query start end replaced?))
+ (else
+ (if clear-on-exit? (clear-message))
+ (execute-char (current-comtabs) char)
+ true)))))
- (set-message)
(let ((point (current-point)))
(if query?
- (fluid-let (((ref-variable "Auto Push Point Notification") false))
- (query-loop point point))
+ (with-variable-value!
+ (ref-variable-object auto-push-point-notification)
+ false
+ (lambda ()
+ (query-loop point point)))
(replacement-loop point)))))
\f
;;;; Occurrence Commands
-(define-command ("Count Occurrences")
+(define-command count-matches
"Print the number of occurrences of a given regexp following point."
- (let ((regexp (prompt-for-string "Count Occurrences (regexp)" false)))
- (define (loop start n)
+ "sHow many matches for (regexp)"
+ (lambda (regexp)
+ (let loop ((start (current-point)) (n 0))
(let ((mark (re-search-forward regexp start)))
(if (not mark)
(message (write-to-string n) " occurrences")
- (loop mark (1+ n)))))
- (loop (current-point) 0)))
+ (loop mark (1+ n)))))))
-(define-command ("List Occurrences" (argument 0))
- "Show all lines containing a given regexp following point.
+(define-command list-matching-lines
+ "Show all lines following point containing a match for a given regexp.
The argument, if given, is the number of context lines to show
on either side of each line; this defaults to zero."
- (let ((regexp (prompt-for-string "List Occurrences (regexp)" false))
- (-arg (- argument))
- (1+arg (1+ argument)))
- (with-output-to-temporary-buffer "*Occur*"
- (lambda ()
- (define (loop start)
- (let ((mark (re-search-forward regexp start)))
- (if mark
- (begin (write-string (extract-string (line-start mark -arg)
- (line-start mark 1+arg)))
- (write-string "--------")
- (newline)
- (loop (line-start mark 1))))))
- (loop (current-point))))))
\ No newline at end of file
+ "sList matching lines (regexp)\nP"
+ (lambda (regexp argument)
+ (let ((argument (or argument 0)))
+ (let ((-arg (- argument))
+ (1+arg (1+ argument)))
+ (with-output-to-temporary-buffer "*Occur*"
+ (lambda ()
+ (define (loop start)
+ (let ((mark (re-search-forward regexp start)))
+ (if mark
+ (begin (write-string
+ (extract-string (line-start mark -arg)
+ (line-start mark 1+arg)))
+ (write-string "--------")
+ (newline)
+ (loop (line-start mark 1))))))
+ (loop (current-point))))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/schmod.scm,v 1.7 1989/03/14 08:02:40 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/schmod.scm,v 1.8 1989/04/15 00:52:46 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define-command ("Scheme Mode")
+(define-command scheme-mode
"Enter Scheme mode."
- (set-current-major-mode! scheme-mode))
+ ()
+ (lambda ()
+ (set-current-major-mode! (ref-mode-object scheme))))
-(define-major-mode "Scheme" "Fundamental"
+(define-major-mode scheme fundamental "Scheme"
"Major mode specialized for editing Scheme code.
-Tab indents the current line for Scheme.
-\\[^R Indent Sexp] indents the next s-expression.
+\\[lisp-indent-line] indents the current line for Scheme.
+\\[indent-sexp] indents the next s-expression.
-\\[^R Evaluate Previous Sexp into Buffer] evaluates the expression preceding point.
+\\[eval-previous-sexp-into-buffer] evaluates the expression preceding point.
All output is inserted into the buffer at point.
-\\[^R Evaluate Sexp Typein] reads and evaluates an expression in the typein window.
+\\[eval-expression] reads and evaluates an expression in the typein window.
The following evaluation commands keep a transcript of all output in
the buffer *Transcript*:
-\\[^R Evaluate Definition] evaluates the current definition.
-\\[^R Evaluate Buffer] evaluates the buffer.
-\\[^R Evaluate Sexp] evaluates the expression following point.
-\\[^R Evaluate Previous Sexp] evaluates the expression preceding point.
-\\[^R Evaluate Region] evaluates the current region."
-
- (local-set-variable! "Syntax Table" scheme-mode:syntax-table)
- (local-set-variable! "Syntax Ignore Comments Backwards" false)
- (local-set-variable! "Lisp Indent Hook" standard-lisp-indent-hook)
- (local-set-variable! "Lisp Indent Methods" scheme-mode:indent-methods)
- (local-set-variable! "Comment Column" 40)
- (local-set-variable! "Comment Locator Hook" lisp-comment-locate)
- (local-set-variable! "Comment Indent Hook" lisp-comment-indentation)
- (local-set-variable! "Comment Start" ";")
- (local-set-variable! "Comment End" "")
- (local-set-variable! "Paragraph Start" "^$")
- (local-set-variable! "Paragraph Separate" (ref-variable "Paragraph Start"))
- (local-set-variable! "Indent Line Procedure" ^r-indent-for-lisp-command)
- (if (ref-variable "Scheme Mode Hook") ((ref-variable "Scheme Mode Hook"))))
-
-(define-variable "Scheme Mode Hook"
+\\[eval-definition] evaluates the current definition.
+\\[eval-buffer] evaluates the buffer.
+\\[eval-next-sexp] evaluates the expression following point.
+\\[eval-previous-sexp] evaluates the expression preceding point.
+\\[eval-region] evaluates the current region."
+
+ (local-set-variable! syntax-table scheme-mode:syntax-table)
+ (local-set-variable! syntax-ignore-comments-backwards false)
+ (local-set-variable! lisp-indent-hook standard-lisp-indent-hook)
+ (local-set-variable! lisp-indent-methods scheme-mode:indent-methods)
+ (local-set-variable! comment-column 40)
+ (local-set-variable! comment-locator-hook lisp-comment-locate)
+ (local-set-variable! comment-indent-hook lisp-comment-indentation)
+ (local-set-variable! comment-start ";")
+ (local-set-variable! comment-end "")
+ (local-set-variable! paragraph-start "^$")
+ (local-set-variable! paragraph-separate (ref-variable paragraph-start))
+ (local-set-variable! indent-line-procedure (ref-command lisp-indent-line))
+ (if (ref-variable scheme-mode-hook) ((ref-variable scheme-mode-hook))))
+
+(define-variable scheme-mode-hook
"If not false, a thunk to call when entering Scheme mode."
false)
-(define-key "Scheme" #\Rubout "^R Backward Delete Hacking Tabs")
-(define-key "Scheme" #\) "^R Lisp Insert Paren")
-(define-key "Scheme" #\M-O "^R Evaluate Buffer")
-(define-key "Scheme" #\M-Z "^R Evaluate Definition")
-(define-key "Scheme" #\C-M-= "^R Evaluate Previous Sexp into Buffer")
-(define-key "Scheme" #\C-M-Q "^R Indent Sexp")
-(define-key "Scheme" #\C-M-X "^R Evaluate Sexp")
-(define-key "Scheme" #\C-M-Z "^R Evaluate Region")
+(define-key 'scheme #\rubout 'backward-delete-char-untabify)
+(define-key 'scheme #\tab 'lisp-indent-line)
+(define-key 'scheme #\) 'lisp-insert-paren)
+(define-key 'scheme #\m-o 'eval-buffer)
+(define-key 'scheme #\m-z 'eval-definition)
+(define-key 'scheme #\c-m-= 'eval-previous-sexp-into-buffer)
+(define-key 'scheme #\c-m-q 'indent-sexp)
+(define-key 'scheme #\c-m-x 'eval-expression)
+(define-key 'scheme #\c-m-z 'eval-region)
\f
;;;; Read Syntax
(string-table-put! scheme-mode:indent-methods
(symbol->string (car entry))
(cdr entry)))
- `((CASE . 1)
+ `(
+ (BEGIN . 0)
+ (CASE . 1)
+ (DELAY . 0)
(DO . 2)
- (FLUID-LET . 1)
(LAMBDA . 1)
(LET . ,scheme-mode:indent-let-method)
(LET* . 1)
- (LET-SYNTAX . 1)
(LETREC . 1)
+
+ (CALL-WITH-INPUT-FILE . 1)
+ (WITH-INPUT-FROM-FILE . 1)
+ (CALL-WITH-OUTPUT-FILE . 1)
+ (WITH-OUTPUT-TO-FILE . 1)
+
+ ;; Remainder are MIT Scheme specific.
+
+ (FLUID-LET . 1)
+ (IN-PACKAGE . 1)
+ (LET-SYNTAX . 1)
(LOCAL-DECLARE . 1)
(MACRO . 1)
+ (MAKE-ENVIRONMENT . 0)
(NAMED-LAMBDA . 1)
+ (USING-SYNTAX . 1)
- (CALL-WITH-INPUT-FILE . 1)
- (WITH-INPUT-FROM-FILE . 1)
(WITH-INPUT-FROM-PORT . 1)
(WITH-INPUT-FROM-STRING . 1)
- (CALL-WITH-OUTPUT-FILE . 1)
- (WITH-OUTPUT-TO-FILE . 1)
(WITH-OUTPUT-TO-PORT . 1)
- (WITH-OUTPUT-TO-STRING . 1)
+ (WITH-OUTPUT-TO-STRING . 1) (WITH-VALUES . 1)
+
+ (BIND-CONDITION-HANDLER . 2)
(LIST-TRANSFORM-POSITIVE . 1)
(LIST-TRANSFORM-NEGATIVE . 1)
(LIST-SEARCH-POSITIVE . 1)
(LIST-SEARCH-NEGATIVE . 1)
+ (SYNTAX-TABLE-DEFINE . 2)
))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/screen.scm,v 1.79 1989/03/30 16:40:07 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/screen.scm,v 1.80 1989/04/15 00:52:51 cph Exp $
;;;
;;; Copyright (c) 1989 Massachusetts Institute of Technology
;;;
(set! new-flag (screen-in-update? screen))
(set-screen-in-update?! screen old-flag)
((screen-operation/finish-update! screen) screen)))))
-
+\f
(define (screen-x-size screen)
((screen-operation/x-size screen) screen))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/sercom.scm,v 1.52 1989/03/14 08:02:48 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/sercom.scm,v 1.53 1989/04/15 00:52:56 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-;;;; Character Search
-;;; JAR Special
+;;;; Variables
-(define-variable "Case Fold Search"
- "If not false, search commands are insensitive to case."
- true)
+(define-variable case-fold-search
+ "*True if searches should ignore case." true)
-(define-command ("^R Character Search" argument)
- "Search for a single character.
-Special characters:
- C-A calls \\[Search Forward].
- C-R searches backwards for the current default.
- C-S searches forward for the current default.
- C-Q quotes the character to be searched for;
- this allows search for special characters."
- (character-search argument true))
+(define-variable search-last-string
+ "Last string search for by a non-regexp search command.
+This does not include direct calls to the primitive search functions,
+and does not include searches that are aborted."
+ "")
-(define-command ("^R Reverse Character Search" argument)
- "Like \\[^R Winning Character Search], but searches backwards."
- (character-search argument false))
+(define-variable search-last-regexp
+ "Last string searched for by a regexp search command.
+This does not include direct calls to the primitive search functions,
+and does not include searches that are aborted."
+ "")
-(define (character-search argument forward?)
- (define (char-search char)
- (search-finish
- ((if forward? char-search-forward char-search-backward)
- char)))
+(define-variable search-repeat-char
+ "*Character to repeat incremental search forwards."
+ #\C-s)
- (define (string-search operator)
- (search-finish (operator (ref-variable "Previous Search String"))))
+(define-variable search-reverse-char
+ "*Character to repeat incremental search backwards."
+ #\C-r)
- (define (search-finish mark)
- (if mark
- (set-current-point! mark)
- (editor-failure)))
+(define-variable search-exit-char
+ "*Character to exit incremental search."
+ #\altmode)
+
+(define-variable search-delete-char
+ "*Character to delete from incremental search string."
+ #\rubout)
+
+(define-variable search-quote-char
+ "*Character to quote special characters for incremental search."
+ #\C-q)
+
+(define-variable search-yank-word-char
+ "*Character to pull next word from buffer into search string."
+ #\C-w)
+
+(define-variable search-yank-line-char
+ "*Character to pull rest of line from buffer into search string."
+ #\C-y)
- (let ((char (prompt-for-char "Character Search")))
- (case (char-upcase char)
- ((#\C-A)
- ((if forward?
- search-forward-command
- search-backward-command)
- argument))
- ((#\C-S) (string-search search-forward))
- ((#\C-R) (string-search search-backward))
- ((#\C-Q)
- (char-search (prompt-for-char-without-interrupts "Quote Character")))
- (else (char-search char)))))
+(define-variable search-exit-option
+ "*True means random control characters terminate incremental search."
+ true)
+
+(define-variable search-slow-speed
+ "*Highest terminal speed at which to use \"slow\" style incremental search.
+This is the style where a one-line window is created to show the line
+that the search has reached."
+ 1200)
+
+(define-variable search-slow-window-lines
+ "*Number of lines in slow search display windows.
+These are the short windows used during incremental search on slow terminals.
+Negative means put the slow search window at the top (normally it's at bottom)
+and the value is minus the number of lines."
+ 1)
\f
;;;; String Search
-(define-variable "Previous Search String"
- "Last string searched for by any string search command."
- "")
+(define (search-prompt prompt)
+ (lambda ()
+ (let ((string
+ (prompt-for-string prompt (ref-variable search-last-string))))
+ (set-variable! search-last-string string)
+ (list string))))
-(define-variable "Previous Search Regexp"
- "Last regular expression searched for by any search command."
- false)
+(define (re-search-prompt prompt)
+ (lambda ()
+ (let ((regexp
+ (prompt-for-string prompt (ref-variable search-last-regexp))))
+ (set-variable! search-last-regexp regexp)
+ (list regexp))))
+
+(define (search-command procedure pattern)
+ (let ((mark (procedure pattern)))
+ (if mark
+ (begin
+ (push-current-mark! (current-point))
+ (set-current-point! mark))
+ (editor-failure))))
-(define-command ("Search Forward")
+(define-command search-forward
"Search forward from point for a character string.
Sets point at the end of the occurrence found."
- (search-command search-prompt "Search" search-forward))
+ (search-prompt "Search")
+ (lambda (string)
+ (search-command search-forward string)))
-(define-command ("Search Backward")
+(define-command search-backward
"Search backward from point for a character string.
Sets point at the beginning of the occurrence found."
- (search-command search-prompt "Search Backward" search-backward))
+ (search-prompt "Search backward")
+ (lambda (string)
+ (search-command search-backward string)))
-(define-command ("RE Search Forward")
+(define-command re-search-forward
"Search forward from point for a regular expression.
Sets point at the end of the occurrence found."
- (search-command re-search-prompt "RE Search" re-search-forward))
+ (search-prompt "RE search")
+ (lambda (regexp)
+ (search-command re-search-forward regexp)))
-(define-command ("RE Search Backward")
+(define-command re-search-backward
"Search backward from point for a character string.
Sets point at the beginning of the occurrence found."
- (search-command re-search-prompt "RE Search Backward" re-search-backward))
+ (search-prompt "RE search backward")
+ (lambda (regexp)
+ (search-command re-search-backward regexp)))
+\f
+;;;; Incremental Search
+
+(define-command isearch-forward
+ "Do incremental search forward.
+As you type characters, they add to the search string and are found.
+Type Delete to cancel characters from end of search string.
+Type ESC to exit, leaving point at location found.
+Type C-s to search again forward, C-r to search again backward.
+Type C-w to yank word from buffer onto end of search string and search for it.
+Type C-y to yank rest of line onto end of search string, etc.
+Type C-q to quote control character to search for it.
+Other control and meta characters terminate the search
+ and are then executed normally.
+The above special characters are mostly controlled by parameters;
+ do M-x variable-apropos on search-.*-char to find them.
+C-g while searching or when search has failed
+ cancels input back to what has been found successfully.
+C-g when search is successful aborts and moves point to starting point."
+ ()
+ (lambda ()
+ (isearch true false)))
+
+(define-command isearch-forward-regexp
+ "Do incremental search forward for regular expression.
+Like ordinary incremental search except that your input
+is treated as a regexp. See \\[isearch-forward] for more info."
+ ()
+ (lambda ()
+ (isearch true true)))
+
+(define-command isearch-backward
+ "Do incremental search backward.
+See \\[isearch-forward] for more information."
+ ()
+ (lambda ()
+ (isearch false false)))
+
+(define-command isearch-backward-regexp
+ "Do incremental search backward for regular expression.
+Like ordinary incremental search except that your input
+is treated as a regexp. See \\[isearch-forward] for more info."
+ ()
+ (lambda ()
+ (isearch false true)))
+\f
+;;;; Character Search
+;;; (Courtesy of Jonathan Rees)
-(define (search-command prompter prompt procedure)
- (let ((mark (procedure (prompter prompt))))
- (if mark
- (begin (push-current-mark! (current-point))
- (set-current-point! mark))
- (editor-failure))))
+(define-command char-search-forward
+ "Search for a single character.
+Special characters:
+ C-a calls \\[search-forward].
+ C-r searches backwards for the current default.
+ C-s searches forward for the current default.
+ C-q quotes the character to be searched for;
+ this allows search for special characters."
+ ()
+ (lambda ()
+ (character-search true)))
-(define (search-prompt prompt)
- (let ((string (prompt-for-string prompt
- (ref-variable "Previous Search String"))))
- (set-variable! "Previous Search String" string)
- string))
+(define-command char-search-backward
+ "Like \\[char-search-forward], but searches backwards."
+ ()
+ (lambda ()
+ (character-search false)))
-(define (re-search-prompt prompt)
- (let ((regexp (prompt-for-string prompt
- (ref-variable "Previous Search Regexp"))))
- (set-variable! "Previous Search Regexp" regexp)
- regexp))
\ No newline at end of file
+(define (character-search forward?)
+ (define (char-search char)
+ (search-finish
+ ((if forward? char-search-forward char-search-backward) char)))
+
+ (define (string-search operator)
+ (search-finish (operator (ref-variable search-last-string))))
+
+ (define (search-finish mark)
+ (if mark
+ (set-current-point! mark)
+ (editor-failure)))
+
+ (let ((char (prompt-for-char "Character search")))
+ (let ((test-for
+ (lambda (char*)
+ (char=? char (remap-alias-char char*)))))
+ (cond ((test-for #\C-a)
+ (dispatch-on-command
+ (if forward?
+ (ref-command-object search-forward)
+ (ref-command-object search-backward))))
+ ((test-for #\C-s)
+ (string-search search-forward))
+ ((test-for #\C-r)
+ (string-search search-backward))
+ ((test-for #\C-q)
+ (char-search (prompt-for-char "Quote character")))
+ (else
+ (char-search char))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/simple.scm,v 1.26 1989/03/14 08:02:53 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/simple.scm,v 1.27 1989/04/15 00:53:03 cph Exp $
;;;
;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
(string-downcase! string)
(string-set! string 0 (char-upcase (string-ref string 0)))
string)))
-
+\f
(define (mark-flash mark #!optional type)
(cond (*executing-keyboard-macro?* unspecific)
((not mark) (editor-beep))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/strtab.scm,v 1.39 1989/03/14 08:02:58 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/strtab.scm,v 1.40 1989/04/15 00:53:07 cph Exp $
;;;
;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
(lambda (index) index false)))
\f
(define (string-table-complete table string
- if-unambiguous if-ambiguous if-not-found)
+ if-unique if-not-unique if-not-found)
(%string-table-complete table string
- if-unambiguous
+ if-unique
(lambda (close-match gcs lower upper)
- lower upper ;ignore
- (if-ambiguous close-match gcs))
+ (if-not-unique
+ (substring close-match 0 gcs)
+ (lambda ()
+ (let loop ((index lower))
+ (if (= index upper)
+ '()
+ (cons (string-table-entry-string
+ (vector-ref (string-table-vector table) index))
+ (loop (1+ index))))))))
if-not-found))
(define (string-table-completions table string)
'())))
(define (%string-table-complete table string
- if-unambiguous if-ambiguous if-not-found)
+ if-unique if-not-unique if-not-found)
(let ((size (string-length string))
- (table-size (string-table-size table)))
- (define (entry-string index)
- (string-table-entry-string (vector-ref (string-table-vector table)
- index)))
- (define (perform-search index)
- (let ((close-match (entry-string index)))
- (define (match-entry index)
- (string-match-forward-ci close-match (entry-string index)))
-
- (define (scan-up gcs receiver)
- (define (loop gcs index)
- (if (= index table-size)
- (receiver gcs table-size)
- (let ((match (match-entry index)))
- (if (< match size)
- (receiver gcs index)
- (loop (min gcs match) (1+ index))))))
- (loop gcs (1+ index)))
-
- (define (scan-down gcs receiver)
- (define (loop gcs index)
- (if (zero? index)
- (receiver gcs 0)
- (let ((new-index (-1+ index)))
- (let ((match (match-entry new-index)))
- (if (< match size)
- (receiver gcs index)
- (loop (min gcs match) new-index))))))
- (loop gcs index))
-
- (if (string-prefix-ci? string close-match)
- (scan-up (string-length close-match)
- (lambda (gcs upper)
- (scan-down gcs
- (lambda (gcs lower)
- (if (= lower (-1+ upper))
- (if-unambiguous (entry-string lower))
- (if-ambiguous close-match gcs lower upper))))))
- (if-not-found))))
- (string-table-search table string
- (lambda (index entry)
- entry ;ignore
- (perform-search index))
- (lambda (index)
- (if (= index table-size)
- (if-not-found)
- (perform-search index))))))
+ (table-size (string-table-size table))
+ (entry-string
+ (lambda (index)
+ (string-table-entry-string
+ (vector-ref (string-table-vector table) index)))))
+ (let ((perform-search
+ (lambda (index)
+ (let ((close-match (entry-string index)))
+ (let ((match-entry
+ (lambda (index)
+ (string-match-forward-ci close-match
+ (entry-string index)))))
+ (define (scan-up gcs receiver)
+ (let loop ((gcs gcs) (index (1+ index)))
+ (if (= index table-size)
+ (receiver gcs table-size)
+ (let ((match (match-entry index)))
+ (if (< match size)
+ (receiver gcs index)
+ (loop (min gcs match) (1+ index)))))))
+ (define (scan-down gcs receiver)
+ (let loop ((gcs gcs) (index index))
+ (if (zero? index)
+ (receiver gcs 0)
+ (let ((new-index (-1+ index)))
+ (let ((match (match-entry new-index)))
+ (if (< match size)
+ (receiver gcs index)
+ (loop (min gcs match) new-index)))))))
+ (if (string-prefix-ci? string close-match)
+ (scan-up (string-length close-match)
+ (lambda (gcs upper)
+ (scan-down gcs
+ (lambda (gcs lower)
+ (if (= lower (-1+ upper))
+ (if-unique (entry-string lower))
+ (if-not-unique close-match
+ gcs lower upper))))))
+ (if-not-found)))))))
+ (string-table-search table string
+ (lambda (index entry)
+ entry ;ignore
+ (perform-search index))
+ (lambda (index)
+ (if (= index table-size)
+ (if-not-found)
+ (perform-search index)))))))
\f
(define (string-table-apropos table string)
(let ((end (string-table-size table)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/syntax.scm,v 1.66 1989/03/14 08:03:08 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/syntax.scm,v 1.67 1989/04/15 00:53:13 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
\f
;;;; Syntax Tables
-(define-variable "Syntax Table"
+(define-variable syntax-table
"The syntax-table used for word and list parsing.")
-(define-variable "Syntax Ignore Comments Backwards"
+(define-variable syntax-ignore-comments-backwards
"If true, ignore comments in backwards expression parsing.
This can be #T for comments that end in }, as in Pascal or C.
It should be #F for comments that end in Newline, as in Lisp;
(vector-copy (syntax-table/entries standard-syntax-table))))))
(define (initialize-syntax-table!)
- (set-variable! "Syntax Table" (make-syntax-table)))
+ (set-variable! syntax-table (make-syntax-table)))
\f
;;;; Word Parsing
(let loop ((start (mark-index mark)) (n n))
(let ((m
((ucode-primitive scan-word-forward)
- (syntax-table/entries (ref-variable "Syntax Table"))
+ (syntax-table/entries (ref-variable syntax-table))
group start end)))
(cond ((not m) (limit-mark-motion limit? (make-mark group start)))
((= n 1) (make-mark group m))
(let loop ((start (mark-index mark)) (n n))
(let ((m
((ucode-primitive scan-word-backward)
- (syntax-table/entries (ref-variable "Syntax Table"))
+ (syntax-table/entries (ref-variable syntax-table))
group start end)))
(cond ((not m) (limit-mark-motion limit? (make-mark group start)))
((= n 1) (make-mark group m))
(let ((limit? (and (not (default-object? limit?)) limit?))
(index
((ucode-primitive scan-forward-to-word)
- (syntax-table/entries (ref-variable "Syntax Table"))
+ (syntax-table/entries (ref-variable syntax-table))
(mark-group mark)
(mark-index mark)
(mark-index (group-end mark)))))
(define (backward-prefix-chars start #!optional end)
(make-mark (mark-group start)
((ucode-primitive scan-backward-prefix-chars)
- (syntax-table/entries (ref-variable "Syntax Table"))
+ (syntax-table/entries (ref-variable syntax-table))
(mark-group start)
(mark-index start)
(mark-index (default-end/backward start end)))))
(define (mark-right-char-quoted? mark)
((ucode-primitive quoted-char?)
- (syntax-table/entries (ref-variable "Syntax Table"))
+ (syntax-table/entries (ref-variable syntax-table))
(mark-group mark)
(mark-index mark)
(group-start-index (mark-group mark))))
(define (%forward-list start end depth sexp?)
(let ((index
((ucode-primitive scan-list-forward)
- (syntax-table/entries (ref-variable "Syntax Table"))
+ (syntax-table/entries (ref-variable syntax-table))
(mark-group start)
(mark-index start)
(mark-index end)
(define (%backward-list start end depth sexp?)
(let ((index
((ucode-primitive scan-list-backward)
- (syntax-table/entries (ref-variable "Syntax Table"))
+ (syntax-table/entries (ref-variable syntax-table))
(mark-group start)
(mark-index start)
(mark-index end)
depth
sexp?
- (ref-variable "Syntax Ignore Comments Backwards"))))
+ (ref-variable syntax-ignore-comments-backwards))))
(and index (make-mark (mark-group start) index))))
(set! forward-one-sexp
(group (mark-group start)))
(let ((state
((ucode-primitive scan-sexps-forward)
- (syntax-table/entries (ref-variable "Syntax Table"))
+ (syntax-table/entries (ref-variable syntax-table))
group
(mark-index start)
(mark-index end)
(define (char->syntax-code char)
((ucode-primitive char->syntax-code)
- (syntax-table/entries (ref-variable "Syntax Table"))
+ (syntax-table/entries (ref-variable syntax-table))
char))
+
+(define (substring-find-next-char-of-syntax string start end syntax)
+ (let loop ((index start))
+ (and (not (= index end))
+ (if (char=? syntax (char->syntax-code (string-ref string index)))
+ index
+ (loop (1+ index))))))
+
+(define (substring-find-next-char-not-of-syntax string start end syntax)
+ (let loop ((index start))
+ (and (not (= index end))
+ (if (char=? syntax (char->syntax-code (string-ref string index)))
+ (loop (1+ index))
+ index))))
\f
;;;; Definition Start/End
-(define-variable "Definition Start"
+(define-variable definition-start
"Regexp to match start of a definition."
"^\\s(")
(define (definition-start? mark)
- (re-match-forward (ref-variable "Definition Start") mark))
+ (re-match-forward (ref-variable definition-start) mark))
(define (forward-one-definition-start mark)
- (and (re-search-forward (ref-variable "Definition Start")
+ (and (re-search-forward (ref-variable definition-start)
(if (line-start? mark) (line-end mark 0) mark))
(re-match-start 0)))
(define (backward-one-definition-start mark)
- (re-search-backward (ref-variable "Definition Start") mark))
+ (re-search-backward (ref-variable definition-start) mark))
(define (forward-one-definition-end mark)
(define (loop start)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tagutl.scm,v 1.31 1989/04/05 18:22:38 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tagutl.scm,v 1.32 1989/04/15 00:53:18 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define-command ("Visit Tags Table")
- "Tell tags commands to use a given tags table file."
- (set-variable!
- "Tags Table Pathname"
- (prompt-for-pathname "Visit tags table"
- (or (ref-variable "Tags Table Pathname")
- (pathname-new-type (current-default-pathname)
- "TAG")))))
+(define-command visit-tags-table
+ "Tell tags commands to use tag table file FILE.
+FILE should be the name of a file created with the `etags' program.
+A directory name is ok too; it means file TAGS in that directory."
+ "FVisit tags table (default TAGS)"
+ (lambda (filename)
+ (let ((pathname (->pathname filename)))
+ (set-variable! tags-table-pathname
+ (if (file-directory? pathname)
+ (pathname-new-name pathname "TAGS")
+ pathname)))))
-(define-command ("Find Tag" argument)
- "Find tag (in current tags table) whose name contains a given string.
+(define-command find-tag
+ "Find tag (in current tag table) whose name contains TAGNAME.
Selects the buffer that the tag is contained in
and puts point at its definition.
- With argument, searches for the next tag in the tags table that matches
-the string used in the previous Find Tag."
- (&find-tag-command argument find-file))
+ If TAGNAME is a null string, the expression in the buffer
+around or before point is used as the tag name.
+ If second arg NEXT is non-false (interactively, with prefix arg),
+searches for the next tag in the tag table
+that matches the tagname used in the previous find-tag.
-(define-command ("Find Tag Other Window" argument)
- "Like \\[Find Tag], but selects buffer in another window."
- (&find-tag-command argument find-file-other-window))
+See documentation of variable tags-file-name."
+ (lambda () (find-tag-arguments "Find tag"))
+ (lambda (string previous-tag?)
+ (&find-tag-command string previous-tag? find-file)))
-(define (tags-table-buffer)
- (if (not (ref-variable "Tags Table Pathname"))
- (visit-tags-table-command false))
- (let ((pathname (ref-variable "Tags Table Pathname")))
- (let ((buffer (find-file-noselect pathname)))
- (if (and (not (verify-visited-file-modification-time buffer))
- (prompt-for-yes-or-no?
- "Tags file has changed, read new contents"))
- (revert-buffer true true))
- (if (not (eqv? (extract-right-char (buffer-start buffer)) #\Page))
- (editor-error "File "
- (pathname->string pathname)
- " not a valid tag table"))
- buffer)))
-
-(define (tag->pathname tag)
- (define (loop mark)
- (let ((file-mark (skip-chars-backward "^,\n" (line-end mark 1))))
- (let ((mark (mark+ (line-start file-mark 1)
- (with-input-from-mark file-mark read))))
- (if (mark> mark tag)
- (string->pathname (extract-string (line-start file-mark 0)
- (mark-1+ file-mark)))
- (loop mark)))))
- (loop (group-start tag)))
+(define-command find-tag-other-window
+ "Find tag (in current tag table) whose name contains TAGNAME.
+ Selects the buffer that the tag is contained in in another window
+and puts point at its definition.
+ If TAGNAME is a null string, the expression in the buffer
+around or before point is used as the tag name.
+ If second arg NEXT is non-false (interactively, with prefix arg),
+searches for the next tag in the tag table
+that matches the tagname used in the previous find-tag.
-(define (tags-table-pathnames)
- (let ((buffer (tags-table-buffer)))
- (define (loop mark)
- (let ((file-mark (skip-chars-backward "^,\n" (line-end mark 1))))
- (let ((mark (mark+ (line-start file-mark 1)
- (with-input-from-mark file-mark read))))
- (cons (string->pathname (extract-string (line-start file-mark 0)
- (mark-1+ file-mark)))
- (if (group-end? mark)
- '()
- (loop mark))))))
- (or (buffer-get buffer tags-table-pathnames)
- (let ((pathnames (loop (buffer-start buffer))))
- (buffer-put! buffer tags-table-pathnames pathnames)
- pathnames))))
+See documentation of variable tags-file-name."
+ (lambda () (find-tag-arguments "Find tag in other window"))
+ (lambda (string previous-tag?)
+ (&find-tag-command string previous-tag? find-file-other-window)))
\f
;;;; Find Tag
(define previous-find-tag-string
false)
-(define (&find-tag-command previous-tag? find-file)
+(define (find-tag-arguments prompt)
+ (let ((previous-tag? (command-argument-standard-value)))
+ (if previous-tag?
+ (list false true)
+ (let ((string (prompt-for-string prompt (find-tag-default))))
+ (set! previous-find-tag-string string)
+ (list string false)))))
+
+(define (&find-tag-command string previous-tag? find-file)
(let ((buffer (tags-table-buffer)))
(if previous-tag?
(find-tag previous-find-tag-string
buffer
(buffer-point buffer)
find-file)
- (let ((string (prompt-for-string "Find tag" (find-tag-default))))
- (set! previous-find-tag-string string)
- (find-tag string
- buffer
- (buffer-start buffer)
- find-file)))))
+ (find-tag string buffer (buffer-start buffer) find-file)))
+ (set! tags-loop-continuation
+ (lambda () ((ref-command find-tag) false true)))
+ unspecific)
(define (find-tag-default)
(let ((point (current-point)))
(let ((end (group-end point)))
- (let ((mark (re-search-forward "\\(\\sw\\|\\s_\\)*" point end 'LIMIT)))
- (and (re-search-backward "\\sw\\|\\s_" mark)
- (let ((mark*
- (re-search-forward "\\(\\s'\\)*"
- (backward-sexp mark 1 'LIMIT)
- mark)))
- (and mark*
- (extract-string mark* mark))))))))
-
+ (let ((mark
+ (re-search-backward
+ "\\sw\\|\\s_"
+ (re-search-forward "\\(\\sw\\|\\s_\\)*" point end 'LIMIT))))
+ (and mark
+ (let ((mark (mark1+ mark)))
+ (let ((mark*
+ (re-search-forward "\\(\\s'\\)*"
+ (backward-sexp mark 1 'LIMIT)
+ mark)))
+ (and mark*
+ (extract-string mark* mark)))))))))
+\f
(define (find-tag string buffer start find-file)
(let ((tag
(let loop ((mark start))
\f
;;;; Tags Search
-(define-command ("Tags Search")
- "Search through all files listed in tag table for a given string.
+(define-command tags-search
+ "Search through all files listed in tag table for match for REGEXP.
Stops when a match is found.
-To continue searching for next match, use command \\[Tags Loop Continue]."
- (let ((string
- (prompt-for-string "Tags Search"
- (ref-variable "Previous Search String"))))
- (set-variable! "Previous Search String" string)
- (tags-search (re-quote-string string))))
+To continue searching for next match, use command \\[tags-loop-continue].
-(define-command ("RE Tags Search")
- "Search through all files listed in tag table for a given regexp.
-Stops when a match is found.
-To continue searching for next match, use command \\[Tags Loop Continue]."
- (let ((regexp
- (prompt-for-string "RE Tags Search"
- (ref-variable "Previous Search Regexp"))))
- (set-variable! "Previous Search Regexp" regexp)
- (tags-search regexp)))
+See documentation of variable tags-file-name."
+ (re-search-prompt "Tags search")
+ (lambda (regexp)
+ (set! tags-loop-continuation
+ (lambda ()
+ (let ((mark (re-search-forward regexp (current-point))))
+ (if mark
+ (begin
+ (set-current-point! mark)
+ (clear-message))
+ (tags-loop-start)))))
+ (set! tags-loop-pathnames (tags-table-pathnames))
+ (tags-loop-start)))
-(define-command ("Tags Query Replace")
- "Query replace a given string with another one though all files listed
-in tag table. If you exit (C-G or Altmode), you can resume the query
-replace with the command \\[Tags Loop Continue]."
- (replace-string-arguments "Tags Query Replace"
- (lambda (source target)
- (let ((replacer (replace-string "Tags Query Replace" false true false)))
- (set! tags-loop-operator
- (lambda (buffer start)
- (select-buffer-no-record buffer)
- (set-current-point! start)
- (replacer source target))))))
- (set! tags-loop-done clear-message)
- (tags-loop-start (tags-table-pathnames)))
+(define-command tags-query-replace
+ "Query-replace-regexp FROM with TO through all files listed in tag table.
+Third arg DELIMITED (prefix arg) means replace only word-delimited matches.
+If you exit (C-G or ESC), you can resume the query-replace
+with the command \\[tags-loop-continue].
-(define-command ("Tags Loop Continue")
- "Continue last \\[Tags Search] or \\[Tags Query Replace] command."
- (let ((buffer (object-unhash tags-loop-buffer)))
- (if (and (not (null? tags-loop-entry))
- buffer)
- (tags-loop-continue buffer (buffer-point buffer))
- (editor-error "No Tags Loop in progress"))))
-\f
-(define tags-loop-buffer (object-hash false))
-(define tags-loop-entry '())
-(define tags-loop-operator)
-(define tags-loop-done)
+See documentation of variable tags-file-name."
+ (lambda () (replace-string-arguments "Tags query replace"))
+ (lambda (source target replace-words-only?)
+ (set! tags-loop-continuation
+ (let ((replacer
+ (replace-string 'tags-query-replace
+ replace-words-only?
+ true
+ false)))
+ (lambda ()
+ (if (replacer source target)
+ (clear-message)
+ (tags-loop-start)))))
+ (set! tags-loop-pathnames (tags-table-pathnames))
+ (tags-loop-start)))
+
+(define tags-loop-continuation false)
+(define tags-loop-pathnames)
-(define (tags-search regexp)
- (set! tags-loop-operator
- (lambda (buffer start)
- (let ((mark (re-search-forward regexp start)))
- (and mark
- (begin (if (not (eq? (current-buffer) buffer))
- (select-buffer buffer))
- (set-current-point! mark)
- (temporary-message "Tags Search succeeded")
- true)))))
- (set! tags-loop-done
- (lambda ()
- (editor-failure "Tags Search failed")))
- (tags-loop-start (tags-table-pathnames)))
+(define (tags-loop-start)
+ (let ((pathnames tags-loop-pathnames))
+ (if (null? pathnames)
+ (editor-error "All files processed.")
+ (begin
+ (set! tags-loop-pathnames (cdr pathnames))
+ (find-file (car pathnames))
+ (message "Scanning file "
+ (pathname->string (buffer-truename (current-buffer)))
+ "...")
+ (set-current-point! (buffer-start (current-buffer)))
+ (tags-loop-continuation)))))
-(define (tags-loop-start entries)
- (set! tags-loop-entry entries)
- (if (null? entries)
- (tags-loop-done)
- (let ((buffer (find-file-noselect (car entries))))
- (set! tags-loop-buffer (object-hash buffer))
- (tags-loop-continue buffer (buffer-start buffer)))))
+(define-command tags-loop-continue
+ "Continue last \\[tags-search] or \\[tags-query-replace] command."
+ ()
+ (lambda ()
+ (if tags-loop-continuation
+ (tags-loop-continuation)
+ (editor-error "No tags loop in progress"))))
+\f
+(define (tags-table-buffer)
+ (if (not (ref-variable tags-table-pathname))
+ (dispatch-on-command (ref-command-object visit-tags-table)))
+ (let ((pathname (ref-variable tags-table-pathname)))
+ (let ((buffer (find-file-noselect pathname)))
+ (if (and (not (verify-visited-file-modification-time buffer))
+ (prompt-for-yes-or-no?
+ "Tags file has changed, read new contents"))
+ (revert-buffer true true))
+ (if (not (eqv? (extract-right-char (buffer-start buffer)) #\Page))
+ (editor-error "File "
+ (pathname->string pathname)
+ " not a valid tag table"))
+ buffer)))
-(define (tags-loop-continue buffer start)
- (if (not (and (buffer-alive? buffer)
- (tags-loop-operator buffer start)))
- (tags-loop-start (cdr tags-loop-entry))))
\ No newline at end of file
+(define (tag->pathname tag)
+ (define (loop mark)
+ (let ((file-mark (skip-chars-backward "^,\n" (line-end mark 1))))
+ (let ((mark (mark+ (line-start file-mark 1)
+ (with-input-from-mark file-mark read))))
+ (if (mark> mark tag)
+ (string->pathname (extract-string (line-start file-mark 0)
+ (mark-1+ file-mark)))
+ (loop mark)))))
+ (loop (group-start tag)))
+
+(define (tags-table-pathnames)
+ (let ((buffer (tags-table-buffer)))
+ (or (buffer-get buffer tags-table-pathnames)
+ (let ((pathnames
+ (let ((directory
+ (pathname-directory-path (buffer-truename buffer))))
+ (let loop ((mark (buffer-start buffer)))
+ (let ((file-mark
+ (skip-chars-backward "^,\n" (line-end mark 1))))
+ (let ((mark
+ (mark+ (line-start file-mark 1)
+ (with-input-from-mark file-mark read))))
+ (cons (merge-pathnames
+ (string->pathname
+ (extract-string (line-start file-mark 0)
+ (mark-1+ file-mark)))
+ directory)
+ (if (group-end? mark)
+ '()
+ (loop mark)))))))))
+ (buffer-put! buffer tags-table-pathnames pathnames)
+ pathnames))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/texcom.scm,v 1.30 1989/03/14 08:03:20 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/texcom.scm,v 1.31 1989/04/15 00:53:26 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define-major-mode "Text" "Fundamental"
+(define-major-mode text fundamental "Text"
"Major mode for editing english text."
- (local-set-variable! "Syntax Table" text-mode:syntax-table)
- (if (ref-variable "Text Mode Hook") ((ref-variable "Text Mode Hook"))))
+ (local-set-variable! syntax-table text-mode:syntax-table)
+ (if (ref-variable text-mode-hook) ((ref-variable text-mode-hook))))
-(define-key "Text" #\M-S "^R Center Line")
+(define-key 'text #\m-s 'center-line)
(define text-mode:syntax-table (make-syntax-table))
(modify-syntax-entry! text-mode:syntax-table #\" " ")
(modify-syntax-entry! text-mode:syntax-table #\} "){ ")
(modify-syntax-entry! text-mode:syntax-table #\' "w ")
-(define-variable "Text Mode Hook"
+(define-variable text-mode-hook
"If not false, a thunk to call when entering Text mode."
false)
(define (turn-on-auto-fill)
- (enable-current-minor-mode! fill-mode))
+ (enable-current-minor-mode! (ref-mode-object auto-fill)))
-(define-command ("Text Mode")
+(define-command text-mode
"Make the current mode be Text mode."
- (set-current-major-mode! text-mode))
+ ()
+ (lambda ()
+ (set-current-major-mode! (ref-mode-object text))))
-(define-major-mode "Indented-Text" "Text"
+(define-major-mode indented-text text "Indented-Text"
"Like Text mode, but indents each line under previous non-blank line."
- (local-set-variable! "Indent Line Procedure" ^r-indent-relative-command))
+ (local-set-variable! indent-line-procedure (ref-command indent-relative)))
-(define-command ("Indented Text Mode")
+(define-command indented-text-mode
"Make the current mode be Indented Text mode."
- (set-current-major-mode! indented-text-mode))
+ ()
+ (lambda ()
+ (set-current-major-mode! (ref-mode-object indented-text))))
\f
;;;; Words
-(define-command ("^R Forward Word" (argument 1))
+(define-command forward-word
"Move one or more words forward."
- (move-thing forward-word argument))
+ "p"
+ (lambda (argument)
+ (move-thing forward-word argument)))
-(define-command ("^R Backward Word" (argument 1))
+(define-command backward-word
"Move one or more words backward."
- (move-thing backward-word argument))
+ "p"
+ (lambda (argument)
+ (move-thing backward-word argument)))
-(define-command ("^R Mark Word" (argument 1))
+(define-command mark-word
"Set mark one or more words from point."
- (mark-thing forward-word argument))
+ "p"
+ (lambda (argument)
+ (mark-thing forward-word argument)))
-(define-command ("^R Kill Word" (argument 1))
+(define-command kill-word
"Kill one or more words forward."
- (kill-thing forward-word argument))
+ "p"
+ (lambda (argument)
+ (kill-thing forward-word argument)))
-(define-command ("^R Backward Kill Word" (argument 1))
+(define-command backward-kill-word
"Kill one or more words backward."
- (kill-thing backward-word argument))
+ "p"
+ (lambda (argument)
+ (kill-thing backward-word argument)))
-(define-command ("^R Transpose Words" (argument 1))
+(define-command transpose-words
"Transpose the words before and after the cursor.
With a positive argument it transposes the words before and after the
cursor, moves right, and repeats the specified number of times,
the cursor, moves between them, and repeats the specified number of
times, exactly undoing the positive argument form.
With a zero argument, it transposes the words at point and mark."
- (transpose-things forward-word argument))
+ "p"
+ (lambda (argument)
+ (transpose-things forward-word argument)))
\f
;;;; Case Conversion
-(define-command ("^R Uppercase Region")
+(define-command upcase-region
"Convert region to upper case."
- (upcase-area (current-mark)))
+ "m"
+ (lambda (mark)
+ (upcase-area mark)))
-(define-command ("^R Lowercase Region")
+(define-command downcase-region
"Convert region to lower case."
- (downcase-area (current-mark)))
+ "m"
+ (lambda (mark)
+ (downcase-area mark)))
-(define-command ("^R Uppercase Word" (argument 1))
+(define-command upcase-word
"Uppercase one or more words.
Moves forward over the words affected.
With a negative argument, uppercases words before point
but does not move point."
- (upcase-area (forward-word (current-point) argument 'ERROR)))
+ "p"
+ (lambda (argument)
+ (upcase-area (forward-word (current-point) argument 'ERROR))))
-(define-command ("^R Lowercase Word" (argument 1))
+(define-command downcase-word
"Lowercase one or more words.
Moves forward over the words affected.
With a negative argument, lowercases words before point
but does not move point."
- (downcase-area (forward-word (current-point) argument 'ERROR)))
+ "p"
+ (lambda (argument)
+ (downcase-area (forward-word (current-point) argument 'ERROR))))
-(define-command ("^R Uppercase Initial" (argument 1))
+(define-command capitalize-word
"Put next word in lowercase, but capitalize initial.
With an argument, capitalizes that many words."
- (define (capitalize-one-word)
- (set-current-point! (forward-to-word (current-point) 'ERROR))
- (capitalize-area (forward-word (current-point) 1 'ERROR)))
- (cond ((positive? argument)
- (dotimes argument
- (lambda (i)
- i ;ignore
- (capitalize-one-word))))
- ((negative? argument)
- (let ((p (current-point)))
- (set-current-point! (forward-word p argument 'ERROR))
- (dotimes (- argument)
- (lambda (i)
- i ;ignore
- (capitalize-one-word)))
- (set-current-point! p)))))
+ "p"
+ (lambda (argument)
+ (define (capitalize-one-word)
+ (set-current-point! (forward-to-word (current-point) 'ERROR))
+ (capitalize-area (forward-word (current-point) 1 'ERROR)))
+ (cond ((positive? argument)
+ (dotimes argument
+ (lambda (i)
+ i ;ignore
+ (capitalize-one-word))))
+ ((negative? argument)
+ (let ((p (current-point)))
+ (set-current-point! (forward-word p argument 'ERROR))
+ (dotimes (- argument)
+ (lambda (i)
+ i ;ignore
+ (capitalize-one-word)))
+ (set-current-point! p))))))
\f
;;;; Sentences
-(define-command ("^R Forward Sentence" (argument 1))
+(define-command forward-sentence
"Move forward to next sentence-end. With argument, repeat.
With negative argument, move backward repeatedly to sentence-beginning.
Sentence ends are identified by the value of Sentence End
treated as a regular expression. Also, every paragraph boundary
terminates sentences as well."
- (move-thing forward-sentence argument))
+ "p"
+ (lambda (argument)
+ (move-thing forward-sentence argument)))
-(define-command ("^R Backward Sentence" (argument 1))
+(define-command backward-sentence
"Move backward to start of sentence. With arg, do it arg times.
-See \\[^R Forward Sentence] for more information."
- (move-thing backward-sentence argument))
+See \\[forward-sentence] for more information."
+ "p"
+ (lambda (argument)
+ (move-thing backward-sentence argument)))
-(define-command ("^R Mark Sentence")
+(define-command mark-sentence
"Put point at beginning and mark at end of sentence.
If you are between sentences, the following sentence is used
unless you are at the end of a paragraph."
- (let ((end (forward-sentence (current-point) 1 'ERROR)))
- (set-current-region! (make-region (backward-sentence end 1 'ERROR) end))))
+ ()
+ (lambda ()
+ (let ((end (forward-sentence (current-point) 1 'ERROR)))
+ (set-current-region!
+ (make-region (backward-sentence end 1 'ERROR) end)))))
-(define-command ("^R Kill Sentence" (argument 1))
+(define-command kill-sentence
"Kill forward to end of sentence.
Accepts numeric argument of either sign."
- (kill-thing forward-sentence argument))
+ "p"
+ (lambda (argument)
+ (kill-thing forward-sentence argument)))
-(define-command ("^R Backward Kill Sentence" (argument 1))
+(define-command backward-kill-sentence
"Kill backward to end of sentence.
Accepts numeric argument of either sign."
- (kill-thing backward-sentence argument))
+ "p"
+ (lambda (argument)
+ (kill-thing backward-sentence argument)))
\f
;;;; Paragraphs
-(define-command ("^R Forward Paragraph" (argument 1))
+(define-command forward-paragraph
"Move forward to end of paragraph.
-See documentation on ^R Backward Paragraph."
- (move-thing forward-paragraph argument))
+See documentation on \\[backward-paragraph]."
+ "p"
+ (lambda (argument)
+ (move-thing forward-paragraph argument)))
-(define-command ("^R Backward Paragraph" (argument 1))
+(define-command backward-paragraph
"Move backward to start of paragraph.
Paragraphs are delimited by blank lines or by lines which
-start with a delimiter in Paragraph Delimiter or Page Delimiter.
+ start with a delimiter in paragraph-delimiter or page-delimiter .
If there is a fill prefix, any line that doesn't start with it
-starts a paragraph.
-Lines which start with the any character in Text Justifier
-Escape Chars, if that character is matched by Paragraph Delimiter,
-count as blank lines in that they separate paragraphs and
-are not part of them."
- (move-thing backward-paragraph argument))
-
-(define-command ("^R Mark Paragraph")
+ starts a paragraph.
+Lines which start with the any character in text-justifier-escape-chars,
+ if that character is matched by paragraph-delimiter ,
+ count as blank lines in that they separate paragraphs and
+ are not part of them."
+ "p"
+ (lambda (argument)
+ (move-thing backward-paragraph argument)))
+
+(define-command mark-paragraph
"Put point and mark around this paragraph.
In between paragraphs, puts it around the next one.
-See ^R Backward Paragraph for paragraph definition."
- (let ((end (forward-paragraph (current-point) 1 'ERROR)))
- (set-current-region! (make-region (backward-paragraph end 1 'ERROR) end))))
\ No newline at end of file
+See \\[backward-paragraph] for paragraph definition."
+ ()
+ (lambda ()
+ (let ((end (forward-paragraph (current-point) 1 'ERROR)))
+ (set-current-region!
+ (make-region (backward-paragraph end 1 'ERROR) end)))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/things.scm,v 1.75 1989/03/14 08:03:22 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/things.scm,v 1.76 1989/04/15 00:53:32 cph Exp $
;;;
;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
(define (compute-horizontal-space c1 c2 receiver)
;; Compute the number of tabs/spaces required to fill from column C1
;; to C2 with whitespace. It is assumed that C1 >= C2.
- (if (ref-variable "Indent Tabs Mode")
- (let ((tab-width (ref-variable "Tab Width")))
+ (if (ref-variable indent-tabs-mode)
+ (let ((tab-width (ref-variable tab-width)))
(let ((qr1 (integer-divide c1 tab-width))
(qr2 (integer-divide c2 tab-width)))
(if (> (integer-divide-quotient qr1) (integer-divide-quotient qr2))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tparse.scm,v 1.63 1989/03/14 08:03:26 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tparse.scm,v 1.64 1989/04/15 00:53:37 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
\f
;;;; Pages
-(define-variable "Page Delimiter"
+(define-variable page-delimiter
"Regexp describing line-beginnings that separate pages."
"^\f")
(define (forward-one-page mark)
(and (not (group-end? mark))
- (or (re-search-forward (ref-variable "Page Delimiter") mark)
+ (or (re-search-forward (ref-variable page-delimiter) mark)
(group-end mark))))
(define (backward-one-page mark)
(and (not (group-start? mark))
- (if (re-search-backward (ref-variable "Page Delimiter") (mark-1+ mark))
+ (if (re-search-backward (ref-variable page-delimiter) (mark-1+ mark))
(re-match-end 0)
(group-start mark))))
(define (page-start mark)
- (let ((page-delimiter (ref-variable "Page Delimiter")))
+ (let ((page-delimiter (ref-variable page-delimiter)))
(or (re-match-forward page-delimiter (line-start mark 0))
(if (re-search-backward page-delimiter (mark-1+ mark))
(re-match-end 0)
\f
;;;; Paragraphs
-(define-variable "Paragraph Start"
+(define-variable paragraph-start
"Regexp for beginning of a line that starts OR separates paragraphs."
"^[ \t\n]")
-(define-variable "Paragraph Separate"
+(define-variable paragraph-separate
"Regexp for beginning of a line that separates paragraphs.
If you change this, you may have to change Paragraph Start also."
"^[ \t]*$")
(define (forward-one-paragraph mark)
(and (not (group-end? mark))
(let ((end (group-end mark))
- (fill-prefix (ref-variable "Fill Prefix"))
- (page-delimiter (ref-variable "Page Delimiter"))
+ (fill-prefix (ref-variable fill-prefix))
+ (page-delimiter (ref-variable page-delimiter))
(forward-kernel
(lambda (mark separator? skip-body)
(if (separator? (line-start mark 0))
skip-body)))))
(let ((prefix (string-append page-delimiter "\\|")))
(let ((start
- (string-append prefix (ref-variable "Paragraph Start")))
+ (string-append prefix (ref-variable paragraph-start)))
(separate
(string-append prefix
- (ref-variable "Paragraph Separate"))))
+ (ref-variable paragraph-separate))))
(forward-kernel mark
(lambda (mark)
(re-match-forward separate mark))
(define (backward-one-paragraph mark)
(and (not (group-start? mark))
(let ((start (group-start mark))
- (fill-prefix (ref-variable "Fill Prefix"))
- (page-delimiter (ref-variable "Page Delimiter"))
+ (fill-prefix (ref-variable fill-prefix))
+ (page-delimiter (ref-variable page-delimiter))
(backward-kernel
(lambda (mark separator? skip-body)
(if (separator? (line-start mark 0))
skip-body)))))
(let ((prefix (string-append page-delimiter "\\|")))
(let ((starter
- (string-append prefix (ref-variable "Paragraph Start")))
+ (string-append prefix (ref-variable paragraph-start)))
(separator
(string-append prefix
- (ref-variable "Paragraph Separate"))))
+ (ref-variable paragraph-separate))))
(backward-kernel mark
(lambda (mark)
(re-match-forward separator mark))
(define (paragraph-text-start mark)
(let ((start (backward-one-paragraph mark)))
(and start
- (let ((fill-prefix (ref-variable "Fill Prefix")))
+ (let ((fill-prefix (ref-variable fill-prefix)))
(if (and fill-prefix
(not (string-null? fill-prefix)))
(if (match-forward fill-prefix start)
start
(line-start start 1))
(let ((start
- (if (re-match-forward (ref-variable "Paragraph Separate")
+ (if (re-match-forward (ref-variable paragraph-separate)
start)
(line-start start 1)
start)))
\f
;;;; Sentences
-(define-variable "Sentence End"
+(define-variable sentence-end
"Regexp describing the end of a sentence.
All paragraph boundaries also end sentences, regardless."
"[.?!][]\")]*\\($\\|\t\\| \\)[ \t\n]*")
(define (forward-one-sentence mark)
(let ((end (paragraph-text-end mark)))
(and end
- (let ((mark (re-search-forward (ref-variable "Sentence End")
+ (let ((mark (re-search-forward (ref-variable sentence-end)
mark end)))
(if mark
(skip-chars-backward " \t\n" mark (re-match-start 0) false)
(define (backward-one-sentence mark)
(let ((start (paragraph-text-start mark)))
(and start
- (if (re-search-backward (string-append (ref-variable "Sentence End")
+ (if (re-search-backward (string-append (ref-variable sentence-end)
"[^ \t\n]")
mark start)
(mark-1+ (re-match-end 0))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tximod.scm,v 1.10 1989/03/14 08:03:31 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tximod.scm,v 1.11 1989/04/15 00:53:42 cph Exp $
;;;
;;; Copyright (c) 1987, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define-command ("Texinfo Mode")
+(define-command texinfo-mode
"Make the current mode be Texinfo mode."
- (set-current-major-mode! texinfo-mode))
+ ()
+ (lambda ()
+ (set-current-major-mode! (ref-mode-object texinfo))))
-(define-major-mode "Texinfo" "Text"
+(define-major-mode texinfo text "Texinfo"
"Major mode for editing texinfo files.
These are files that are input for TeX and also to be turned
-into Info files by \\[Texinfo Format Buffer].
+into Info files by \\[texinfo-format-buffer].
These files must be written in a very restricted and
modified version of TeX input format."
- (local-set-variable! "Syntax Table" texinfo-mode:syntax-table)
- (local-set-variable! "Fill Column" 75)
- (local-set-variable! "Require Final Newline" true)
- (local-set-variable! "Page Delimiter"
+ (local-set-variable! syntax-table texinfo-mode:syntax-table)
+ (local-set-variable! fill-column 75)
+ (local-set-variable! require-final-newline true)
+ (local-set-variable! page-delimiter
(string-append "^@node\\|"
- (ref-variable "Page Delimiter")))
- (local-set-variable! "Paragraph Start"
+ (ref-variable page-delimiter)))
+ (local-set-variable! paragraph-start
(string-append "^\b\\|^@[a-z]*[ \n]\\|"
- (ref-variable "Paragraph Start")))
- (local-set-variable! "Paragraph Separate"
+ (ref-variable paragraph-start)))
+ (local-set-variable! paragraph-separate
(string-append "^\b\\|^@[a-z]*[ \n]\\|"
- (ref-variable "Paragraph Separate")))
- (if (ref-variable "Texinfo Mode Hook") ((ref-variable "Texinfo Mode Hook"))))
-
-(define texinfo-mode:syntax-table
- (make-syntax-table))
+ (ref-variable paragraph-separate)))
+ (if (ref-variable texinfo-mode-hook) ((ref-variable texinfo-mode-hook))))
+(define texinfo-mode:syntax-table (make-syntax-table))
(modify-syntax-entry! texinfo-mode:syntax-table #\" " ")
(modify-syntax-entry! texinfo-mode:syntax-table #\\ " ")
(modify-syntax-entry! texinfo-mode:syntax-table #\@ "\\")
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/undo.scm,v 1.43 1989/03/14 08:03:33 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/undo.scm,v 1.44 1989/04/15 00:53:47 cph Exp $
;;;
;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
(define undo-command-tag "Undo")
-(define-command ("Undo" (argument 1))
+(define-command undo
"Undo some previous changes.
Repeat this command to undo more changes.
A numeric argument serves as a repeat count."
- (if (positive? argument)
- (let ((buffer (current-buffer)))
- (let ((undo-data (group-undo-data (buffer-group buffer))))
- (if (not undo-data)
- (editor-error "Undo information not kept for this buffer"))
- (without-interrupts
- (lambda ()
- (command-message-receive undo-command-tag
- (lambda ()
- (if (or (not (eq? last-undone-buffer buffer))
- (= -1 last-undone-record))
- (editor-error cant-undo-more)))
- (lambda ()
- (set! last-undone-buffer buffer)
- (set! number-records-undone 0)
- (set! number-chars-left
- (string-length (undo-data-chars undo-data)))
- (set! last-undone-record (undo-data-next-record undo-data))
- (set! last-undone-char (undo-data-next-char undo-data))
- ;; This accounts for the boundary that is inserted
- ;; just before this command is called.
- (set! argument (1+ argument))
- unspecific))
- (undo-n-records undo-data
- buffer
- (count-records-to-undo undo-data argument))))
- (set-command-message! undo-command-tag)
- (temporary-message "Undo!")))))
+ "p"
+ (lambda (argument)
+ (if (positive? argument)
+ (let ((buffer (current-buffer)))
+ (let ((undo-data (group-undo-data (buffer-group buffer))))
+ (if (not undo-data)
+ (editor-error "Undo information not kept for this buffer"))
+ (without-interrupts
+ (lambda ()
+ (command-message-receive undo-command-tag
+ (lambda ()
+ (if (or (not (eq? last-undone-buffer buffer))
+ (= -1 last-undone-record))
+ (editor-error cant-undo-more)))
+ (lambda ()
+ (set! last-undone-buffer buffer)
+ (set! number-records-undone 0)
+ (set! number-chars-left
+ (string-length (undo-data-chars undo-data)))
+ (set! last-undone-record (undo-data-next-record undo-data))
+ (set! last-undone-char (undo-data-next-char undo-data))
+ ;; This accounts for the boundary that is inserted
+ ;; just before this command is called.
+ (set! argument (1+ argument))
+ unspecific))
+ (undo-n-records undo-data
+ buffer
+ (count-records-to-undo undo-data argument))))
+ (set-command-message! undo-command-tag)
+ (temporary-message "Undo!"))))))
\f
(define (count-records-to-undo undo-data argument)
(let ((records (undo-data-records undo-data)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/unix.scm,v 1.2 1989/03/15 19:15:20 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/unix.scm,v 1.3 1989/04/15 00:53:52 cph Exp $
;;;
;;; Copyright (c) 1989 Massachusetts Institute of Technology
;;;
(wrap (pathname-name-string pathname)
(pathname-directory-path pathname)))))
-(define-variable "Backup By Copying When Linked"
+(define-variable backup-by-copying-when-linked
"*Non-false means use copying to create backups for files with multiple names.
This causes the alternate names to refer to the latest version as edited.
This variable is relevant only if Backup By Copying is false."
false)
-(define-variable "Backup By Copying When Mismatch"
+(define-variable backup-by-copying-when-mismatch
"*Non-false means create backups by copying if this preserves owner or group.
Renaming may still be used (subject to control of other variables)
when it would not result in changing the owner or group of the file;
This variable is relevant only if Backup By Copying is false."
false)
-(define-variable "Version Control"
+(define-variable version-control
"*Control use of version numbers for backup files.
#T means make numeric backup versions unconditionally.
#F means make them for files that have some already.
'NEVER means do not make them."
false)
-(define-variable "Kept Old Versions"
+(define-variable kept-old-versions
"*Number of oldest versions to keep when a new numbered backup is made."
2)
-(define-variable "Kept New Versions"
+(define-variable kept-new-versions
"*Number of newest versions to keep when a new numbered backup is made.
Includes the new backup. Must be > 0"
2)
\f
(define (os/backup-by-copying? truename)
(let ((attributes (file-attributes truename)))
- (and (ref-variable "Backup By Copying When Linked")
+ (and (ref-variable backup-by-copying-when-linked)
(> (file-attributes/n-links attributes) 1))
- (and (ref-variable "Backup By Copying When Mismatch")
+ (and (ref-variable backup-by-copying-when-mismatch)
(not (and (= (file-attributes/uid attributes) (unix/current-uid))
(= (file-attributes/gid attributes) (unix/current-gid)))))))
(values
(string->pathname (string-append (pathname->string truename) "~"))
'()))))
- (if (eq? 'NEVER (ref-variable "Version Control"))
+ (if (eq? 'NEVER (ref-variable version-control))
(no-versions)
- (let ((non-numeric (char-set-invert char-set:numeric))
- (directory (pathname-directory-path truename))
- (prefix (string-append (pathname-name-string truename) ".~")))
- (let ((prefix-length (string-length prefix)))
- (let ((filenames
- (map pathname-name-string
- (directory-read directory false))))
+ (let ((prefix (string-append (pathname-name-string truename) ".~")))
+ (let ((filenames
+ (os/directory-list-completions
+ (pathname-directory-string truename)
+ prefix))
+ (prefix-length (string-length prefix)))
(let ((possibilities
(list-transform-positive filenames
- (lambda (filename)
- (let ((end (string-length filename)))
- (let ((last (-1+ end)))
- (and (string-prefix? prefix filename)
- (char=? #\~ (string-ref filename last))
- (eqv? last
- (substring-find-next-char-in-set
- filename
- prefix-length
- end
- non-numeric)))))))))
+ (let ((non-numeric (char-set-invert char-set:numeric)))
+ (lambda (filename)
+ (let ((end (string-length filename)))
+ (let ((last (-1+ end)))
+ (and (char=? #\~ (string-ref filename last))
+ (eqv? last
+ (substring-find-next-char-in-set
+ filename
+ prefix-length
+ end
+ non-numeric))))))))))
(let ((versions
(sort (map (lambda (filename)
(string->number
possibilities)
<)))
(let ((high-water-mark (apply max (cons 0 versions))))
- (if (or (ref-variable "Version Control")
+ (if (or (ref-variable version-control)
(positive? high-water-mark))
(let ((version->pathname
- (lambda (version)
- (merge-pathnames
- (string->pathname
- (string-append prefix
- (number->string version)
- "~"))
- directory))))
+ (let ((directory
+ (pathname-directory-path truename)))
+ (lambda (version)
+ (merge-pathnames
+ (string->pathname
+ (string-append prefix
+ (number->string version)
+ "~"))
+ directory)))))
(values
(version->pathname (1+ high-water-mark))
- (let ((start
- (ref-variable "Kept Old Versions"))
+ (let ((start (ref-variable kept-old-versions))
(end
(- (length versions)
- (-1+ (ref-variable "Kept New Versions")))))
+ (-1+ (ref-variable kept-new-versions)))))
(if (< start end)
(map version->pathname
(sublist versions start end))
'()))))
- (no-versions)))))))))))
+ (no-versions))))))))))
\f
(define (os/make-dired-line pathname)
(let ((attributes (file-attributes pathname)))
(define (os/dired-filename-region lstart)
(let ((lend (line-end lstart 0)))
- (char-search-backward #\Space lend lstart 'LIMIT) (make-region (re-match-end 0) lend)))
\ No newline at end of file
+ (char-search-backward #\Space lend lstart 'LIMIT) (make-region (re-match-end 0) lend)))
+
+(define (os/directory-list directory)
+ (let loop
+ ((name ((ucode-primitive open-directory) directory))
+ (result '()))
+ (if name
+ (loop ((ucode-primitive directory-read)) (cons name result))
+ result)))
+
+(define (os/directory-list-completions directory prefix)
+ (let loop
+ ((name ((ucode-primitive open-directory) directory))
+ (result '()))
+ (if name
+ (loop ((ucode-primitive directory-read))
+ (if (string-prefix? prefix name) (cons name result) result))
+ result)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/utils.scm,v 1.11 1989/04/05 18:23:37 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/utils.scm,v 1.12 1989/04/15 00:53:57 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(substring-move-right! string2 start2 end2 result length1)
result)))
+(define (string-greatest-common-prefix strings)
+ (let loop
+ ((strings (cdr strings))
+ (string (car strings))
+ (index (string-length (car strings))))
+ (if (null? strings)
+ (substring string 0 index)
+ (let ((string* (car strings)))
+ (let ((index*
+ (string-match-forward string string*)))
+ (if (< index* index)
+ (loop (cdr strings) string* index*)
+ (loop (cdr strings) string index)))))))
+
+(define (xchar->name char)
+ (if (pair? char)
+ (chars->name char)
+ (char-name char)))
+
+(define (chars->name chars)
+ (if (null? chars)
+ ""
+ (string-append-separated (char-name (car chars))
+ (chars->name (cdr chars)))))
+
+(define (string-append-separated x y)
+ (cond ((string-null? x) y)
+ ((string-null? y) x)
+ (else (string-append x " " y))))
(define (dotimes n procedure)
(define (loop i)
(if (< i n)
(define char-set:not-graphic
(char-set-invert char-set:graphic))
-
+\f
(define (read-line #!optional port)
(read-string char-set:return
(if (default-object? port)
(current-input-port)
(guarantee-input-port port))))
+(define (read-from-string string)
+ (with-input-from-string string read))
(define (y-or-n? . strings)
(define (loop)
(let ((char (char-upcase (read-char))))
(let ((bits (char-bits char)))
(if (odd? (quotient bits 2)) bits (+ bits 2))))))
+(define (char-controlified? char)
+ (or (ascii-controlified? char)
+ (odd? (quotient (char-bits char) 2))))
+
(define (char-metafy char)
(make-char (char-code char)
(let ((bits (char-bits char)))
(if (odd? bits) bits (1+ bits)))))
+(define-integrable (char-metafied? char)
+ (odd? (char-bits char)))
+
(define (char-control-metafy char)
(char-controlify (char-metafy char)))
(define (char-base char)
- (make-char (char-code char) 0))
\ No newline at end of file
+ (make-char (char-code char) 0))
+
+(define (catch-file-errors if-error thunk)
+ (call-with-current-continuation
+ (lambda (continuation)
+ (bind-condition-handler
+ (list error-type:file)
+ (lambda (condition)
+ condition
+ (continuation (if-error)))
+ thunk))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/wincom.scm,v 1.90 1989/03/30 16:40:11 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/wincom.scm,v 1.91 1989/04/15 00:54:03 cph Exp $
;;;
;;; Copyright (c) 1987, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define-variable "Cursor Centering Point"
+(define-variable cursor-centering-point
"The distance from the top of the window at which to center the point.
This number is a percentage, where 0 is the window's top and 100 the bottom."
35)
-(define-variable "Cursor Centering Threshold"
+(define-variable cursor-centering-threshold
"If point moves offscreen by more than this many lines, recenter.
Otherwise, the screen is scrolled to put point at the edge it moved over."
0)
-(define-variable "Window Minimum Width"
+(define-variable window-minimum-width
"Delete any window less than this wide.
Do not set this variable below 2."
2)
-(define-variable "Window Minimum Height"
+(define-variable window-minimum-height
"Delete any window less than this high.
The modeline is not included in this figure.
Do not set this variable below 1."
1)
-(define-variable "Next Screen Context Lines"
+(define-variable next-screen-context-lines
"Number of lines of continuity when scrolling by screenfuls."
2)
-(define-variable "Mode Line Inverse Video"
+(define-variable mode-line-inverse-video
"If true, the mode line is highlighted."
true)
-(define-command ("^R New Window" argument)
+(define-variable pop-up-windows
+ "If false, this disables the use of pop-up windows."
+ true)
+
+(define-variable preserve-window-arrangement
+ "If true, commands that normally change the window arrangement do not."
+ false)
+
+(define-variable split-height-threshold
+ "Pop-up windows prefer to split the largest window if it is this large.
+If there is only one window, it is split regardless of this value."
+ 500)
+\f
+(define-command redraw-display
+ "Redraws the entire display from scratch."
+ ()
+ (lambda ()
+ (update-screens! true)))
+
+(define-command recenter
"Choose new window putting point at center, top or bottom.
With no argument, chooses a window to put point at the center
-\(\"Cursor Centering Point\" says where).
+\(cursor-centering-point says where).
An argument gives the line to put point on;
-negative args count from the bottom.
-C-U as argument redisplays the line containing point."
- (let ((window (current-window)))
- (let ((size (window-y-size window)))
+negative args count from the bottom."
+ "P"
+ (lambda (argument)
+ (let ((window (current-window)))
(if (not argument)
(begin
(window-redraw! window false)
- (update-window-screen! window true))
+ (update-screens! true))
(window-scroll-y-absolute! window
- (let ((n (remainder argument size)))
- (if (negative? n)
- (+ n size)
- n)))))))
-
-(define-command ("^R Move to Screen Edge" argument)
- "Jump to top or bottom of screen.
-Like \\[^R New Window] except that point is changed instead of the window.
-With no argument, jumps to the center, according to \"Cursor Centering Point\".
-An argument specifies the number of lines from the top;
-negative args count from the bottom."
- (let ((window (current-window)))
- (let ((mark
- (or (window-coordinates->mark
- window 0
- (if (not argument)
- (window-y-center window)
- (let ((y-size (window-y-size window)))
- (let ((n (remainder argument y-size)))
- (if (negative? n)
- (+ n y-size)
- n)))))
- (window-coordinates->mark
- window 0
- (window-mark->y window
- (buffer-end (window-buffer window)))))))
- (set-current-point! (if (group-start? mark)
- (group-start mark)
- mark)))))
+ (let ((size (window-y-size window)))
+ (let ((n (remainder argument size)))
+ (if (negative? n)
+ (+ n size)
+ n))))))))
+
+(define-command move-to-window-line
+ "Position point relative to window.
+With no argument, position at text at center of window.
+An argument specifies screen line; zero means top of window,
+negative means relative to bottom of window."
+ "P"
+ (lambda (argument)
+ (let ((window (current-window)))
+ (let ((mark
+ (or (window-coordinates->mark
+ window 0
+ (if (not argument)
+ (window-y-center window)
+ (let ((y-size (window-y-size window)))
+ (let ((n (remainder argument y-size)))
+ (if (negative? n)
+ (+ n y-size)
+ n)))))
+ (window-coordinates->mark
+ window 0
+ (window-mark->y window
+ (buffer-end (window-buffer window)))))))
+ (set-current-point! (if (group-start? mark)
+ (group-start mark)
+ mark))))))
\f
-(define-command ("^R Next Screen" argument)
+(define-command scroll-up
"Move down to display next screenful of text.
With argument, moves window down that many lines (negative moves up).
Just minus as an argument moves up a full screen."
- (let ((window (current-window)))
- (scroll-window window
- (standard-scroll-window-argument window argument 1))))
+ "P"
+ (lambda (argument)
+ (let ((window (current-window)))
+ (scroll-window window
+ (standard-scroll-window-argument window argument 1)))))
-(define-command ("^R Previous Screen" argument)
+(define-command scroll-down
"Move up to display previous screenful of text.
With argument, moves window up that many lines (negative moves down).
Just minus as an argument moves down a full screen."
- (let ((window (current-window)))
- (scroll-window window
- (standard-scroll-window-argument window argument -1))))
+ "P"
+ (lambda (argument)
+ (let ((window (current-window)))
+ (scroll-window window
+ (standard-scroll-window-argument window argument -1)))))
-(define-command ("^R Next Several Screens" argument)
+(define-command scroll-up-several-screens
"Move down to display next screenful of text.
With argument, move window down that many screenfuls (negative moves up).
Just minus as an argument moves up a full screen."
- (let ((window (current-window)))
- (scroll-window window
- (multi-scroll-window-argument window argument 1))))
+ "P"
+ (lambda (argument)
+ (let ((window (current-window)))
+ (scroll-window window
+ (multi-scroll-window-argument window argument 1)))))
-(define-command ("^R Previous Several Screens" argument)
+(define-command scroll-down-several-screens
"Move up to display previous screenful of text.
With argument, move window down that many screenfuls (negative moves down).
Just minus as an argument moves down full screen."
- (let ((window (current-window)))
- (scroll-window window
- (multi-scroll-window-argument window argument -1))))
+ "P"
+ (lambda (argument)
+ (let ((window (current-window)))
+ (scroll-window window
+ (multi-scroll-window-argument window argument -1)))))
(define (scroll-window window n #!optional limit)
(if (if (negative? n)
(* factor
(let ((quantum
(- (window-y-size window)
- (ref-variable "Next Screen Context Lines"))))
+ (ref-variable next-screen-context-lines))))
(cond ((not argument) quantum)
((command-argument-negative-only?) (- quantum))
(else argument)))))
(* factor
(let ((quantum
(- (window-y-size window)
- (ref-variable "Next Screen Context Lines"))))
+ (ref-variable next-screen-context-lines))))
(cond ((not argument) quantum)
- ((command-argument-negative-only?)
- (- quantum))
+ ((command-argument-negative-only?) (- quantum))
(else (* argument quantum))))))
\f
-(define-command ("^R Screen Video" (argument 0))
+(define-command toggle-screen-video
"Toggle the screen's use of inverse video.
With a positive argument, inverse video is forced.
With a negative argument, normal video is forced."
- (screen-inverse-video!
- (current-screen)
- (or (positive? argument)
- (not (or (negative? argument)
- (screen-inverse-video!
- (current-screen)
- false)))))
- (update-screens! true))
-
-(define-command ("What Cursor Position")
+ "P"
+ (lambda (argument)
+ (screen-inverse-video!
+ (current-screen)
+ (if (not argument)
+ (screen-inverse-video! (current-screen) false)
+ (positive? argument)))
+ (update-screens! true)))
+
+(define-command what-cursor-position
"Print various things about where cursor is.
Print the X position, the Y position,
the ASCII code for the following character,
point absolutely and as a percentage of the total file size,
and the virtual boundaries, if any."
- (let ((buffer (current-buffer))
- (point (current-point)))
- (let ((position (mark-index point))
- (total (group-length (buffer-group buffer))))
- (message (if (group-end? point)
- ""
- (let ((char (mark-right-char point)))
- (string-append "Char: " (char-name char)
- " (0"
- (number->string (char->ascii char)
- '(HEUR (RADIX O S)
- (EXACTNESS S)))
- ") ")))
- "point=" (write-to-string position)
- " of " (write-to-string total)
- "("
- (write-to-string (if (zero? total)
- 0
- (round (* 100 (/ position total)))))
- "%) "
- (let ((group (mark-group point)))
- (let ((start (group-start-index group))
- (end (group-end-index group)))
- (if (and (zero? start) (= end total))
- ""
- (string-append "<" (write-to-string start)
- " - " (write-to-string end)
- "> "))))
- "x=" (write-to-string (mark-column point))))))
+ ()
+ (lambda ()
+ (let ((buffer (current-buffer))
+ (point (current-point)))
+ (let ((position (mark-index point))
+ (total (group-length (buffer-group buffer))))
+ (message (if (group-end? point)
+ ""
+ (let ((char (mark-right-char point)))
+ (string-append "Char: " (char-name char)
+ " (0"
+ (number->string (char->ascii char)
+ '(HEUR (RADIX O S)
+ (EXACTNESS S)))
+ ") ")))
+ "point=" (write-to-string position)
+ " of " (write-to-string total)
+ "("
+ (write-to-string (if (zero? total)
+ 0
+ (round (* 100 (/ position total)))))
+ "%) "
+ (let ((group (mark-group point)))
+ (let ((start (group-start-index group))
+ (end (group-end-index group)))
+ (if (and (zero? start) (= end total))
+ ""
+ (string-append "<" (write-to-string start)
+ " - " (write-to-string end)
+ "> "))))
+ "x=" (write-to-string (mark-column point)))))))
\f
;;;; Multiple Windows
-(define-command ("^R Split Window Vertically" argument)
+(define-command split-window-vertically
"Split current window into two windows, one above the other.
This window becomes the uppermost of the two, and gets
ARG lines. No arg means split equally."
- (disallow-typein)
- (window-split-vertically! (current-window) argument))
+ "P"
+ (lambda (argument)
+ (disallow-typein)
+ (window-split-vertically! (current-window) argument)))
-(define-command ("^R Split Window Horizontally" argument)
+(define-command split-window-horizontally
"Split current window into two windows side by side.
This window becomes the leftmost of the two, and gets
ARG lines. No arg means split equally."
- (disallow-typein)
- (window-split-horizontally! (current-window) argument))
+ "P"
+ (lambda (argument)
+ (disallow-typein)
+ (window-split-horizontally! (current-window) argument)))
-(define-command ("^R Enlarge Window Vertically" (argument 1))
+(define-command enlarge-window
"Makes current window ARG lines bigger."
- (disallow-typein)
- (window-grow-vertically! (current-window) argument))
+ "p"
+ (lambda (argument)
+ (disallow-typein)
+ (window-grow-vertically! (current-window) argument)))
-(define-command ("^R Shrink Window Vertically" (argument 1))
+(define-command shrink-window
"Makes current window ARG lines smaller."
- (disallow-typein)
- (window-grow-vertically! (current-window) (- argument)))
+ "p"
+ (lambda (argument)
+ (disallow-typein)
+ (window-grow-vertically! (current-window) (- argument))))
-(define-command ("^R Enlarge Window Horizontally" (argument 1))
+(define-command enlarge-window-horizontally
"Makes current window ARG columns wider."
- (disallow-typein)
- (window-grow-horizontally! (current-window) argument))
+ "p"
+ (lambda (argument)
+ (disallow-typein)
+ (window-grow-horizontally! (current-window) argument)))
-(define-command ("^R Shrink Window Horizontally" (argument 1))
+(define-command shrink-window-horizontally
"Makes current window ARG columns narrower."
- (disallow-typein)
- (window-grow-horizontally! (current-window) (- argument)))
+ "p"
+ (lambda (argument)
+ (disallow-typein)
+ (window-grow-horizontally! (current-window) (- argument))))
-(define-command ("^R Delete Window")
+(define-command delete-window
"Delete the current window from the screen."
- (window-delete! (current-window)))
+ ()
+ (lambda ()
+ (window-delete! (current-window))))
-(define-command ("^R Delete Other Windows")
+(define-command delete-other-windows
"Make the current window fill the screen."
- (delete-other-windows (current-window)))
+ ()
+ (lambda ()
+ (delete-other-windows (current-window))))
-(define-command ("^R Other Window" argument)
+(define-command other-window
"Select the ARG'th different window."
- (select-window (other-window-interactive argument)))
+ "P"
+ (lambda (argument)
+ (select-window (other-window-interactive argument))))
(define (other-window-interactive n)
(let ((window (other-window n)))
(define (disallow-typein)
(if (typein-window? (current-window))
(editor-error "Not implemented for typein window")))
-
-(define-command ("^R Scroll Other Window" argument)
+\f
+(define-command scroll-other-window
"Scroll text of next window up ARG lines, or near full screen if no arg."
- (let ((window (other-window-interactive 1)))
- (scroll-window window
- (standard-scroll-window-argument window argument 1))))
+ "P"
+ (lambda (argument)
+ (let ((window (other-window-interactive 1)))
+ (scroll-window window
+ (standard-scroll-window-argument window argument 1)))))
-(define-command ("^R Scroll Other Window Several Screens" argument)
+(define-command scroll-other-window-several-screens
"Scroll other window up several screenfuls.
Specify the number as a numeric argument, negative for down.
The default is one screenful up. Just minus as an argument
means scroll one screenful down."
- (let ((window (other-window-interactive 1)))
- (scroll-window window
- (multi-scroll-window-argument window argument 1))))
+ "P"
+ (lambda (argument)
+ (let ((window (other-window-interactive 1)))
+ (scroll-window window
+ (multi-scroll-window-argument window argument 1)))))
\f
;;;; Pop-up Buffers
-(define-variable "Pop Up Windows"
- "If false, this disables the use of pop-up windows."
- true)
-
-(define-variable "Preserve Window Arrangement"
- "If true, commands that normally change the window arrangement do not."
- false)
-
-(define-variable "Split Height Threshold"
- "Pop-up windows prefer to split the largest window if it is this large.
-If there is only one window, it is split regardless of this value."
- 500)
-
-(define-command ("Kill Pop Up Buffer")
+(define-command kill-pop-up-buffer
"Kills the most recently popped up buffer, if one exists.
Also kills any pop up window it may have created."
- (let ((buffer (object-unhash *previous-popped-up-buffer*))
- (window (object-unhash *previous-popped-up-window*)))
+ ()
+ (lambda ()
+ (kill-pop-up-buffer true)))
+
+(define (cleanup-pop-up-buffers thunk)
+ (fluid-let ((*previous-popped-up-window* (object-hash false))
+ (*previous-popped-up-buffer* (object-hash false)))
+ (dynamic-wind (lambda () unspecific)
+ thunk
+ kill-pop-up-buffer)))
+
+(define (kill-pop-up-buffer #!optional error-if-none?)
+ (let ((window (object-unhash *previous-popped-up-window*)))
(if (and window (window-visible? window))
- (window-delete! window))
- (if (and buffer (buffer-alive? buffer))
- (kill-buffer-interactive buffer)
- (editor-error "No previous pop up buffer"))))
+ (begin
+ (set! *previous-popped-up-window* (object-hash false))
+ (window-delete! window)))) (let ((buffer (object-unhash *previous-popped-up-buffer*)))
+ (cond ((and buffer (buffer-alive? buffer))
+ (set! *previous-popped-up-buffer* (object-hash false))
+ (kill-buffer-interactive buffer))
+ ((and (not (default-object? error-if-none?)) error-if-none?)
+ (editor-error "No previous pop up buffer")))))
(define *previous-popped-up-buffer* (object-hash false))
(define *previous-popped-up-window* (object-hash false))
-
+\f
(define (pop-up-buffer buffer #!optional select?)
;; If some new window is created by this procedure, it is returned
;; as the value. Otherwise the value is false.
(let ((select? (and (not (default-object? select?)) select?)))
+
(define (pop-up-window window)
(let ((window (window-split-vertically! window false)))
(pop-into-window window)
window))
+
(define (pop-into-window window)
(set-window-buffer! window buffer true)
+ (maybe-record-window window))
+
+ (define (maybe-record-window window)
(if select? (select-window window))
- false)
- (if (< (ref-variable "Window Minimum Height") 2)
- (set-variable! "Window Minimum Height" 2))
+ (and (eq? window (object-unhash *previous-popped-up-window*))
+ window))
+
+ (if (< (ref-variable window-minimum-height) 2)
+ (set-variable! window-minimum-height 2))
(let ((window
(let ((window (get-buffer-window buffer)))
(if window
- (begin (set-window-point! window (buffer-point buffer))
- (if select? (select-window window))
- false)
- (let ((limit (* 2 (ref-variable "Window Minimum Height"))))
- (if (< (ref-variable "Split Height Threshold") limit)
- (set-variable! "Split Height Threshold" limit))
- (cond ((ref-variable "Preserve Window Arrangement")
+ (begin
+ (set-window-point! window (buffer-point buffer))
+ (maybe-record-window window))
+ (let ((limit (* 2 (ref-variable window-minimum-height))))
+ (if (< (ref-variable split-height-threshold) limit)
+ (set-variable! split-height-threshold limit))
+ (cond ((ref-variable preserve-window-arrangement)
(pop-into-window (largest-window)))
- ((ref-variable "Pop Up Windows")
- (or (let ((window (largest-window)))
- (and (>= (window-y-size window)
- (ref-variable
- "Split Height Threshold"))
+ ((ref-variable pop-up-windows)
+ (let ((window (largest-window)))
+ (if (and (>= (window-y-size window)
+ (ref-variable split-height-threshold))
(not
- (window-has-horizontal-neighbor? window))
- (pop-up-window window)))
- (let ((window (lru-window))
- (current (current-window)))
- (if (and (or (eq? window current)
- (and (typein-window? current)
- (eq? window
- (window1+ window))))
- (>= (window-y-size window) limit))
- (pop-up-window window)
- (pop-into-window window)))))
+ (window-has-horizontal-neighbor?
+ window)))
+ (pop-up-window window)
+ (let ((window (lru-window))
+ (current (current-window)))
+ (if (and (or (eq? window current)
+ (and (typein-window? current)
+ (eq? window
+ (window1+ window))))
+ (>= (window-y-size window) limit))
+ (pop-up-window window)
+ (pop-into-window window))))))
(else
(pop-into-window (lru-window)))))))))
(set! *previous-popped-up-window* (object-hash window))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rgxcmp.scm,v 1.99 1989/03/14 08:02:16 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rgxcmp.scm,v 1.100 1989/04/15 00:52:39 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;; Matches any one character except for newline.
any-char
-
+\f
;; Matches any one char belonging to specified set. First following
;; byte is # bitmap bytes. Then come bytes for a bit-map saying
;; which chars are in. Bits in each byte are ordered low-bit-first.
(define-integrable stack-maximum-length
re-number-of-registers)
+(define error-type:re-compile-pattern
+ (make-error-type '() "Error compiling regular expression:"))
+
(define input-list)
(define current-byte)
(define translation-table)
(if fixup-jump
(store-jump! fixup-jump re-code:jump (output-position)))
(if (not (stack-empty?))
- (error "Unmatched \\("))
+ (error error-type:re-compile-pattern "Unmatched \\("))
(list->string (map ascii->char (cdr output-head))))
(begin
(compile-pattern-char)
((vector-ref pattern-chars (input-peek-1))))
(define (premature-end)
- (error "Premature end of regular expression"))
+ (error error-type:re-compile-pattern "Premature end of regular expression"))
(define (normal-char)
(if (if (input-end?)
(define-backslash-char #\(
(lambda ()
(if (stack-full?)
- (error "Nesting too deep"))
+ (error error-type:re-compile-pattern "Nesting too deep"))
(if (< register-number re-number-of-registers)
(begin
(output-re-code! re-code:start-memory)
(define-backslash-char #\)
(lambda ()
(if (stack-empty?)
- (error "Unmatched close paren"))
+ (error error-type:re-compile-pattern "Unmatched close paren"))
(if fixup-jump
(store-jump! fixup-jump re-code:jump (output-position)))
(stack-pop!
projects / mit-scheme.git / commitdiff