From: Chris Hanson Date: Fri, 25 Feb 2000 17:48:04 +0000 (+0000) Subject: Reimplement case-conversion commands, including new capitalize-region. X-Git-Tag: 20090517-FFI~4234 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=45b5c23d5b1121cf80af4e03bcee773fd8edaf1d;p=mit-scheme.git Reimplement case-conversion commands, including new capitalize-region. New implementation utilities low-level code to replace strings in buffer without disturbing marks or text properties. --- diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index 60f826d60..e21b0a73c 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-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 @@ -168,6 +168,9 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. 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!)) @@ -202,6 +205,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. undo-record-deletion! undo-record-insertion! undo-record-property-changes! + undo-record-replacement! undo-start with-group-undo-disabled)) @@ -871,8 +875,10 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (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! diff --git a/v7/src/edwin/grpops.scm b/v7/src/edwin/grpops.scm index 6099c9397..8b5e4a217 100644 --- a/v7/src/edwin/grpops.scm +++ b/v7/src/edwin/grpops.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -72,18 +72,18 @@ (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)) -;;;; Insertions +;;;; Insertion (define (group-insert-char! group index char) (group-insert-chars! group index char 1)) @@ -167,11 +167,11 @@ (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))) -;;;; Deletions +;;;; Deletion (define (group-delete-left-char! group index) (group-delete! group (fix:- index 1) index)) @@ -241,12 +241,71 @@ (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))) +;;;; 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))) + ;;;; Resizing (define (grow-group! group new-gap-start n) diff --git a/v7/src/edwin/regops.scm b/v7/src/edwin/regops.scm index 146e80622..ab6ad3529 100644 --- a/v7/src/edwin/regops.scm +++ b/v7/src/edwin/regops.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -73,16 +73,11 @@ (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))))) ;;;; Clipping diff --git a/v7/src/edwin/simple.scm b/v7/src/edwin/simple.scm index 0d73e482c..1068e599a 100644 --- a/v7/src/edwin/simple.scm +++ b/v7/src/edwin/simple.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -198,28 +198,6 @@ (group-extract-and-delete-string! group index1 index2) (group-extract-and-delete-string! group index2 index1))))) -(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)) @@ -251,7 +229,7 @@ (define (reposition-window-top mark) (if (not (and mark (set-window-start-mark! (current-window) mark false))) (editor-beep))) - + (define (narrow-to-region mark #!optional point) (let ((point (if (default-object? point) (current-point) point))) (let ((group (mark-group mark)) diff --git a/v7/src/edwin/texcom.scm b/v7/src/edwin/texcom.scm index 39dd19cc6..221dc52cd 100644 --- a/v7/src/edwin/texcom.scm +++ b/v7/src/edwin/texcom.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -114,56 +114,78 @@ With a zero argument, it transposes the words at point and mark." ;;;; 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))))))))) ;;;; Sentences diff --git a/v7/src/edwin/txtprp.scm b/v7/src/edwin/txtprp.scm index 7c86813fe..510b7af1a 100644 --- a/v7/src/edwin/txtprp.scm +++ b/v7/src/edwin/txtprp.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -277,6 +277,9 @@ (let ((next (next-interval interval))) (and next (loop next)))))))) + +(define text-not-replaceable? + text-not-deleteable?) ;;;; Miscellaneous Properties @@ -322,7 +325,7 @@ (region-end-index region) comtabs)) -;;;; Insertion and Deletion +;;;; Buffer modification (define (update-intervals-for-insertion! group start length) ;; Assumes that (GROUP-TEXT-PROPERTIES GROUP) is not #F. @@ -368,6 +371,14 @@ (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) ;;;; Undo diff --git a/v7/src/edwin/undo.scm b/v7/src/edwin/undo.scm index 73c7a3cdf..7943d7838 100644 --- a/v7/src/edwin/undo.scm +++ b/v7/src/edwin/undo.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -121,6 +121,19 @@ 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 @@ -209,6 +222,10 @@ which includes both the saved text and other data." (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)))) @@ -281,49 +298,63 @@ A numeric argument serves as a repeat count." (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))))))