From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 10 Aug 1993 06:35:54 +0000 (+0000)
Subject: Define mechanism to find and execute commands from point-local comtabs
X-Git-Tag: 20090517-FFI~8103
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f0114415511a4129acbd8dad431e1bc5a6cd5dc6;p=mit-scheme.git

Define mechanism to find and execute commands from point-local comtabs
when they exist, and modify various places to use it instead of
COMTAB-ENTRY.

Fix installation of text properties: "edwin.pkg" not propertly
modified.

Change name of package for text properties.
---

diff --git a/v7/src/edwin/comred.scm b/v7/src/edwin/comred.scm
index 4329747c0..0d90cfd31 100644
--- a/v7/src/edwin/comred.scm
+++ b/v7/src/edwin/comred.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: comred.scm,v 1.101 1993/08/09 19:38:13 jawilson Exp $
+;;;	$Id: comred.scm,v 1.102 1993/08/10 06:35:38 cph Exp $
 ;;;
 ;;;	Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology
 ;;;
@@ -117,26 +117,12 @@
 			       (let ((window (current-window)))
 				 (%dispatch-on-command
 				  window
-				  (let ((txtprp-comtab
-					 (get-property-at
-					  'command-table
-					  (mark-index
-					   (buffer-point (window-buffer window)))
-					  (buffer-group (window-buffer window)))))
-				    (or
-				     (and
-				      txtprp-comtab
-				      (let ((command
-					     (comtab-entry (cadr txtprp-comtab) input)))
-					(if (eq? command
-						 (ref-command-object undefined))
-					    false
-					    command)))
-					(comtab-entry
-					 (buffer-comtabs (window-buffer window))
-					 input)))
+				  (local-comtab-entry (buffer-comtabs
+						       (window-buffer window))
+						      input
+						      (window-point window))
 				  false)))))
-			       ((dequeue! command-reader-override-queue)))))))))))))
+		       ((dequeue! command-reader-override-queue)))))))))))))
 
 (define (bind-abort-editor-command thunk)
   (call-with-current-continuation
diff --git a/v7/src/edwin/comtab.scm b/v7/src/edwin/comtab.scm
index c005feab4..e5ae584fd 100644
--- a/v7/src/edwin/comtab.scm
+++ b/v7/src/edwin/comtab.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comtab.scm,v 1.62 1992/01/14 18:34:34 cph Exp $
+;;;	$Id: comtab.scm,v 1.63 1993/08/10 06:35:40 cph Exp $
 ;;;
-;;;	Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
+;;;	Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology
 ;;;
 ;;;	This material was developed by the Scheme project at the
 ;;;	Massachusetts Institute of Technology, Department of
@@ -254,10 +254,21 @@
 		   (error "Illegal comtab datum:" datum))))))))
 
 (define (comtab-entry comtabs key)
+  (or (%comtab-entry comtabs key)
+      (and (not (button? key))
+	   (ref-command-object undefined))))
+
+(define (local-comtab-entry comtabs key mark)
+  (or (and mark
+	   (let ((local-comtabs (local-comtabs mark)))
+	     (and local-comtabs
+		  (%comtab-entry local-comtabs key))))
+      (comtab-entry comtabs key)))
+
+(define (%comtab-entry comtabs key)
   (let ((object (lookup-key comtabs key)))
     (cond ((not object)
-	   (and (not (button? key))
-		(ref-command-object undefined)))
+	   #f)
 	  ((command? object)
 	   object)
 	  ((command&comtab? object)
diff --git a/v7/src/edwin/ed-ffi.scm b/v7/src/edwin/ed-ffi.scm
index 229d5e3c8..b721aab5f 100644
--- a/v7/src/edwin/ed-ffi.scm
+++ b/v7/src/edwin/ed-ffi.scm
@@ -223,7 +223,7 @@
 	       syntax-table/system-internal)
     ("tximod"  (edwin)
 	       edwin-syntax-table)
-    ("txtprp"  (edwin text-props)
+    ("txtprp"  (edwin text-properties)
 	       edwin-syntax-table)
     ("undo"    (edwin undo)
 	       edwin-syntax-table)
diff --git a/v7/src/edwin/edtfrm.scm b/v7/src/edwin/edtfrm.scm
index 30257a78a..801629dd9 100644
--- a/v7/src/edwin/edtfrm.scm
+++ b/v7/src/edwin/edtfrm.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: edtfrm.scm,v 1.86 1993/08/09 19:22:40 jawilson Exp $
+;;;	$Id: edtfrm.scm,v 1.87 1993/08/10 06:35:44 cph Exp $
 ;;;
 ;;;	Copyright (c) 1985, 1989-93 Massachusetts Institute of Technology
 ;;;
@@ -191,23 +191,16 @@
 	  ;; Make sure the event is inside the text portion of the
 	  ;; buffer, not in the modeline or other decoration.
 	  (cond ((and (< -1 relative-x (buffer-frame-x-size frame))
-		      (< -1 relative-y (buffer-frame-y-size frame)))
-		 (let* ((point (window-coordinates->mark frame relative-x relative-y))
-			(txtprp-comtab (and point
-					    (get-property-at
-					     'command-table
-					     (mark-index point)
-					     (mark-group point)))))
-		   (let ((command
-			  (or (and txtprp-comtab (comtab-entry (cadr txtprp-comtab)
-							       button))
-			      (comtab-entry (buffer-comtabs (window-buffer frame))
-					    button))))
-		     (cond (command
-			    (with-current-button-event
-				(make-button-event frame relative-x relative-y)
-			      (lambda () (execute-command command))))
-			   ((button/down? button)
-			    (editor-beep))))))
+		      (< -1 relative-y (buffer-frame-y-size frame))
+		      (local-comtab-entry
+		       (buffer-comtabs (window-buffer frame))
+		       button
+		       (window-coordinates->mark frame
+						 relative-x
+						 relative-y)))
+		 => (lambda (command)
+		      (with-current-button-event
+			  (make-button-event frame relative-x relative-y)
+			(lambda () (execute-command command)))))
 		((button/down? button)
-		 (editor-beep)))))))
+		 (editor-beep)))))))
\ No newline at end of file
diff --git a/v7/src/edwin/edwin.ldr b/v7/src/edwin/edwin.ldr
index ddb99827e..bf25e9710 100644
--- a/v7/src/edwin/edwin.ldr
+++ b/v7/src/edwin/edwin.ldr
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: edwin.ldr,v 1.39 1993/08/09 19:20:36 jawilson Exp $
+$Id: edwin.ldr,v 1.40 1993/08/10 06:35:46 cph Exp $
 
-Copyright (c) 1989-1992 Massachusetts Institute of Technology
+Copyright (c) 1989-93 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -94,11 +94,12 @@ MIT in each case. |#
 	(load "clscon" (->environment '(EDWIN CLASS-CONSTRUCTOR)))
 	(load "clsmac" (->environment '(EDWIN CLASS-MACROS)))
 	(load "xform"
-	      (->environment '(EDWIN CLASS-MACROS TRANSFORM-INSTANCE-VARIABLES)))
+	      (->environment
+	       '(EDWIN CLASS-MACROS TRANSFORM-INSTANCE-VARIABLES)))
 	(load "paths" environment)
 	(load "struct" environment)
 	(load "grpops" (->environment '(EDWIN GROUP-OPERATIONS)))
-	(load "txtprp" (->environment '(EDWIN TEXT-PROPS)))
+	(load "txtprp" (->environment '(EDWIN TEXT-PROPERTIES)))
 	(load "regops" environment)
 	(load "motion" environment)
 	(load "search" environment)
diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index 9a1b77462..7ea12c0ef 100644
--- a/v7/src/edwin/edwin.pkg
+++ b/v7/src/edwin/edwin.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: edwin.pkg,v 1.123 1993/08/02 23:54:24 cph Exp $
+$Id: edwin.pkg,v 1.124 1993/08/10 06:35:49 cph Exp $
 
 Copyright (c) 1989-1993 Massachusetts Institute of Technology
 
@@ -193,6 +193,7 @@ MIT in each case. |#
 	  comtab?
 	  define-key
 	  define-prefix-key
+	  local-comtab-entry
 	  make-comtab
 	  prefix-key-list?))
 
@@ -211,6 +212,7 @@ MIT in each case. |#
 	  undo-more
 	  undo-record-deletion!
 	  undo-record-insertion!
+	  undo-record-property-changes!
 	  undo-start
 	  with-group-undo-disabled))
 
@@ -1116,6 +1118,33 @@ MIT in each case. |#
 	  edwin-variable$rmail-primary-inbox-list
 	  edwin-variable$rmail-reply-with-re
 	  rmail-spool-directory))
+
+(define-package (edwin text-properties)
+  (files "txtprp")
+  (parent (edwin))
+  (export (edwin)
+	  add-text-properties
+	  get-property
+	  get-property-at
+	  group-extract-properties
+	  group-reinsert-properties!
+	  local-comtabs
+	  next-property-change
+	  next-specific-property-change
+	  prev-specific-property-change
+	  previous-property-change
+	  remove-text-properties
+	  set-text-properties
+	  text-not-deleteable?
+	  text-not-insertable?
+	  text-properties-at
+	  update-intervals-for-deletion!
+	  update-intervals-for-insertion!)
+  (export (edwin window)
+	  find-interval
+	  interval-end
+	  interval-property
+	  next-interval))
 #|
 (define-package (edwin bochser)
   (files "bochser"
diff --git a/v7/src/edwin/fill.scm b/v7/src/edwin/fill.scm
index f0e429858..dac3b31ba 100644
--- a/v7/src/edwin/fill.scm
+++ b/v7/src/edwin/fill.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: fill.scm,v 1.58 1993/02/22 19:32:01 cph Exp $
+;;;	$Id: fill.scm,v 1.59 1993/08/10 06:35:50 cph Exp $
 ;;;
 ;;;	Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology
 ;;;
@@ -378,7 +378,7 @@ With argument, turn auto-fill mode on iff argument is positive."
   ;; invoked, and performs the auto-fill action only when the context
   ;; is the expected one.
   (let ((command
-	 (comtab-entry
+	 (local-comtab-entry
 	  (let ((comtabs (current-comtabs)))
 	    (let ((tail
 		   (memq (minor-mode-comtab (ref-mode-object auto-fill))
@@ -386,7 +386,8 @@ With argument, turn auto-fill mode on iff argument is positive."
 	      (if (or (null? tail) (null? (cdr tail)))
 		  comtabs
 		  (cdr tail))))
-	  (current-command-key))))
+	  (current-command-key)
+	  (current-point))))
     (if (or (eq? command overriding)
 	    (eq? command overridden)
 	    (eq? command (ref-command-object undefined)))
diff --git a/v7/src/edwin/hlpcom.scm b/v7/src/edwin/hlpcom.scm
index 310f74ec6..e9bf38412 100644
--- a/v7/src/edwin/hlpcom.scm
+++ b/v7/src/edwin/hlpcom.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: hlpcom.scm,v 1.105 1992/11/13 22:16:17 cph Exp $
+;;;	$Id: hlpcom.scm,v 1.106 1993/08/10 06:35:52 cph Exp $
 ;;;
-;;;	Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
+;;;	Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology
 ;;;
 ;;;	This material was developed by the Scheme project at the
 ;;;	Massachusetts Institute of Technology, Department of
@@ -167,7 +167,7 @@ Prints the full documentation for the given command."
 Prints the brief documentation for that command."
   "kDescribe key briefly"
   (lambda (key)
-    (let ((command (comtab-entry (current-comtabs) key)))
+    (let ((command (local-comtab-entry (current-comtabs) key (current-point))))
       (if (eq? command (ref-command-object undefined))
 	  (help-describe-unbound-key key)
 	  (message (xkey->name key)
@@ -179,7 +179,7 @@ Prints the brief documentation for that command."
 Prints the full documentation for that command."
   "kDescribe key"
   (lambda (key)
-    (let ((command (comtab-entry (current-comtabs) key)))
+    (let ((command (local-comtab-entry (current-comtabs) key (current-point))))
       (if (eq? command (ref-command-object undefined))
 	  (help-describe-unbound-key key)
 	  (help-describe-command command)))))
diff --git a/v7/src/edwin/txtprp.scm b/v7/src/edwin/txtprp.scm
index 526225dd5..0d0bb177f 100644
--- a/v7/src/edwin/txtprp.scm
+++ b/v7/src/edwin/txtprp.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: txtprp.scm,v 1.1 1993/08/09 19:12:51 jawilson Exp $
+;;;	$Id: txtprp.scm,v 1.2 1993/08/10 06:35:54 cph Exp $
 ;;;
 ;;;	Copyright (c) 1993 Massachusetts Institute of Technology
 ;;;
@@ -125,6 +125,12 @@
       (get-property prop (interval-properties (find-interval group index)))
       #f))
 
+(define (local-comtabs mark)
+  (let ((property
+	 (get-property-at 'COMMAND-TABLE (mark-index mark) (mark-group mark))))
+    (and property
+	 (cadr property))))
+
 ;;; The next four procedures are all about the same
 ;;; and none have been tested.
 
@@ -238,7 +244,7 @@
 	       (and next
 		    (fix:> end (interval-start next))
 		    (loop next)))))))
-
+
 ;; export
 #|
 (define (update-intervals-for-deletion! group start end)
@@ -252,11 +258,13 @@
 		  (if (and (fix:= start start*)
 			   (fix:= end end*))
 		      (delete-interval interval group)
-		      (add-amount-up-tree interval (fix:- 0 (fix:- end start))))
+		      (add-amount-up-tree interval
+					  (fix:- 0 (fix:- end start))))
 		  (begin
 		    (if (fix:= start start*)
 			(delete-interval interval group)
-			(add-amount-up-tree interval (fix:- 0 (fix:- end* start))))
+			(add-amount-up-tree interval
+					    (fix:- 0 (fix:- end* start))))
 		    (loop end*)))))))))
 |#
 (define (update-intervals-for-deletion! group start end)
@@ -779,8 +787,9 @@
       (connect-left! c y2)
       
       (set-interval-total-length! a (fix:+ (fix:+ lx ly1) la))
-      (set-interval-total-length! b (fix:+ (fix:+ (fix:+ lx ly1) (fix:+ ly2 lz))
-					   (fix:+ (fix:+ la lc) lb)))
+      (set-interval-total-length! b
+				  (fix:+ (fix:+ (fix:+ lx ly1) (fix:+ ly2 lz))
+					 (fix:+ (fix:+ la lc) lb)))
       (set-interval-total-length! c (fix:+ (fix:+ ly2 lz) lc))
       (set-interval-size! a (fix:+ (fix:+ nx ny1) 1))
       (set-interval-size! c (fix:+ (fix:+ ny2 nz) 1))
@@ -849,8 +858,9 @@
       (connect-right! c y2)
 
       (set-interval-total-length! a (fix:+ (fix:+ lx ly1) la))
-      (set-interval-total-length! b (fix:+ (fix:+ (fix:+ lx ly1) (fix:+ ly2 lz))
-					   (fix:+ (fix:+ la lb) lc)))
+      (set-interval-total-length! b
+				  (fix:+ (fix:+ (fix:+ lx ly1) (fix:+ ly2 lz))
+					 (fix:+ (fix:+ la lb) lc)))
       (set-interval-total-length! c (fix:+ (fix:+ ly2 lz) lc))
 
       (set-interval-size! a (fix:+ (fix:+ ny1 nx) 1))
@@ -882,9 +892,4 @@
 	      (else
 	       (set-interval-size! t (fix:+ (interval-size t)
 					    size-inc-amount))
-	       (balance (interval-parent t) group size-inc-amount))))))
-
-;; Edwin Variables:
-;; scheme-environment: '(edwin text-props)
-;; scheme-syntax-table: (access edwin-syntax-table (->environment '(edwin)))
-;; End:
\ No newline at end of file
+	       (balance (interval-parent t) group size-inc-amount))))))
\ No newline at end of file