From c4e7f8a462f1c9c6ffa5e308556b8982c0cd14ac Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 6 Oct 1993 00:59:18 +0000 Subject: [PATCH] Define some procedures to hide the use of the text-property mechanism for highlighting, local comtabs, and read-only regions. --- v7/src/edwin/debug.scm | 54 +++++++++++++---------------------------- v7/src/edwin/edwin.pkg | 12 +++++++-- v7/src/edwin/txtprp.scm | 48 +++++++++++++++++++++++++++++++++--- 3 files changed, 71 insertions(+), 43 deletions(-) diff --git a/v7/src/edwin/debug.scm b/v7/src/edwin/debug.scm index 4bc980d8d..b1c502bb4 100644 --- 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 @@ ;;;; 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))))))) ;;;; 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 1e629c400..665f1f802 100644 --- 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 1290acb09..8a7771576 100644 --- 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)))))))) +;;;; 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)) + ;;;; Insertion and Deletion (define (update-intervals-for-insertion! group start length) -- 2.25.1