;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/argred.scm,v 1.31 1991/08/06 15:39:54 arthur Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/argred.scm,v 1.32 1991/10/21 23:40:21 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
Used more than once, this command multiplies the argument by 4 each time."
"P"
(lambda (argument)
- (set-command-argument! (list (* (if (pair? argument) (car argument) 1) 4)))
- (set-command-message! 'AUTO-ARGUMENT (key-name (last-command-key)))))
+ (set-command-argument! (list (* (if (pair? argument) (car argument) 1) 4))
+ (key-name (last-command-key)))))
(define-command digit-argument
"Part of the numeric argument for the next command."
"P"
(lambda (argument)
- (let ((key (last-command-key)))
- (if (char? key)
- (let ((digit (char->digit (char-base key))))
- (if digit
- (begin
- (set-command-argument!
- (cond ((eq? '- argument) (- digit))
- ((not (number? argument)) digit)
- ((negative? argument) (- (* 10 argument) digit))
- (else (+ (* 10 argument) digit))))
- (set-command-message! 'AUTO-ARGUMENT
- (auto-argument-mode?)))))))))
+ (digit-argument argument (auto-argument-mode?))))
+
+(define (digit-argument argument mode)
+ (let ((key (last-command-key)))
+ (if (char? key)
+ (let ((digit (char->digit (char-base key))))
+ (if digit
+ (set-command-argument!
+ (cond ((eq? '- argument) (- digit))
+ ((not (number? argument)) digit)
+ ((negative? argument) (- (* 10 argument) digit))
+ (else (+ (* 10 argument) digit)))
+ mode))))))
(define-command negative-argument
"Begin a negative numeric argument for the next command."
"P"
(lambda (argument)
- (set-command-argument!
- (cond ((eq? '- argument) false)
- ((number? argument) (- argument))
- (else '-)))
- (set-command-message! 'AUTO-ARGUMENT (auto-argument-mode?))))
+ (negative-argument argument (auto-argument-mode?))))
+
+(define (negative-argument argument mode)
+ (set-command-argument! (cond ((eq? '- argument) false)
+ ((number? argument) (- argument))
+ (else '-))
+ mode))
+
+(define-command auto-argument
+ "Start a command argument.
+Digits following this command become part of the argument."
+ "P"
+ (lambda (argument)
+ (let ((mode (if argument (auto-argument-mode?) true)))
+ (if (let ((key (last-command-key)))
+ (and (char? key)
+ (char=? #\- (char-base key))))
+ (if (not (number? argument))
+ (negative-argument argument mode))
+ (digit-argument argument mode)))))
(define-command auto-digit-argument
"When reading a command argument, part of the numeric argument.
(not (number? argument)))
((ref-command negative-argument) argument)
((ref-command self-insert-command) argument))))
-
-(define-command auto-argument
- "Start a command argument.
-Digits following this command become part of the argument."
- "P"
- (lambda (argument)
- (if (let ((key (last-command-key)))
- (and (char? key)
- (char=? #\- (char-base key))))
- (if (not (number? argument))
- ((ref-command negative-argument) argument))
- ((ref-command digit-argument) argument))
- (if (not argument)
- (set-command-message! 'AUTO-ARGUMENT true))))
\f
(define (command-argument-self-insert? command)
(and (or (eq? command (ref-command-object auto-digit-argument))
(not (number? (command-argument)))))
(not (auto-argument-mode?))))
-(define (auto-argument-mode?)
- (command-message-receive 'AUTO-ARGUMENT (lambda (x) x) (lambda () false)))
-
(define (command-argument-prompt)
(let ((arg (command-argument)))
(if (not arg)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comred.scm,v 1.87 1991/08/06 15:40:25 arthur Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comred.scm,v 1.88 1991/10/21 23:40:40 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(define *command-continuation*) ;Continuation of current command
(define *command-key*) ;Key read to find current command
(define *command*) ;The current command
+(define *last-command*) ;The previous command, excluding arg commands
(define *command-argument*) ;Argument from last command
(define *next-argument*) ;Argument to next command
(define *command-message*) ;Message from last command
(lambda (continuation)
(fluid-let ((*command-continuation* continuation)
(*command-key* false)
- (*command*)
+ (*command* false)
(*next-argument* false)
(*next-message* false))
(bind-condition-handler (list condition-type:editor-error)
(set! *command-key* key)
(clear-message)
(set-command-prompt!
- (if (not *command-argument*)
+ (if (not (command-argument))
(key-name key)
(string-append-separated (command-argument-prompt)
(key-name key))))
false)))
(start-next-command))
- (fluid-let ((*command-argument*)
+ (fluid-let ((*last-command* false)
+ (*command-argument*)
(*command-message*)
(*non-undo-count* 0))
(if (and (not (default-object? initialization)) initialization)
(command-reader-loop)))
(define (reset-command-state!)
+ (set! *last-command* *command*)
+ (set! *command* false)
(set! *command-argument* *next-argument*)
(set! *next-argument* false)
(set! *command-message* *next-message*)
(set! *next-message* false)
- (if *command-argument*
+ (if (command-argument)
(set-command-prompt! (command-argument-prompt))
(reset-command-prompt!))
- (if *defining-keyboard-macro?* (keyboard-macro-finalize-keys)))
+ (if *defining-keyboard-macro?*
+ (keyboard-macro-finalize-keys)))
\f
-;;; The procedures for executing commands come in two flavors. The
-;;; difference is that the EXECUTE-foo procedures reset the command
-;;; state first, while the DISPATCH-ON-foo procedures do not. The
-;;; latter should only be used by "prefix" commands such as C-X or
-;;; C-4, since they want arguments, messages, etc. to be passed on.
-
-(define-integrable (execute-key comtab key)
- (reset-command-state!)
- (dispatch-on-key comtab key))
-
-(define-integrable (execute-command command)
- (reset-command-state!)
- (%dispatch-on-command (current-window) command false))
-
-(define (read-and-dispatch-on-key)
- (dispatch-on-key (current-comtabs)
- (with-editor-interrupts-disabled keyboard-read)))
-
-(define (dispatch-on-key comtab key)
- (set! *command-key* key)
- (set-command-prompt!
- (string-append-separated (command-argument-prompt) (xkey->name key)))
- (%dispatch-on-command (current-window) (comtab-entry comtab key) false))
-
-(define (dispatch-on-command command #!optional record?)
- (%dispatch-on-command (current-window)
- command
- (if (default-object? record?) false record?)))
-
(define (abort-current-command #!optional value)
(keyboard-macro-disable)
(*command-continuation* (if (default-object? value) 'ABORT value)))
*command-key*
(car (last-pair *command-key*))))
+(define (set-current-command! command)
+ (set! *command* command)
+ unspecific)
+
(define-integrable (current-command)
*command*)
-(define (set-command-argument! argument)
- (set! *next-argument* argument)
+(define-integrable (last-command)
+ *last-command*)
+
+(define (set-command-argument! argument mode)
+ (set! *next-argument* (cons argument mode))
+ ;; Preserve message and last command.
+ (set! *next-message* *command-message*)
+ (set! *command* *last-command*)
unspecific)
(define-integrable (command-argument)
- *command-argument*)
+ (and *command-argument* (car *command-argument*)))
+
+(define (auto-argument-mode?)
+ (and *command-argument* (cdr *command-argument*)))
(define (set-command-message! tag . arguments)
(set! *next-message* (cons tag arguments))
'()
(loop history))))))
\f
+;;; The procedures for executing commands come in two flavors. The
+;;; difference is that the EXECUTE-foo procedures reset the command
+;;; state first, while the DISPATCH-ON-foo procedures do not. The
+;;; latter should only be used by "prefix" commands such as C-X or
+;;; C-4, since they want arguments, messages, etc. to be passed on.
+
+(define-integrable (execute-key comtab key)
+ (reset-command-state!)
+ (dispatch-on-key comtab key))
+
+(define-integrable (execute-command command)
+ (reset-command-state!)
+ (%dispatch-on-command (current-window) command false))
+
+(define (read-and-dispatch-on-key)
+ (dispatch-on-key (current-comtabs)
+ (with-editor-interrupts-disabled keyboard-read)))
+
+(define (dispatch-on-key comtab key)
+ (set! *command-key* key)
+ (set-command-prompt!
+ (string-append-separated (command-argument-prompt) (xkey->name key)))
+ (%dispatch-on-command (current-window) (comtab-entry comtab key) false))
+
+(define (dispatch-on-command command #!optional record?)
+ (%dispatch-on-command (current-window)
+ command
+ (if (default-object? record?) false record?)))
+
(define (%dispatch-on-command window command record?)
(set! *command* command)
(guarantee-command-loaded command)
(set! *non-undo-count* 0)
(undo-boundary! point)
(apply procedure (interactive-arguments command record?)))))
- (cond ((or *executing-keyboard-macro?* (command-argument))
+ (cond ((or *executing-keyboard-macro?* *command-argument*)
(set! *non-undo-count* 0)
(apply procedure (interactive-arguments command record?)))
((window-needs-redisplay? window)
(normal))
- ((eq? command (ref-command-object 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? command (ref-command-object backward-char))
- (if (and (not (group-start? point))
- (char-graphic? (mark-left-char point))
- (positive? point-x)
- (< point-x (-1+ (window-x-size window))))
- (window-direct-output-backward-char! window)
- (normal)))
- ((and (not (special-key? *command-key*))
+ ((and (char? *command-key*)
(or (eq? command (ref-command-object self-insert-command))
(and (eq? command (ref-command-object auto-fill-space))
(not (auto-fill-break? point)))
(command-argument-self-insert? command)))
+ (if (or (= *non-undo-count* 0)
+ (>= *non-undo-count* 20))
+ (begin
+ (set! *non-undo-count* 0)
+ (undo-boundary! point)))
+ (set! *non-undo-count* (+ *non-undo-count* 1))
(let ((key *command-key*))
(if (let ((buffer (window-buffer window)))
(and (buffer-auto-save-modified? buffer)
(null? (cdr (buffer-windows buffer)))
(line-end? point)
(char-graphic? key)
- (< point-x (-1+ (window-x-size window)))))
- (begin
- (if (or (zero? *non-undo-count*)
- (>= *non-undo-count* 20))
- (begin
- (set! *non-undo-count* 0)
- (undo-boundary! point)))
- (set! *non-undo-count* (1+ *non-undo-count*))
- (window-direct-output-insert-char! window key))
+ (< point-x (- (window-x-size window) 1))))
+ (window-direct-output-insert-char! window key)
(region-insert-char! point key))))
+ ((eq? command (ref-command-object 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? command (ref-command-object backward-char))
+ (if (and (not (group-start? point))
+ (char-graphic? (mark-left-char point))
+ (< 0 point-x (- (window-x-size window) 1)))
+ (window-direct-output-backward-char! window)
+ (normal)))
(else
(normal))))))
\f
(interactive-argument
(string-ref specification index)
(substring specification
- (1+ index)
+ (+ index 1)
(or newline end))))
(lambda (argument expression from-tty?)
(with-values
(lambda ()
(if newline
- (loop (1+ newline))
+ (loop (+ newline 1))
(values '() '() false)))
(lambda (arguments expressions any-from-tty?)
(values (cons argument arguments)
projects / mit-scheme.git / commitdiff