Define some procedures to hide the use of the text-property mechanism

for highlighting, local comtabs, and read-only regions.

diff --git a/v7/src/edwin/debug.scm b/v7/src/edwin/debug.scm
index 4bc980d8dafb2f86a3bf7165399b8b5f39711636..b1c502bb49f3942a817b9e53a082ff29b809264d 100644 (file)
--- a/v7/src/edwin/debug.scm
+++ b/v7/src/edwin/debug.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Id: debug.scm,v 1.19 1993/09/09 21:21:33 cph Exp $
+;;;    $Id: debug.scm,v 1.20 1993/10/06 00:59:18 cph Exp $
 ;;;
 ;;;    Copyright (c) 1992-93 Massachusetts Institute of Technology
 ;;;
@@ -49,42 +49,19 @@
 \f
 ;;;; Text prop setup stuff
 
-(define (with-output-property port key datum thunk)
-  (let ((start (mark-index (port/mark port))))
+(define (with-output-highlighted port thunk)
+  (let ((start (mark-temporary-copy (port/mark port))))
     (thunk)
-    (let ((end (mark-index (port/mark port))))
-      (add-text-property (mark-group (port/mark port))
-                        start
-                        end
-                        key
-                        datum))))
-
-(define (readable-between start end)
-  (remove-text-property (mark-group start)
-                       (mark-index start)
-                       (mark-index end)
-                       'READ-ONLY))
-
-(define (dehigh-between start end)
-  (remove-text-property (mark-group start)
-                       (mark-index start)
-                       (mark-index end)
-                       'HIGHLIGHTED))
+    (highlight-region (make-region start (port/mark port)) #t)))
 
 (define (read-only-between start end)
-  (add-text-property (mark-group start)
-                    (mark-index start)
-                    (mark-index end)
-                    'READ-ONLY
-                    (generate-uninterned-symbol)))
+  (region-read-only (make-region start end)))
 
-(define (highlight-region start end)
-  (if (not (mark<= start end))
-      (error "Marks incorrectly related:" start end))
-  (group-highlight (mark-group start) (mark-index start) (mark-index end)))
+(define (readable-between start end)
+  (region-writable (make-region start end)))
 
-(define (group-highlight group start end)
-  (add-text-property group start end 'HIGHLIGHTED #t))
+(define (dehigh-between start end)
+  (highlight-region (make-region start end) #f))
 
 (define (debugger-pp-highlight-subexpression expression subexpression
                                             indentation port)
@@ -119,13 +96,12 @@
     (let ((lend (line-end start 0)))
       (if (mark<= lend end)
          (begin
-           (highlight-region (horizontal-space-end start)
-                             (horizontal-space-start lend))
+           (highlight-region (horizontal-space-region start) #t)
            (loop (mark1+ lend)))
          (let ((start (horizontal-space-end start))
                (end (horizontal-space-start end)))
            (if (mark< start end)
-               (highlight-region start end)))))))
+               (highlight-region (make-region start end) #t)))))))
 \f
 ;;;; Browsers
 
@@ -345,7 +321,11 @@
 
 (define (highlight-the-number mark)
   (let ((end (re-search-forward "[RSE][0-9]+ " mark (line-end mark 0))))
-    (highlight-region mark (if (mark? end) (mark- end 1) (line-end mark 0)))))
+    (highlight-region (make-region mark
+                                  (if (mark? end)
+                                      (mark- end 1)
+                                      (line-end mark 0)))
+                     #t)))
 
 (define (unselect-bline browser)
   (let ((bline (browser/selected-line browser)))
@@ -1106,7 +1086,7 @@ The buffer below describes the current subproblem or reduction.
                         (newline port)
                         (newline port)
                         (write-string "  " port)
-                        (with-output-property port 'HIGHLIGHTED #t
+                        (with-output-highlighted port
                           (lambda ()
                             (write-condition-report object port)))
                         (newline port)))

diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index 1e629c400f647dcf4d8d2dae28069b824f46d4af..665f1f8028613b273f6332f8c13e7028afc1e38b 100644 (file)
--- a/v7/src/edwin/edwin.pkg
+++ b/v7/src/edwin/edwin.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: edwin.pkg,v 1.134 1993/10/05 23:05:56 cph Exp $
+$Id: edwin.pkg,v 1.135 1993/10/06 00:59:11 cph Exp $
 
 Copyright (c) 1989-1993 Massachusetts Institute of Technology
 
@@ -840,12 +840,20 @@ MIT in each case. |#
          add-text-property
          get-text-properties
          get-text-property
+         highlight-region
+         highlight-subgroup
          local-comtabs
          next-property-change
          next-specific-property-change
          previous-property-change
          previous-specific-property-change
-         remove-text-property)
+         region-read-only
+         region-writable
+         remove-text-property
+         set-region-local-comtabs!
+         set-subgroup-local-comtabs!
+         subgroup-read-only
+         subgroup-writable)
   (export (edwin group-operations)
          text-not-deleteable?
          text-not-insertable?

diff --git a/v7/src/edwin/txtprp.scm b/v7/src/edwin/txtprp.scm
index 1290acb09935f4a22fc53e449bd192fc49a70ccd..8a77715764529a47083eaeab44b7811329e132ed 100644 (file)
--- a/v7/src/edwin/txtprp.scm
+++ b/v7/src/edwin/txtprp.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Id: txtprp.scm,v 1.12 1993/10/05 23:05:18 cph Exp $
+;;;    $Id: txtprp.scm,v 1.13 1993/10/06 00:59:04 cph Exp $
 ;;;
 ;;;    Copyright (c) 1993 Massachusetts Institute of Technology
 ;;;
@@ -78,9 +78,6 @@
       (interval-property (find-interval group index) key default)
       default))
 
-(define (local-comtabs mark)
-  (get-text-property (mark-group mark) (mark-index mark) 'COMMAND-TABLE #f))
-
 (define (next-property-change group start end)
   (validate-region-arguments group start end 'NEXT-PROPERTY-CHANGE)
   (and (group-text-properties group)
@@ -263,6 +260,22 @@
 ;;; immediately adjacent to one another, insertions may occur in
 ;;; between the regions, but not inside of them.
 
+(define (subgroup-read-only group start end)
+  (add-text-property group start end 'READ-ONLY (list 'READ-ONLY)))
+
+(define (subgroup-writable group start end)
+  (remove-text-property group start end 'READ-ONLY))
+
+(define (region-read-only region)
+  (subgroup-read-only (region-group region)
+                     (region-start-index region)
+                     (region-end-index region)))
+
+(define (region-writable region)
+  (subgroup-writable (region-group region)
+                    (region-start-index region)
+                    (region-end-index region)))
+
 (define (text-not-insertable? group start)
   ;; Assumes that (GROUP-TEXT-PROPERTIES GROUP) is not #F.
   (and (not (eq? 'FULLY (group-writable? group)))
@@ -291,6 +304,33 @@
                    (and next
                         (loop next))))))))
 \f
+;;;; Miscellaneous Properties
+
+(define (highlight-subgroup group start end highlight)
+  (if highlight
+      (add-text-property group start end 'HIGHLIGHTED highlight)
+      (remove-text-property group start end 'HIGHLIGHTED)))
+
+(define (highlight-region region highlight)
+  (highlight-subgroup (region-group region)
+                     (region-start-index region)
+                     (region-end-index region)
+                     highlight))
+
+(define (local-comtabs mark)
+  (get-text-property (mark-group mark) (mark-index mark) 'COMMAND-TABLE #f))
+
+(define (set-subgroup-local-comtabs! group start end comtabs)
+  (if comtabs
+      (add-text-property group start end 'COMMAND-TABLE comtabs)
+      (remove-text-property group start end 'COMMAND-TABLE)))
+
+(define (set-region-local-comtabs! region comtabs)
+  (set-subgroup-local-comtabs! (region-group region)
+                              (region-start-index region)
+                              (region-end-index region)
+                              comtabs))
+\f
 ;;;; Insertion and Deletion
 
 (define (update-intervals-for-insertion! group start length)