#| -*-Scheme-*-
-$Id: edwin.pkg,v 1.242 2000/02/23 22:58:28 cph Exp $
+$Id: edwin.pkg,v 1.243 2000/02/25 17:47:08 cph Exp $
Copyright (c) 1989-2000 Massachusetts Institute of Technology
group-insert-string!
group-insert-substring!
group-left-char
+ group-replace-char!
+ group-replace-string!
+ group-replace-substring!
group-right-char
prepare-gap-for-insert!))
undo-record-deletion!
undo-record-insertion!
undo-record-property-changes!
+ undo-record-replacement!
undo-start
with-group-undo-disabled))
(export (edwin group-operations)
text-not-deleteable?
text-not-insertable?
+ text-not-replaceable?
update-intervals-for-deletion!
- update-intervals-for-insertion!)
+ update-intervals-for-insertion!
+ update-intervals-for-replacement!)
(export (edwin undo)
group-extract-properties
group-reinsert-properties!
;;; -*-Scheme-*-
;;;
-;;; $Id: grpops.scm,v 1.25 1999/11/01 03:40:17 cph Exp $
+;;; $Id: grpops.scm,v 1.26 2000/02/25 17:47:00 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-2000 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
(define (group-left-char group index)
(string-ref (group-text group)
- (fix:- (group-index->position-integrable group index false) 1)))
+ (fix:- (group-index->position-integrable group index #f) 1)))
(define (group-right-char group index)
(string-ref (group-text group)
- (group-index->position-integrable group index true)))
+ (group-index->position-integrable group index #t)))
(define (group-extract-and-delete-string! group start end)
(let ((string (group-extract-string group start end)))
(group-delete! group start end)
string))
\f
-;;;; Insertions
+;;;; Insertion
(define (group-insert-char! group index char)
(group-insert-chars! group index char 1))
(set-group-modified-tick! group (fix:+ (group-modified-tick group) 1))
(undo-record-insertion! group index (fix:+ index n))
;; The MODIFIED? bit must be set *after* the undo recording.
- (set-group-modified?! group true)
+ (set-group-modified?! group #t)
(if (group-text-properties group)
(update-intervals-for-insertion! group index n)))
\f
-;;;; Deletions
+;;;; Deletion
(define (group-delete-left-char! group index)
(group-delete! group (fix:- index 1) index))
(fix:- (mark-index (system-pair-car marks)) n))))))
(set-group-modified-tick! group (fix:+ (group-modified-tick group) 1))
;; The MODIFIED? bit must be set *after* the undo recording.
- (set-group-modified?! group true)
+ (set-group-modified?! group #t)
(if (group-text-properties group)
(update-intervals-for-deletion! group start end))
(set-interrupt-enables! interrupt-mask)
unspecific)))
\f
+;;;; Replacement
+
+(define (group-replace-char! group index char)
+ (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))
+ (end-index (fix:+ index 1)))
+ (prepare-gap-for-replace! group index end-index)
+ (string-set! (group-text group) index char)
+ (finish-group-replace! group index end-index)
+ (set-interrupt-enables! interrupt-mask)
+ unspecific))
+
+(define (group-replace-string! group index string)
+ (group-replace-substring! group index string 0 (string-length string)))
+
+(define (group-replace-substring! group index string start end)
+ (if (fix:< start end)
+ (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))
+ (end-index (fix:+ index (fix:- end start))))
+ (prepare-gap-for-replace! group index end-index)
+ (%substring-move! string start end (group-text group) index)
+ (finish-group-replace! group index end-index)
+ (set-interrupt-enables! interrupt-mask)
+ unspecific)))
+
+(define (prepare-gap-for-replace! group start end)
+ (if (or (group-read-only? group)
+ (and (group-text-properties group)
+ (text-not-replaceable? group start end)))
+ (barf-if-read-only))
+ (if (not (group-modified? group))
+ (check-first-group-modification group))
+ (if (and (fix:< start (group-gap-start group))
+ (fix:< (group-gap-start group) end))
+ (let ((new-end (fix:+ end (group-gap-length group))))
+ (%substring-move! (group-text group)
+ (group-gap-end group)
+ new-end
+ (group-text group)
+ (group-gap-start group))
+ (set-group-gap-start! group end)
+ (set-group-gap-end! group new-end)))
+ (undo-record-replacement! group start end))
+
+(define (finish-group-replace! group start end)
+ (if (group-start-changes-index group)
+ (begin
+ (if (fix:< start (group-start-changes-index group))
+ (set-group-start-changes-index! group start))
+ (if (fix:> end (group-end-changes-index group))
+ (set-group-end-changes-index! group end)))
+ (begin
+ (set-group-start-changes-index! group start)
+ (set-group-end-changes-index! group end)))
+ (set-group-modified-tick! group (fix:+ (group-modified-tick group) 1))
+ ;; The MODIFIED? bit must be set *after* the undo recording.
+ (set-group-modified?! group #t)
+ (if (group-text-properties group)
+ (update-intervals-for-replacement! group start end)))
+\f
;;;; Resizing
(define (grow-group! group new-gap-start n)
;;; -*-Scheme-*-
;;;
-;;; $Id: regops.scm,v 1.87 1999/01/02 06:11:34 cph Exp $
+;;; $Id: regops.scm,v 1.88 2000/02/25 17:47:18 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-2000 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
(error "No right char:" mark))
(group-delete-right-char! (mark-group mark) (mark-index mark)))
-;;; **** This is not a great thing to do. It will screw up any marks
-;;; that are within the region, pushing them to either side.
-;;; Conceptually we just want the characters to be altered.
-
(define (region-transform! region operation)
- (let ((m (mark-right-inserting-copy (region-start region)))
- (string (operation (region->string region))))
- (region-delete! region)
- (region-insert-string! m string)
- (mark-temporary! m)))
+ (let ((start (region-start region)))
+ (group-replace-string! (mark-group start)
+ (mark-index start)
+ (operation (region->string region)))))
\f
;;;; Clipping
;;; -*-Scheme-*-
;;;
-;;; $Id: simple.scm,v 1.48 1999/01/02 06:11:34 cph Exp $
+;;; $Id: simple.scm,v 1.49 2000/02/25 17:46:30 cph Exp $
;;;
-;;; Copyright (c) 1985, 1989-1999 Massachusetts Institute of Technology
+;;; Copyright (c) 1985, 1989-2000 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
(group-extract-and-delete-string! group index1 index2)
(group-extract-and-delete-string! group index2 index1)))))
\f
-(define (downcase-area mark #!optional point)
- (region-transform!
- (make-region mark (if (default-object? point) (current-point) point))
- (lambda (string)
- (string-downcase! string)
- string)))
-
-(define (upcase-area mark #!optional point)
- (region-transform!
- (make-region mark (if (default-object? point) (current-point) point))
- (lambda (string)
- (string-upcase! string)
- string)))
-
-(define (capitalize-area mark #!optional point)
- (region-transform!
- (make-region mark (if (default-object? point) (current-point) point))
- (lambda (string)
- (string-downcase! string)
- (string-set! string 0 (char-upcase (string-ref string 0)))
- string)))
-
(define (mark-flash mark #!optional type)
(cond (*executing-keyboard-macro?* unspecific)
((not mark) (editor-beep))
(define (reposition-window-top mark)
(if (not (and mark (set-window-start-mark! (current-window) mark false)))
(editor-beep)))
-\f
+
(define (narrow-to-region mark #!optional point)
(let ((point (if (default-object? point) (current-point) point)))
(let ((group (mark-group mark))
;;; -*-Scheme-*-
;;;
-;;; $Id: texcom.scm,v 1.39 1999/01/02 06:11:34 cph Exp $
+;;; $Id: texcom.scm,v 1.40 2000/02/25 17:46:45 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-2000 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;;; Case Conversion
(define-command upcase-region
- "Convert region to upper case."
- "m"
- (lambda (mark)
- (upcase-area mark)))
+ "Convert the region to upper case."
+ "r"
+ (lambda (region) (upcase-region region)))
(define-command downcase-region
- "Convert region to lower case."
- "m"
- (lambda (mark)
- (downcase-area mark)))
+ "Convert the region to lower case."
+ "r"
+ (lambda (region) (downcase-region region)))
+
+(define-command capitalize-region
+ "Convert the region to capitalized form.
+Capitalized form means each word's first character is upper case
+and the rest of it is lower case."
+ "r"
+ (lambda (region) (capitalize-region region)))
(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."
+ "Convert following word (or ARG words) to upper case, moving over.
+With negative argument, convert previous words but do not move.
+See also `capitalize-word'."
"p"
- (lambda (argument)
- (upcase-area (forward-word (current-point) argument 'ERROR))))
+ (lambda (argument) (case-word-command upcase-region argument)))
(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."
+ "Convert following word (or ARG words) to lower case, moving over.
+With negative argument, convert previous words but do not move."
"p"
- (lambda (argument)
- (downcase-area (forward-word (current-point) argument 'ERROR))))
+ (lambda (argument) (case-word-command downcase-region argument)))
(define-command capitalize-word
- "Put next word in lowercase, but capitalize initial.
-With an argument, capitalizes that many words."
+ "Capitalize the following word (or ARG words), moving over.
+This gives the word(s) a first character in upper case
+and the rest lower case.
+With negative argument, capitalize previous words but do not move."
"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))))))
+ (lambda (argument) (case-word-command capitalize-region argument)))
+
+(define (case-word-command procedure argument)
+ (let* ((point (current-point))
+ (end (forward-word point argument 'ERROR)))
+ (procedure (make-region point end))
+ (if (positive? argument) (set-current-point! end))))
+
+(define (downcase-region region)
+ (region-transform! region
+ (lambda (string)
+ (string-downcase! string)
+ string)))
+
+(define (upcase-region region)
+ (region-transform! region
+ (lambda (string)
+ (string-upcase! string)
+ string)))
+
+(define (capitalize-region region)
+ (let ((end (region-end region)))
+ (let loop ((start (region-start region)))
+ (let ((start (forward-to-word start 'LIMIT)))
+ (if (mark< start end)
+ (let ((m (forward-word start 1 #f)))
+ (if m
+ (begin
+ (region-transform! (make-region start m)
+ (lambda (string)
+ (string-capitalize! string)
+ string))
+ (loop m))
+ (region-transform! (make-region start end)
+ (lambda (string)
+ (string-capitalize! string)
+ string)))))))))
\f
;;;; Sentences
;;; -*-Scheme-*-
;;;
-;;; $Id: txtprp.scm,v 1.18 1999/11/01 03:29:06 cph Exp $
+;;; $Id: txtprp.scm,v 1.19 2000/02/25 17:47:37 cph Exp $
;;;
-;;; Copyright (c) 1993-1999 Massachusetts Institute of Technology
+;;; Copyright (c) 1993-2000 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
(let ((next (next-interval interval)))
(and next
(loop next))))))))
+
+(define text-not-replaceable?
+ text-not-deleteable?)
\f
;;;; Miscellaneous Properties
(region-end-index region)
comtabs))
\f
-;;;; Insertion and Deletion
+;;;; Buffer modification
(define (update-intervals-for-insertion! group start length)
;; Assumes that (GROUP-TEXT-PROPERTIES GROUP) is not #F.
(decrement-interval-length interval delta)
(deletion-loop (next-interval interval)
(fix:- length delta))))))))))
+
+(define (update-intervals-for-replacement! group start end)
+ ;; Assumes that (GROUP-TEXT-PROPERTIES GROUP) is not #F.
+ ;; Assumes that (FIX:< START END).
+ group start end
+ ;; Not sure what to do about this right now. For current uses of
+ ;; replacement, it's reasonable to leave the properties alone.
+ unspecific)
\f
;;;; Undo
;;; -*-Scheme-*-
;;;
-;;; $Id: undo.scm,v 1.58 1999/01/02 06:11:34 cph Exp $
+;;; $Id: undo.scm,v 1.59 2000/02/25 17:48:04 cph Exp $
;;;
-;;; Copyright (c) 1985, 1989-1999 Massachusetts Institute of Technology
+;;; Copyright (c) 1985, 1989-2000 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
point
(group-undo-data group)))))))))
+(define (undo-record-replacement! group start end)
+ (if (not (eq? #t (group-undo-data group)))
+ (begin
+ (if (not (group-modified? group))
+ (undo-record-first-change! group))
+ (set-group-undo-data!
+ group
+ (let ((text (group-extract-string group start end))
+ (point (mark-index (group-point group))))
+ (cons* (cons* 'REPLACEMENT text start)
+ point
+ (group-undo-data group)))))))
+
(define (undo-record-property-changes! group properties)
(if (not (eq? #t (group-undo-data group)))
(begin
(b (cdar undo-data)))
(cond ((eq? 'REINSERT-PROPERTIES a)
(reinsert-properties-size b))
+ ((eq? 'REPLACEMENT a)
+ (fix:+ 2
+ (system-vector-length
+ (car b))))
((string? a)
(fix:+ 1 (system-vector-length a)))
(else 0))))
(mark-temporary! point)
data)))
(let loop ((data data))
- (if (null? data)
- (finish data)
+ (if (pair? data)
(let ((element (car data))
(data (cdr data)))
- (if (eq? #f element)
- ;; #F means boundary: this step is done.
- (finish data)
- (begin
- (cond
+ (cond ((not element)
+ ;; #F means boundary: this step is done.
+ (finish data))
+ ((fix:fixnum? element)
;; Fixnum is a point position.
- ((fix:fixnum? element)
- (set-mark-index! point element))
- (else
- (let ((a (car element))
- (b (cdr element)))
- (cond ((eq? #t a)
- ;; (#t . MOD-TIME) means first modification
- (if (eqv? b (buffer-modification-time buffer))
- (buffer-not-modified! buffer)))
- ((eq? 'REINSERT-PROPERTIES a)
- (group-reinsert-properties! group b))
- ((fix:fixnum? a)
- ;; (START . END) means insertion
- (if (or (fix:< a (group-start-index group))
- (fix:> a (group-end-index group))
- (fix:> b (group-end-index group)))
- (outside-visible-range))
- (set-mark-index! point a)
- (group-delete! group a b))
+ (set-mark-index! point element)
+ (loop data))
+ ((pair? element)
+ (let ((a (car element))
+ (b (cdr element)))
+ (cond ((eq? #t a)
+ ;; (#t . MOD-TIME) means first modification
+ (if (eqv? b (buffer-modification-time buffer))
+ (buffer-not-modified! buffer)))
+ ((eq? 'REINSERT-PROPERTIES a)
+ (group-reinsert-properties! group b))
+ ((eq? 'REPLACEMENT a)
+ (let ((string (car b))
+ (start (cdr b)))
+ (if (or (fix:< start (group-start-index group))
+ (fix:> (fix:+ start
+ (string-length string))
+ (group-end-index group)))
+ (outside-visible-range))
+ ;; No need to set point, set explicitly.
+ (group-replace-string! group start string)))
+ ((fix:fixnum? a)
+ ;; (START . END) means insertion
+ (if (or (fix:< a (group-start-index group))
+ (fix:> a (group-end-index group))
+ (fix:> b (group-end-index group)))
+ (outside-visible-range))
+ (set-mark-index! point a)
+ (group-delete! group a b))
+ ((string? a)
;; (STRING . START) means deletion
- ((fix:< b 0)
- ;; negative START means set point at end
- (let ((b (fix:- 0 b)))
- (if (or (fix:< b (group-start-index group))
- (fix:> b (group-end-index group)))
- (outside-visible-range))
- (set-mark-index! point b)
- (group-insert-string! group b a)))
- (else
- ;; nonnegative START means set point at start
- (if (or (fix:< b (group-start-index group))
- (fix:> b (group-end-index group)))
- (outside-visible-range))
- (group-insert-string! group b a)
- (set-mark-index! point b))))))
- (loop data)))))))))
+ (if (fix:< b 0)
+ ;; negative START means set point at end
+ (let ((b (fix:- 0 b)))
+ (if (or (fix:< b (group-start-index group))
+ (fix:> b (group-end-index group)))
+ (outside-visible-range))
+ (set-mark-index! point b)
+ (group-insert-string! group b a))
+ ;; nonnegative START means set point at start
+ (begin
+ (if (or (fix:< b (group-start-index group))
+ (fix:> b (group-end-index group)))
+ (outside-visible-range))
+ (group-insert-string! group b a)
+ (set-mark-index! point b))))
+ (else
+ (error "Malformed undo element:" element))))
+ (loop data))
+ (else
+ (error "Malformed undo element:" element))))
+ (finish data))))))
projects / mit-scheme.git / commitdiff