;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/argred.scm,v 1.29 1989/04/28 22:46:49 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/argred.scm,v 1.30 1991/05/02 01:11:56 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;;; Command Argument Reader
(declare (usual-integrations))
-
-;;; 1. The reader keeps track of:
-;;;
-;;; [] The MAGNITUDE of the argument. If there are no digits, the
-;;; magnitude is false.
-;;; [] The SIGN of the argument.
-;;; [] The MULTIPLIER-EXPONENT, which is the number of C-U's typed.
-;;; [] Whether or not "Autoargument mode" is in effect. In autoarg
-;;; mode, ordinary digits are interpreted as part of the argument;
-;;; normally they are self-inserting.
-;;;
-;;; 2. From these, it can compute:
-;;;
-;;; [] VALUE = (* MAGNITUDE (EXPT 4 MULTIPLIER-EXPONENT)).
-;;; If the magnitude is false, then the value is too.
\f
-;;;; Commands
-
(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."
- ()
- (lambda ()
- (command-argument-increment-multiplier-exponent!)
- (enter-autoargument-mode!)
- (update-argument-prompt!)
- (read-and-dispatch-on-char)))
+ "Begin a numeric argument for the following command.
+Digits or minus sign following this command make up the numeric argument.
+If no digits or minus sign follow, this command by itself provides 4 as argument.
+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 (char-name (last-command-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)."
- ()
- (lambda ()
- (command-argument-accumulate-digit! (char-base (current-command-char)))
- (update-argument-prompt!)
- (read-and-dispatch-on-char)))
+ "Part of the numeric argument for the next command."
+ "P"
+ (lambda (argument)
+ (let ((digit (char->digit (char-base (last-command-char)))))
+ (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?)))))))
(define-command negative-argument
- "Negates the numeric argument for the next command.
-If no argument has yet been given, the argument defaults to -1."
- ()
- (lambda ()
- (command-argument-negate!)
- (update-argument-prompt!)
- (read-and-dispatch-on-char)))
-
-(define (command-argument-self-insert? procedure)
- (and (or (eq? procedure (ref-command auto-digit-argument))
- (and (eq? procedure (ref-command auto-negative-argument))
- (command-argument-beginning?)))
- (not *autoargument-mode?*)))
+ "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?))))
(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
-\\[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)))))
+ "When reading a command argument, part of the numeric argument.
+Otherwise, the digit inserts itself."
+ "P"
+ (lambda (argument)
+ (if (auto-argument-mode?)
+ ((ref-command digit-argument) argument)
+ ((ref-command self-insert-command) argument))))
(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-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)))))
+ "When reading a command argument, begin a negative argument.
+Otherwise, the character inserts itself."
+ "P"
+ (lambda (argument)
+ (if (and (auto-argument-mode?)
+ (not (number? argument)))
+ ((ref-command negative-argument) argument)
+ ((ref-command self-insert-command) argument))))
(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."
+ "Start a command argument.
+Digits following this command become part of the 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))))))
+ (if (char=? #\- (char-base (last-command-char)))
+ (if (not (number? argument))
+ ((ref-command negative-argument) argument))
+ ((ref-command digit-argument) argument))
+ (if (not argument)
+ (set-command-message! 'AUTO-ARGUMENT true))))
\f
-;;;; Primitives
+(define (command-argument-self-insert? command)
+ (and (or (eq? command (ref-command-object auto-digit-argument))
+ (and (eq? command (ref-command-object auto-negative-argument))
+ (not (number? (command-argument)))))
+ (not (auto-argument-mode?))))
-(define (with-command-argument-reader thunk)
- (fluid-let ((*magnitude*)
- (*negative?*)
- (*multiplier-exponent*)
- (*multiplier-value*)
- (*autoargument-mode?*)
- (*previous-prompt*))
- (thunk)))
-
-(define (reset-command-argument-reader!)
- ;; Call this at the beginning of a command cycle.
- (set! *magnitude* false)
- (set! *negative?* false)
- (set! *multiplier-exponent* 0)
- (set! *multiplier-value* 1)
- (set! *autoargument-mode?* false)
- (set! *previous-prompt* ""))
+(define (auto-argument-mode?)
+ (command-message-receive 'AUTO-ARGUMENT (lambda (x) x) (lambda () false)))
(define (command-argument-prompt)
- (or *previous-prompt* (%command-argument-prompt)))
-
-(define *previous-prompt*)
-
-(define (update-argument-prompt!)
- (let ((prompt (%command-argument-prompt)))
- (set! *previous-prompt* prompt)
- (set-command-prompt! prompt)))
-
-(define (%command-argument-prompt)
- (if (and (not *magnitude*)
- (if (autoargument-mode?)
- (and (not *negative?*)
- (= *multiplier-exponent* 1))
- *negative?*))
- (xchar->name (current-command-char))
- (let ((prefix (if (autoargument-mode?) "Autoarg" "Arg"))
- (value (command-argument-value)))
- (cond (value (string-append-separated prefix (write-to-string value)))
- (*negative?* (string-append-separated prefix "-"))
- (else "")))))
-
-;;;; Argument Number
-
-(define *magnitude*)
-(define *negative?*)
-
-(define (command-argument-accumulate-digit! digit-char)
- (set! *multiplier-exponent* 0)
- (set! *multiplier-value* 1)
- (let ((digit (or (char->digit digit-char 10)
- (error "Not a valid digit" digit-char))))
- (set! *magnitude*
- (if (not *magnitude*)
- digit
- (+ digit (* 10 *magnitude*))))))
-
-(define (command-argument-negate!)
- (set! *multiplier-exponent* 0)
- (set! *multiplier-value* 1)
- (set! *negative?* (not *negative?*)))
-
-(define (command-argument-magnitude)
- *magnitude*)
-
-(define (command-argument-negative?)
- *negative?*)
-\f
-;;;; Argument Multiplier
-
-(define *multiplier-exponent*)
-(define *multiplier-value*)
-
-(define (command-argument-increment-multiplier-exponent!)
- (set! *magnitude* false)
- (set! *negative?* false)
- (set! *multiplier-exponent* (1+ *multiplier-exponent*))
- (set! *multiplier-value* (* 4 *multiplier-value*)))
-
-(define (command-argument-multiplier-exponent)
- *multiplier-exponent*)
-
-;;;; Autoargument Mode
-
-(define *autoargument-mode?*)
-
-(define (enter-autoargument-mode!)
- (set! *autoargument-mode?* true))
-
-(define (autoargument-mode?)
- *autoargument-mode?*)
-
-;;;; 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)))
-
-(define (command-argument-value)
- ;; This returns the numeric value of the argument, or false if none.
- (cond (*magnitude*
- (* (if *negative?* (- *magnitude*) *magnitude*)
- *multiplier-value*))
- ((not (zero? *multiplier-exponent*))
- (if *negative?* (- *multiplier-value*) *multiplier-value*))
- (else false)))
-
-(define (command-argument-multiplier-only?)
- (and (not *magnitude*)
- (not (zero? *multiplier-exponent*))
- *multiplier-exponent*))
-
-(define (command-argument-negative-only?)
- (and (not *magnitude*)
- (zero? *multiplier-exponent*)
- *negative?*))
-
-(define (command-argument-beginning?)
- (and (not *magnitude*)
- (not *negative?*)
- (< *multiplier-exponent* 2)))
\ No newline at end of file
+ (let ((arg (command-argument)))
+ (if (not arg)
+ ""
+ (let ((mode (auto-argument-mode?)))
+ (string-append
+ (if (and (pair? arg) (string? mode))
+ (let loop ((n (car arg)))
+ (if (= n 4)
+ mode
+ (string-append mode " " (loop (quotient n 4)))))
+ (string-append
+ (cond ((string? mode) mode)
+ (mode "Autoarg")
+ (else "Arg"))
+ " "
+ (if (eq? '- arg)
+ "-"
+ (number->string (if (pair? arg) (car arg) arg)))))
+ " -")))))
+
+(define (command-argument-multiplier-only? argument)
+ (pair? argument))
+
+(define (command-argument-negative-only? argument)
+ (eq? '- argument))
+
+(define (command-argument-value argument)
+ (cond ((not argument) false)
+ ((eq? '- argument) -1)
+ ((pair? argument) (car argument))
+ (else argument)))
+
+(define (command-argument-numeric-value argument)
+ (or (command-argument-value argument) 1))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/autold.scm,v 1.49 1991/02/15 18:12:16 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/autold.scm,v 1.50 1991/05/02 01:12:03 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
Second arg is prefix arg when called interactively."
(lambda ()
(list
- (car
- (prompt-for-alist-value "Load library"
- (map (lambda (library)
- (cons (symbol->string (car library))
- library))
- known-libraries)))
- (command-argument-standard-value)))
+ (car (prompt-for-alist-value "Load library"
+ (map (lambda (library)
+ (cons (symbol->string (car library))
+ library))
+ known-libraries)))
+ (command-argument)))
(lambda (name force?)
(let ((do-it
(let ((library
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/autosv.scm,v 1.25 1991/04/21 00:48:49 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/autosv.scm,v 1.26 1991/05/02 01:12:10 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
With arg, turn auto-saving on if arg is positive, else off."
"P"
(lambda (argument)
- (let ((buffer (current-buffer)))
+ (let ((argument (command-argument-value argument))
+ (buffer (current-buffer)))
(if (if argument
(positive? argument)
(not (buffer-auto-save-pathname buffer)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/basic.scm,v 1.108 1991/04/24 00:36:19 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/basic.scm,v 1.109 1991/05/02 01:12:16 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
With an argument, insert the character that many times."
"P"
(lambda (argument)
- (insert-chars (current-command-char) (or argument 1))))
+ (insert-chars (last-command-char)
+ (command-argument-numeric-value argument))))
(define-command quoted-insert
"Reads a character and inserts it."
- "P"
+ "p"
(lambda (argument)
(let ((read-char
(lambda ()
(let ((digit3 (read-digit)))
(+ (* (+ (* digit 8) digit2) 8) digit3))))
char)))
- (or argument 1))))))
+ argument)))))
(define-command open-line
"Insert a newline after point.
"P"
(lambda (argument)
(let ((m* (mark-right-inserting (current-point))))
- (insert-newlines (or argument 1))
+ (insert-newlines (or (command-argument-value argument) 1))
(set-current-point! m*))))
(define-command narrow-to-region
With argument, saves visited file first."
"P"
(lambda (argument)
- (if argument ((ref-command save-buffer) false))
+ (if argument (save-buffer (current-buffer) false))
(set! edwin-finalization
(lambda ()
(set! edwin-finalization false)
Otherwise, set the comment column to the argument."
"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))))))
+ (if (command-argument-negative-only? argument)
+ ((ref-command kill-comment))
+ (let ((column
+ (or (command-argument-value argument)
+ (current-column))))
+ (set-variable! comment-column column)
+ (message "comment-column set to " column)))))
\f
(define-command indent-for-comment
"Indent this line's comment to comment column, or insert an empty comment."
()
(lambda ()
(if (not (ref-variable comment-locator-hook))
- (editor-error "No comment syntax defined")
- (let ((start (line-start (current-point) 0))
- (end (line-end (current-point) 0)))
- (let ((com ((ref-variable comment-locator-hook) start)))
- (set-current-point! (if com (car com) end))
- (let ((comment-end (and com (mark-permanent! (cdr com)))))
- (let ((indent
- ((ref-variable comment-indent-hook) (current-point))))
- (maybe-change-column indent)
- (if comment-end
- (set-current-point! comment-end)
- (begin
- (insert-string (ref-variable comment-start))
- (insert-comment-end))))))))))
+ (editor-error "No comment syntax defined"))
+ (let ((start (line-start (current-point) 0))
+ (end (line-end (current-point) 0)))
+ (let ((com ((ref-variable comment-locator-hook) start)))
+ (set-current-point! (if com (car com) end))
+ (let ((comment-end (and com (mark-permanent! (cdr com)))))
+ (let ((indent
+ ((ref-variable comment-indent-hook) (current-point))))
+ (maybe-change-column indent)
+ (if comment-end
+ (set-current-point! comment-end)
+ (begin
+ (insert-string (ref-variable comment-start))
+ (insert-comment-end)))))))))
(define-variable comment-multi-line
"True means \\[indent-new-comment-line] should continue same comment
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufcom.scm,v 1.86 1990/10/09 16:23:12 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufcom.scm,v 1.87 1991/05/02 01:12:22 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(string-append "Buffer "
(buffer-name buffer)
" contains changes. Write them out")))
- (write-buffer-interactive buffer)))
+ (write-buffer-interactive buffer false)))
(define (new-buffer name)
(create-buffer
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.144 1991/04/24 00:42:08 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.145 1991/05/02 01:12:28 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(define-integrable (set-buffer-comtabs! buffer comtabs)
(vector-set! buffer buffer-index:comtabs comtabs))
-
+\f
(define (buffer-point buffer)
(if (current-buffer? buffer)
(current-point)
(define-integrable (%set-buffer-point! buffer mark)
(set-group-point! (buffer-group buffer) mark))
-\f
+
(define-integrable (minibuffer? buffer)
(char=? (string-ref (buffer-name buffer) 0) #\Space))
(define-integrable (buffer-end buffer)
(group-end-mark (buffer-group buffer)))
+(define-integrable (buffer-absolute-start buffer)
+ (group-absolute-start (buffer-group buffer)))
+
+(define-integrable (buffer-absolute-end buffer)
+ (group-absolute-end (buffer-group buffer)))
+
(define (add-buffer-window! buffer window)
(vector-set! buffer
buffer-index:windows
(define-integrable (set-buffer-display-start! buffer mark)
(vector-set! buffer buffer-index:display-start mark))
-
+\f
(define-integrable (buffer-visible? buffer)
(not (null? (buffer-windows buffer))))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufmnu.scm,v 1.113 1991/04/21 00:49:05 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufmnu.scm,v 1.114 1991/05/02 01:12:36 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(for-each buffer-menu-kill! (find-buffers-marked 0 #\D)))
(define (buffer-menu-save! lstart)
- (save-buffer (buffer-menu-buffer lstart))
- (set-buffer-menu-mark! lstart 1 #\Space))
+ (save-buffer (buffer-menu-buffer lstart) false)
+ (set-buffer-menu-mark! lstart 1 #\space))
(define (buffer-menu-kill! lstart)
(define (erase-line)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comred.scm,v 1.85 1991/03/16 00:01:28 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comred.scm,v 1.86 1991/05/02 01:12:45 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(define *command-continuation*) ;Continuation of current command
(define *command-char*) ;Character read to find current command
(define *command*) ;The current command
+(define *command-argument*) ;Argument from last command
+(define *next-argument*) ;Argument to next 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
(call-with-current-continuation
(lambda (continuation)
(fluid-let ((*command-continuation* continuation)
- (*command-char*)
+ (*command-char* false)
(*command*)
+ (*next-argument* false)
(*next-message* false))
(bind-condition-handler (list condition-type:editor-error)
editor-error-handler
(let ((char (with-editor-interrupts-disabled keyboard-read-char)))
(set! *command-char* char)
(clear-message)
- (set-command-prompt! (char-name char))
+ (set-command-prompt!
+ (if (not *command-argument*)
+ (char-name char)
+ (string-append-separated (command-argument-prompt)
+ (char-name char))))
(let ((window (current-window)))
(%dispatch-on-command window
(comtab-entry (buffer-comtabs
false)))
(start-next-command))
- (fluid-let ((*command-message*)
+ (fluid-let ((*command-argument*)
+ (*command-message*)
(*non-undo-count* 0))
- (with-command-argument-reader
- (lambda ()
- (if (and (not (default-object? initialization)) initialization)
- (with-command-variables
- (lambda ()
- (reset-command-state!)
- (initialization))))
- (command-reader-loop)))))
+ (if (and (not (default-object? initialization)) initialization)
+ (with-command-variables
+ (lambda ()
+ (reset-command-state!)
+ (initialization))))
+ (command-reader-loop)))
(define (reset-command-state!)
- (reset-command-argument-reader!)
- (reset-command-prompt!)
+ (set! *command-argument* *next-argument*)
+ (set! *next-argument* false)
(set! *command-message* *next-message*)
(set! *next-message* false)
+ (if *command-argument*
+ (set-command-prompt! (command-argument-prompt))
+ (reset-command-prompt!))
(if *defining-keyboard-macro?* (keyboard-macro-finalize-chars)))
\f
;;; The procedures for executing commands come in two flavors. The
(define-integrable (current-command-char)
*command-char*)
+(define (last-command-char)
+ (if (char? *command-char*)
+ *command-char*
+ (car (last-pair *command-char*))))
+
(define-integrable (current-command)
*command*)
+(define (set-command-argument! argument)
+ (set! *next-argument* argument)
+ unspecific)
+
+(define-integrable (command-argument)
+ *command-argument*)
+
(define (set-command-message! tag . arguments)
(set! *next-message* (cons tag arguments))
unspecific)
(set! *non-undo-count* 0)
(undo-boundary! point)
(apply procedure (interactive-arguments command record?)))))
- (cond ((or *executing-keyboard-macro?*
- (command-argument-standard-value?))
+ (cond ((or *executing-keyboard-macro?* (command-argument))
(set! *non-undo-count* 0)
(apply procedure (interactive-arguments command record?)))
((window-needs-redisplay? window)
(normal))
- ((eq? procedure (ref-command forward-char))
+ ((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? procedure (ref-command backward-char))
+ ((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)))
- ((or (eq? procedure (ref-command self-insert-command))
- (and (eq? procedure (ref-command auto-fill-space))
+ ((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? procedure))
+ (command-argument-self-insert? command))
(let ((char *command-char*))
(if (let ((buffer (window-buffer window)))
(and (buffer-auto-save-modified? buffer)
((#\n)
(prompting (prompt-for-number prompt false)))
((#\N)
- (prefix
- (or (command-argument-standard-value)
- (prompt-for-number prompt false))))
+ (prefix (or (command-argument) (prompt-for-number prompt false))))
((#\p)
- (prefix (or (command-argument-standard-value) 1)))
+ (prefix (or (command-argument-value (command-argument)) 1)))
((#\P)
- (prefix (command-argument-standard-value)))
+ (prefix (command-argument)))
((#\r)
(varies (current-region) '(CURRENT-REGION)))
((#\s)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.34 1991/04/29 10:42:35 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.35 1991/05/02 01:12:54 cph Exp $
Copyright (c) 1989-91 Massachusetts Institute of Technology
undo-boundary!
undo-done!
undo-record-deletion!
- undo-record-insertion!))
+ undo-record-insertion!
+ with-group-undo-disabled))
(define-package (edwin display-type)
(files "display")
(parent (edwin))
(export (edwin)
abort-current-command
+ command-argument
command-history-list
command-message-receive
command-reader
execute-command-history-entry
initialize-command-reader!
keyboard-chars-read
+ last-command-char
read-and-dispatch-on-char
+ set-command-argument!
set-command-message!
top-level-command-reader))
(files "argred")
(parent (edwin))
(export (edwin)
- command-argument-beginning?
- command-argument-multiplier-exponent
command-argument-multiplier-only?
command-argument-negative-only?
- command-argument-negative?
+ command-argument-numeric-value
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))
+ edwin-command$auto-argument
+ edwin-command$auto-digit-argument
+ edwin-command$auto-negative-argument
+ edwin-command$digit-argument
+ edwin-command$negative-argument
+ edwin-command$universal-argument))
(define-package (edwin buffer-menu)
(files "bufmnu")
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/filcom.scm,v 1.150 1991/04/23 06:32:03 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/filcom.scm,v 1.151 1991/05/02 01:13:01 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(local-set-variable! scheme-environment (cadr entry))
(local-set-variable! scheme-syntax-table (caddr entry)))))))
\f
-(define (save-buffer buffer)
- (if (buffer-modified? buffer)
- (let ((exponent (command-argument-multiplier-only?)))
- (if (buffer-pathname buffer)
- (save-buffer-prepare-version buffer)
- (set-visited-pathname
- buffer
- (prompt-for-pathname
- (string-append "Write buffer " (buffer-name buffer) " to file")
- false false)))
- (if (memv exponent '(2 3)) (set-buffer-backed-up?! buffer false))
- (write-buffer-interactive buffer)
- (if (memv exponent '(1 3)) (set-buffer-backed-up?! buffer false)))
- (temporary-message "(No changes need to be written)")))
-
-(define (save-some-buffers #!optional no-confirmation?)
- (let ((buffers
- (list-transform-positive (buffer-list)
- (lambda (buffer)
- (and (buffer-modified? buffer)
- (buffer-pathname buffer))))))
- (if (null? buffers)
- (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)))))
- (write-buffer-interactive buffer)))
- buffers))))
-
-(define (save-buffer-prepare-version buffer)
- (if pathname-newest
- (let ((pathname (buffer-pathname buffer)))
- (if (and pathname (integer? (pathname-version pathname)))
- (set-buffer-pathname! buffer
- (pathname-new-version pathname 'NEWEST))))))
-
(define-command save-buffer
"Save current buffer in visited file if modified. Versions described below.
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"
+ "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)))))
+ (save-buffer (current-buffer)
+ (case argument
+ ((0) 'NO-BACKUP)
+ ((4) 'BACKUP-NEXT)
+ ((16) 'BACKUP-PREVIOUS)
+ ((64) 'BACKUP-BOTH)
+ (else false)))))
(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)
+ (lambda (no-confirmation?)
+ (save-some-buffers no-confirmation?)))
+
+(define (save-buffer buffer backup-mode)
+ (if (buffer-modified? buffer)
+ (begin
+ (if (not (buffer-pathname buffer))
+ (set-visited-pathname
+ buffer
+ (prompt-for-pathname
+ (string-append "Write buffer " (buffer-name buffer) " to file")
+ false false)))
+ (write-buffer-interactive buffer backup-mode))
+ (message "(No changes need to be written)")))
+
+(define (save-some-buffers #!optional no-confirmation?)
+ (let ((buffers
+ (list-transform-positive (buffer-list)
+ (lambda (buffer)
+ (and (buffer-modified? buffer)
+ (buffer-pathname buffer))))))
+ (if (null? buffers)
+ (temporary-message "(No files need saving)")
+ (for-each (if (and (not (default-object? no-confirmation?))
+ no-confirmation?)
+ (lambda (buffer)
+ (write-buffer-interactive buffer false))
+ (lambda (buffer)
+ (if (prompt-for-confirmation?
+ (string-append
+ "Save file "
+ (pathname->string (buffer-pathname buffer))))
+ (write-buffer-interactive buffer false))))
+ buffers))))
\f
(define-command set-visited-file-name
"Change name of file visited in current buffer.
(not (string-null? filename)))
(set-visited-pathname buffer (->pathname filename)))
(buffer-modified! buffer)
- (save-buffer buffer))
+ (save-buffer buffer false))
(define-command write-region
"Write current region into specified file."
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/fileio.scm,v 1.97 1991/04/23 06:45:42 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/fileio.scm,v 1.98 1991/05/02 01:13:09 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(association-procedure string-ci=? car))
(define (parse-buffer-mode-header buffer)
- (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))
- (extract-string start end)
- (let ((mode-mark (re-search-forward "mode:[ \t]*" start end)))
- (and mode-mark
- (extract-string mode-mark
- (if (re-search-forward "[ \t]*;" mode-mark end)
- (re-match-start 0)
- end))))))
+ (let ((start (buffer-start buffer)))
+ (let ((end (line-end start 0)))
+ (let ((start (re-search-forward "-\\*-[ \t]*" start end false)))
+ (and start
+ (re-search-forward "[ \t]*-\\*-" start end false)
+ (let ((end (re-match-start 0)))
+ (if (not (char-search-forward #\: start end false))
+ (extract-string start end)
+ (let ((m (re-search-forward "mode:[ \t]*" start end true)))
+ (and m
+ (extract-string
+ m
+ (if (re-search-forward "[ \t]*;" m end false)
+ (re-match-start 0)
+ end)))))))))))
)
\f
(named-lambda (initialize-buffer-local-variables! buffer)
(let ((end (buffer-end buffer)))
(let ((start
- (with-narrowed-region!
- (make-region (mark- end
- (ref-variable local-variable-search-limit)
- 'LIMIT)
- end)
- (lambda ()
- (backward-one-page end)))))
+ (with-text-clipped
+ (mark- end (ref-variable local-variable-search-limit) 'LIMIT)
+ end
+ (lambda () (backward-one-page end)))))
(if start
(if (re-search-forward "Edwin Variables:[ \t]*" start end true)
(parse-local-variables buffer
Otherwise asks confirmation."
false)
\f
-(define (write-buffer-interactive buffer)
+(define (write-buffer-interactive buffer backup-mode)
(let ((truename (pathname->output-truename (buffer-pathname buffer))))
(let ((writable? (file-writable? truename)))
(if (or writable?
(prompt-for-yes-or-no?
"Disk file has changed since visited or saved. Save anyway")))
(editor-error "Save not confirmed"))
- (let ((modes
- (and (not (buffer-backed-up? buffer))
- (backup-buffer! buffer truename))))
+ (let ((modes (backup-buffer! buffer truename backup-mode)))
(require-newline buffer)
(if (not (or writable? modes))
(begin
(fix:+ end gap-length))))))
\f
(define (require-newline buffer)
- (let ((require-final-newline? (ref-variable require-final-newline)))
+ (let ((require-final-newline? (ref-variable require-final-newline buffer)))
(if require-final-newline?
(without-group-clipped! (buffer-group buffer)
(lambda ()
" does not end in newline. Add one")))))
(insert-newline end))))))))
-(define (backup-buffer! buffer truename)
- (let ((continue-with-false (lambda () false)))
- (and truename
- (ref-variable make-backup-files)
- (not (buffer-backed-up? buffer))
- (file-exists? truename)
- (os/backup-buffer? truename)
- (catch-file-errors
- continue-with-false
- (lambda ()
- (with-values (lambda () (os/buffer-backup-pathname truename))
- (lambda (backup-pathname targets)
- (let ((modes
- (catch-file-errors
- (lambda ()
- (let ((filename (os/default-backup-filename)))
- (temporary-message
- "Cannot write backup file; backing up in "
- filename)
- (copy-file truename
- (string->pathname filename))
- false))
- (lambda ()
- (if (or (file-symbolic-link? truename)
- (ref-variable backup-by-copying)
- (os/backup-by-copying? truename))
- (begin
- (copy-file truename backup-pathname)
- false)
- (begin
+(define (backup-buffer! buffer truename backup-mode)
+ (and (ref-variable make-backup-files buffer)
+ (or (memq backup-mode '(BACKUP-PREVIOUS BACKUP-BOTH))
+ (and (not (eq? backup-mode 'NO-BACKUP))
+ (not (buffer-backed-up? buffer))))
+ truename
+ (file-exists? truename)
+ (os/backup-buffer? truename)
+ (catch-file-errors
+ (lambda () false)
+ (lambda ()
+ (with-values (lambda () (os/buffer-backup-pathname truename))
+ (lambda (backup-pathname targets)
+ (let ((modes
+ (catch-file-errors
+ (lambda ()
+ (let ((filename (os/default-backup-filename)))
+ (temporary-message
+ "Cannot write backup file; backing up in "
+ filename)
+ (copy-file truename (string->pathname filename))
+ false))
+ (lambda ()
+ (if (or (file-symbolic-link? truename)
+ (ref-variable backup-by-copying buffer)
+ (os/backup-by-copying? truename))
+ (begin
+ (copy-file truename backup-pathname)
+ false)
+ (begin
+ (catch-file-errors
+ (lambda () unspecific)
+ (lambda () (delete-file backup-pathname)))
+ (rename-file truename backup-pathname)
+ (file-modes backup-pathname)))))))
+ (set-buffer-backed-up?!
+ buffer
+ (not (memv backup-mode '(BACKUP-NEXT BACKUP-BOTH))))
+ (if (and (not (null? targets))
+ (or (ref-variable trim-versions-without-asking buffer)
+ (prompt-for-confirmation?
+ (string-append
+ "Delete excess backup versions of "
+ (pathname->string (buffer-pathname buffer))))))
+ (for-each (lambda (target)
(catch-file-errors
- (lambda () false)
- (lambda ()
- (delete-file backup-pathname)))
- (rename-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)
- (prompt-for-confirmation?
- (string-append
- "Delete excess backup versions of "
- (pathname->string
- (buffer-pathname buffer))))))
- (for-each (lambda (target)
- (catch-file-errors continue-with-false
- (lambda ()
- (delete-file target))))
- targets))
- modes))))))))
\ No newline at end of file
+ (lambda () unspecific)
+ (lambda () (delete-file target))))
+ targets))
+ modes)))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/fill.scm,v 1.49 1991/04/24 00:40:22 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/fill.scm,v 1.50 1991/05/02 01:13:16 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
fill-column's value is separate for each buffer."
"P"
(lambda (argument)
- (let ((column (or argument (current-column))))
+ (let ((column
+ (or (command-argument-value argument)
+ (current-column))))
(set-variable! fill-column column)
- (message "fill-column set to " (number->string column)))))
+ (message "fill-column set to " column))))
(define-variable-per-buffer fill-prefix
"String for filling to insert at front of new line, or #f for none.
With argument, turn auto-fill mode on iff argument is positive."
"P"
(lambda (argument)
- (let ((mode (ref-mode-object auto-fill)))
+ (let ((argument (command-argument-value argument))
+ (mode (ref-mode-object auto-fill)))
(cond ((and (or (not argument) (positive? argument))
(not (current-minor-mode? mode)))
(enable-current-minor-mode! mode))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/kilcom.scm,v 1.61 1991/04/24 00:38:05 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/kilcom.scm,v 1.62 1991/05/02 01:13:23 cph Exp $
;;;
;;; Copyright (c) 1985, 1989-91 Massachusetts Institute of Technology
;;;
\f
;;;; Deletion
-(define-command backward-delete-char
+(define-command delete-backward-char
"Delete character before point.
With argument, kills several characters (saving them).
Negative args kill characters forward."
(lambda (argument)
(if (not argument)
(delete-region (mark-1+ (current-point)))
- (kill-region (mark- (current-point) argument)))))
+ (kill-region
+ (mark- (current-point) (command-argument-value argument))))))
(define-command delete-char
"Delete character after point.
(lambda (argument)
(if (not argument)
(delete-region (mark1+ (current-point)))
- (kill-region (mark+ (current-point) argument)))))
+ (kill-region
+ (mark+ (current-point) (command-argument-value argument))))))
(define-command kill-line
"Kill to end of line, or kill an end of line.
Killed text is pushed onto the kill ring for retrieval."
"P"
(lambda (argument)
- (let ((point (current-point)))
+ (let ((argument (command-argument-value argument))
+ (point (current-point)))
(kill-region
(cond ((not argument)
(let ((end (line-end point 0)))
(begin
(convert-tab-to-spaces! (mark-1+ tab))
(forth n)))))))
- (cond ((not argument)
- (let ((point (current-point)))
- (if (char-match-backward #\Tab point)
- (convert-tab-to-spaces! (mark-1+ point))))
- (delete-region (mark-1+ (current-point))))
- ((positive? argument)
- (kill-region (back argument)))
- ((negative? argument)
- (kill-region (forth (- argument)))))))
+ (let ((argument (command-argument-value argument)))
+ (cond ((not argument)
+ (let ((point (current-point)))
+ (if (char-match-backward #\Tab point)
+ (convert-tab-to-spaces! (mark-1+ 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)))
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."
- "p"
+ "P"
(lambda (argument)
(let ((ring (current-kill-ring)))
(define (pop-loop n)
(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)))))
+ (if (command-argument-multiplier-only? argument)
+ (unkill (ring-ref ring 0))
+ (let ((argument (command-argument-numeric-value argument)))
+ (if (positive? argument)
+ (begin
+ (pop-loop argument)
+ (unkill-reversed (ring-ref ring 0)))))))
(set-command-message! un-kill-tag)))
(define-command yank-pop
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))))))
+ "P"
+ (lambda (argument)
+ (case (and (command-argument-multiplier-only? argument)
+ (command-argument-value argument))
+ ((4) (set-current-point! (pop-current-mark!)))
+ ((16) (pop-current-mark!))
+ (else (push-current-mark! (current-point))))))
(define-command mark-beginning-of-buffer
"Set mark at beginning of buffer."
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/lincom.scm,v 1.109 1991/04/23 06:41:30 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/lincom.scm,v 1.110 1991/05/02 01:13:31 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
"Put mark at end of page, point at beginning."
"P"
(lambda (argument)
- (let ((end (forward-page (current-point) (1+ (or argument 0)) 'LIMIT)))
+ (let ((end
+ (forward-page (current-point)
+ (1+ (or (command-argument-value argument) 0))
+ 'LIMIT)))
(set-current-region! (make-region (backward-page end 1 'LIMIT) end)))))
(define-command narrow-to-page
(lambda (argument)
(set-variable! indent-tabs-mode
(if argument
- (positive? argument)
+ (positive? (command-argument-value argument))
(not (ref-variable indent-tabs-mode))))))
(define-command insert-tab
An argument inhibits this."
"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)))
+ (cond (argument
+ (insert-newlines (command-argument-value argument)))
+ ((not (line-end? (current-point)))
+ (insert-newline))
(else
- (insert-newlines argument)))))
+ (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)))))))
(define-command split-line
"Move rest of this line vertically down.
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/macros.scm,v 1.51 1991/04/21 00:51:18 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/macros.scm,v 1.52 1991/05/02 01:13:38 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(variable-name->scheme-name (canonicalize-name name))))
(syntax-table-define edwin-syntax-table 'REF-VARIABLE
- (lambda (name)
- `(VARIABLE-VALUE
- ,(variable-name->scheme-name (canonicalize-name name)))))
+ (lambda (name #!optional buffer)
+ (let ((name (variable-name->scheme-name (canonicalize-name name))))
+ (if (default-object? buffer)
+ `(VARIABLE-VALUE ,name)
+ `(VARIABLE-LOCAL-VALUE ,buffer ,name)))))
(syntax-table-define edwin-syntax-table 'SET-VARIABLE!
(lambda (name #!optional value)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.40 1991/04/29 10:43:18 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.41 1991/05/02 01:13:45 cph Exp $
Copyright (c) 1989-91 Massachusetts Institute of Technology
(declare (usual-integrations))
(package/system-loader "edwin" '() 'QUERY)
-(add-system! (make-system "Edwin" 3 40 '()))
\ No newline at end of file
+(add-system! (make-system "Edwin" 3 41 '()))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modefs.scm,v 1.124 1991/04/21 00:51:28 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modefs.scm,v 1.125 1991/05/02 01:13:52 cph Exp $
;;;
;;; Copyright (c) 1985, 1989-91 Massachusetts Institute of Technology
;;;
(define-key 'fundamental char-set:numeric 'auto-digit-argument)
(define-key 'fundamental #\- 'auto-negative-argument)
-(define-key 'fundamental #\rubout 'backward-delete-char)
+(define-key 'fundamental #\rubout 'delete-backward-char)
\f
(define-key 'fundamental #\c-% 'replace-string)
(define-key 'fundamental #\c-- 'negative-argument)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/motcom.scm,v 1.39 1989/04/28 22:51:42 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/motcom.scm,v 1.40 1991/05/02 01:13:59 cph Exp $
;;;
-;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1985, 1989-91 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(push-current-mark! (current-point))
(cond ((not argument)
(set-current-point! (buffer-start (current-buffer))))
- ((command-argument-multiplier-only?)
+ ((command-argument-multiplier-only? argument)
(set-current-point! (buffer-end (current-buffer))))
- ((<= 0 argument 10)
- (set-current-point! (region-10ths (buffer-region (current-buffer))
- argument))))))
+ ((and (number? argument) (<= 0 argument 10))
+ (set-current-point!
+ (region-10ths (buffer-region (current-buffer)) argument))))))
(define-command end-of-buffer
"Go to end of buffer (leaving mark behind).
(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)))))))
+ ((and (number? argument) (<= 0 argument 10))
+ (set-current-point!
+ (region-10ths (buffer-region (current-buffer))
+ (- 10 argument)))))))
(define (region-10ths region n)
(mark+ (region-start region)
last newline in the buffer, makes a new one at the end."
"P"
(lambda (argument)
- (let ((column (current-goal-column)))
+ (let ((argument (command-argument-value argument))
+ (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)))))
+ (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)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/prompt.scm,v 1.139 1990/10/06 00:16:12 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/prompt.scm,v 1.140 1991/05/02 01:14:05 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(define-variable enable-recursive-minibuffers
"If true, allow minibuffers to invoke commands which use
recursive minibuffers."
- false)
+ false
+ boolean?)
(define-variable completion-auto-help
- "*True means automatically provide help for invalid completion input."
- true)
+ "True means automatically provide help for invalid completion input."
+ true
+ boolean?)
(define (prompt-for-typein prompt-string check-recursion? thunk)
(if (and check-recursion?
(within-typein-edit
(lambda ()
(insert-string prompt-string)
- (with-narrowed-region! (let ((mark (current-point)))
- (make-region (mark-right-inserting mark)
- (mark-left-inserting mark)))
- (lambda ()
- (intercept-^G-interrupts
- (lambda ()
- (cond ((not (eq? (current-window) (typein-window)))
- (abort-current-command))
- (typein-edit-continuation
- (typein-edit-continuation typein-edit-abort-flag))
- (else
- (error "illegal ^G signaled in typein window"))))
- thunk))))))
+ (let ((mark (current-point)))
+ (with-text-clipped (mark-right-inserting mark)
+ (mark-left-inserting mark)
+ (lambda ()
+ (intercept-^G-interrupts
+ (lambda ()
+ (cond ((not (eq? (current-window) (typein-window)))
+ (abort-current-command))
+ (typein-edit-continuation
+ (typein-edit-continuation typein-edit-abort-flag))
+ (else
+ (error "illegal ^G signaled in typein window"))))
+ thunk)))))))
(define ((typein-editor-thunk mode))
(let ((buffer (current-buffer)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/replaz.scm,v 1.68 1991/04/29 11:23:46 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/replaz.scm,v 1.69 1991/05/02 01:14:17 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(let ((source (prompt-for-string name false)))
(list source
(prompt-for-string (string-append name " " source " with") false)
- (command-argument-standard-value))))
+ (command-argument))))
(define-command replace-string
"Replace occurrences of FROM-STRING with TO-STRING.
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/sendmail.scm,v 1.5 1991/04/24 07:26:09 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/sendmail.scm,v 1.6 1991/05/02 01:14:23 cph Exp $
;;;
;;; Copyright (c) 1991 Massachusetts Institute of Technology
;;;
start)
(if (not (line-end? end))
(insert-newline end))
- (if (not (command-argument-multiplier-only?))
+ (if (not (command-argument-multiplier-only? argument))
(begin
(mail-yank-clear-headers start end)
- (indent-rigidly start end (or argument 3))))
+ (indent-rigidly start end
+ (or (command-argument-value argument)
+ 3))))
(mark-temporary! start)
(mark-temporary! end)
(push-current-mark! start)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/shell.scm,v 1.2 1991/04/21 00:52:05 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/shell.scm,v 1.3 1991/05/02 01:14:28 cph Exp $
Copyright (c) 1991 Massachusetts Institute of Technology
"Turn directory tracking on and off in a shell buffer."
"P"
(lambda (argument)
- (set-variable! shell-dirtrack?
- (cond ((not argument) (not (ref-variable shell-dirtrack?)))
- ((positive? argument) true)
- ((negative? argument) false)
- (else (ref-variable shell-dirtrack?))))
+ (set-variable!
+ shell-dirtrack?
+ (let ((argument (command-argument-value argument)))
+ (cond ((not argument) (not (ref-variable shell-dirtrack?)))
+ ((positive? argument) true)
+ ((negative? argument) false)
+ (else (ref-variable shell-dirtrack?)))))
(message "Directory tracking "
(if (ref-variable shell-dirtrack?) "on" "off")
".")))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/struct.scm,v 1.77 1991/04/21 00:52:14 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/struct.scm,v 1.78 1991/05/02 01:14:34 cph Exp $
;;;
;;; Copyright (c) 1985, 1989-91 Massachusetts Institute of Technology
;;;
(define-integrable (set-group-point! group point)
(vector-set! group group-index:point (mark-left-inserting-copy point)))
-(define (with-narrowed-region! region thunk)
- (with-group-text-clipped! (region-group region)
- (region-start-index region)
- (region-end-index region)
+(define (group-absolute-start group)
+ (make-temporary-mark group 0 false))
+
+(define (group-absolute-end group)
+ (make-temporary-mark group (group-length group) true))
+\f
+;;;; Text Clipping
+
+;;; Changes the group's start and end points, but doesn't affect the
+;;; display.
+
+(define (with-text-clipped start end thunk)
+ (if (not (mark<= start end))
+ (error "Marks incorrectly related:" start end))
+ (with-group-text-clipped! (mark-group start)
+ (mark-index start)
+ (mark-index end)
thunk))
+(define (text-clip start end)
+ (if (not (mark<= start end))
+ (error "Marks incorrectly related:" start end))
+ (group-text-clip (mark-group start) (mark-index start) (mark-index end)))
+
(define (with-group-text-clipped! group start end thunk)
(let ((old-text-start)
(old-text-end)
(set! new-text-end (group-end-mark group))
(vector-set! group group-index:start-mark old-text-start)
(vector-set! group group-index:end-mark old-text-end)))))
+
+(define (group-text-clip group start end)
+ (let ((start (make-permanent-mark group start false))
+ (end (make-permanent-mark group end true)))
+ (vector-set! group group-index:start-mark start)
+ (vector-set! group group-index:end-mark end)))
\f
(define (invoke-group-daemons! daemons group start end)
(let loop ((daemons daemons))
(define (group-display-end? mark)
(group-display-end-index? (mark-group mark) (mark-index mark)))
+
+(define-integrable (mark-absolute-start mark)
+ (group-absolute-start (mark-group mark)))
+
+(define-integrable (mark-absolute-end mark)
+ (group-absolute-end (mark-group mark)))
\f
;;; The next few procedures are simple algorithms that are haired up
;;; the wazoo for maximum speed.
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tagutl.scm,v 1.38 1991/04/26 03:14:31 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tagutl.scm,v 1.39 1991/05/02 01:14:40 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
false)
(define (find-tag-arguments prompt)
- (let ((previous-tag? (command-argument-standard-value)))
+ (let ((previous-tag? (command-argument)))
(if previous-tag?
(list false true)
(let ((string (prompt-for-string prompt (find-tag-default))))
(set-buffer-point! buffer (line-end tag 0))
(find-file pathname)
(let* ((buffer (current-buffer))
- (group (buffer-group buffer))
- (end (group-end-index group)))
+ (group (buffer-group buffer)))
(buffer-widen! buffer)
(push-current-mark! (current-point))
(let ((mark
(or (re-search-forward
regexp
(make-mark group index)
- (make-mark group (min (+ start offset) end)))
+ (make-mark group
+ (min (+ start offset)
+ (group-end-index group))))
(loop (* 3 offset)))
(re-search-forward regexp
(make-mark group 0)
- end))))))
+ (group-end-mark group)))))))
(if (not mark)
(editor-failure regexp
" not found in "
(prompt-for-string
(string-append "Tags query replace " source " with")
false)
- (command-argument-standard-value))))
+ (command-argument))))
(lambda (source target delimited)
(set! tags-loop-continuation
(lambda ()
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/undo.scm,v 1.47 1991/04/21 00:52:26 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/undo.scm,v 1.48 1991/05/02 01:14:45 cph Exp $
;;;
;;; Copyright (c) 1985, 1989-91 Massachusetts Institute of Technology
;;;
(define (disable-group-undo! group)
(set-group-undo-data! group false))
+
+(define (with-group-undo-disabled group thunk)
+ (dynamic-wind (lambda () (disable-group-undo! group))
+ thunk
+ (if (group-undo-data group)
+ (lambda () (enable-group-undo! group))
+ (lambda () unspecific))))
\f
(define (new-undo! undo-data type group start length)
(let ((records (undo-data-records undo-data))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/wincom.scm,v 1.99 1990/11/02 03:24:57 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/wincom.scm,v 1.100 1991/05/02 01:14:50 cph Exp $
;;;
-;;; Copyright (c) 1987, 1989, 1990 Massachusetts Institute of Technology
+;;; Copyright (c) 1987, 1989-91 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(update-selected-screen! true))
(window-scroll-y-absolute!
window
- (modulo argument (window-y-size window)))))))
+ (modulo (command-argument-value argument)
+ (window-y-size window)))))))
(define-command move-to-window-line
"Position point relative to window.
window 0
(if (not argument)
(window-y-center window)
- (modulo argument (window-y-size window))))
+ (modulo (command-argument-value argument)
+ (window-y-size window))))
(window-coordinates->mark
window 0
(window-mark->y window
(- (window-y-size window)
(ref-variable next-screen-context-lines))))
(cond ((not argument) quantum)
- ((command-argument-negative-only?) (- quantum))
- (else argument)))))
+ ((command-argument-negative-only? argument) (- quantum))
+ (else (command-argument-value argument))))))
(define (multi-scroll-window-argument window argument factor)
(* factor
(- (window-y-size window)
(ref-variable next-screen-context-lines))))
(cond ((not argument) quantum)
- ((command-argument-negative-only?) (- quantum))
- (else (* argument quantum))))))
+ ((command-argument-negative-only? argument) (- quantum))
+ (else (* (command-argument-value argument) quantum))))))
(define-command what-cursor-position
"Print info on cursor position (on screen and within buffer)."
"P"
(lambda (argument)
(disallow-typein)
- (window-split-vertically! (current-window) argument)))
+ (window-split-vertically! (current-window)
+ (command-argument-value argument))))
(define-command split-window-horizontally
"Split current window into two windows side by side.
"P"
(lambda (argument)
(disallow-typein)
- (window-split-horizontally! (current-window) argument)))
+ (window-split-horizontally! (current-window)
+ (command-argument-value argument))))
(define-command enlarge-window
"Makes current window ARG lines bigger."
(define-command other-window
"Select the ARG'th different window."
- "P"
+ "p"
(lambda (argument)
(select-window (other-window-interactive argument))))
\f
(let ((window (screen-root-window screen)))
(send window ':set-size!
(let ((x-size (screen-x-size screen)))
- (cond ((command-argument-multiplier-only?)
+ (cond ((command-argument-multiplier-only? argument)
x-size)
((not argument)
(let ((x-size* (window-x-size window)))
x-size
(min 80 x-size))))
(else
- (if (< argument 10)
- (editor-error "restriction too small: " argument))
- (min x-size argument))))
+ (let ((argument (command-argument-value argument)))
+ (if (< argument 10)
+ (editor-error "restriction too small: " argument))
+ (min x-size argument)))))
(screen-y-size screen)))
(update-screen! screen true))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff