From a888199ce356c1bbd3d69bab3346fe485d7fb0ff Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Sat, 19 Feb 2000 00:30:19 +0000
Subject: [PATCH] ...

original commit: f0c615071e1e354f3412d82c2c5c9f7fea6975d7
---
 collects/framework/editor.ss     |  5 +--
 collects/framework/frame.ss      |  1 +
 collects/framework/frameworks.ss |  3 ++
 collects/framework/keymap.ss     | 57 ++++++++++++++++++++++++++++++--
 collects/framework/scheme.ss     |  2 +-
 5 files changed, 62 insertions(+), 6 deletions(-)

diff --git a/collects/framework/editor.ss b/collects/framework/editor.ss
index 6a553f0b..9c9b2767 100644
--- a/collects/framework/editor.ss
+++ b/collects/framework/editor.ss
@@ -195,10 +195,11 @@
 	[get-keymaps
 	 (lambda ()
 	   (list (keymap:get-global)))])
-      (inherit get-keymap)
+      (inherit set-keymap)
       (sequence
 	(apply super-init args)
-	(let ([keymap (get-keymap)])
+	(let ([keymap (make-object keymap:aug-keymap%)])
+          (set-keymap keymap)
 	  (for-each (lambda (k) (send keymap chain-to-keymap k #f))
 		    (get-keymaps))))))
 
diff --git a/collects/framework/frame.ss b/collects/framework/frame.ss
index 4c396602..ebb73869 100644
--- a/collects/framework/frame.ss
+++ b/collects/framework/frame.ss
@@ -1,3 +1,4 @@
+
 (unit/sig framework:frame^
   (import mred^
 	  [group : framework:group^]
diff --git a/collects/framework/frameworks.ss b/collects/framework/frameworks.ss
index 27d839e9..f855afbf 100644
--- a/collects/framework/frameworks.ss
+++ b/collects/framework/frameworks.ss
@@ -218,6 +218,9 @@
   (send-map-function-meta
    make-meta-prefix-list
 
+   aug-keymap%
+   aug-keymap<%>
+   
    setup-global
    setup-search
    setup-file
diff --git a/collects/framework/keymap.ss b/collects/framework/keymap.ss
index 0a9d3ee8..bb110968 100644
--- a/collects/framework/keymap.ss
+++ b/collects/framework/keymap.ss
@@ -9,6 +9,57 @@
   
   (rename [-get-file get-file])
   
+  (define aug-keymap<%> (interface () get-chained-keymaps get-map-function-table))
+  
+  (define aug-keymap%
+    (class* keymap% (aug-keymap<%>) args
+      (private
+        [chained-keymaps null])
+      (public
+        [get-chained-keymaps
+         (lambda ()
+           chained-keymaps)])
+      (rename [super-chain-to-keymap chain-to-keymap])
+      (override
+        [chain-to-keymap
+         (lambda (keymap prefix?)
+           (super-chain-to-keymap keymap prefix?)
+           (set! chained-keymaps
+                 (if prefix?
+                     (cons keymap chained-keymaps)
+                     (append chained-keymaps (list keymap)))))])
+      
+      (private [function-table (make-hash-table)])
+      (public [get-function-table (lambda () function-table)])
+      (rename [super-map-function map-function])
+      (override
+        [map-function
+         (lambda (keyname fname)
+           (super-map-function keyname fname)
+           (hash-table-put! function-table (string->symbol keyname) fname))])
+      
+      (public
+        [get-map-function-table
+         (lambda ()
+           (let ([table (make-hash-table)])
+             (hash-table-for-each
+              function-table
+              (lambda (keyname fname) (hash-table-put! table keyname fname)))
+             (for-each
+              (lambda (chained-keymap)
+                (when (is-a? chained-keymap aug-keymap<%>)
+                  (hash-table-for-each
+                   (send chained-keymap get-map-function-table)
+                   (lambda (keyname fname)
+                     (unless (hash-table-get table keyname (lambda () #f))
+                       (hash-table-put! table keyname fname))))))
+              chained-keymaps)
+             table))])
+      
+      (sequence
+        (apply super-init args))))
+
+  
   (define (make-meta-prefix-list key)
     (list (string-append "m:" key)
 	  (string-append "ESC;" key)))
@@ -899,17 +950,17 @@
     (add-pasteboard-keymap-functions keymap)
     (add-text-keymap-functions keymap))
 
-  (define global (make-object keymap%))
+  (define global (make-object aug-keymap%))
   (setup-global global)
   (generic-setup global)
   (define (get-global) global)
   
-  (define file (make-object keymap%))
+  (define file (make-object aug-keymap%))
   (setup-file file)
   (generic-setup file)
   (define (-get-file) file)
   
-  (define search (make-object keymap%))
+  (define search (make-object aug-keymap%))
   (generic-setup search)
   (setup-search search)
   (define (get-search) search)
diff --git a/collects/framework/scheme.ss b/collects/framework/scheme.ss
index 4f1eee14..f389d16e 100644
--- a/collects/framework/scheme.ss
+++ b/collects/framework/scheme.ss
@@ -930,7 +930,7 @@
 	  (map-meta "c:t" "transpose-sexp"))
 	(send keymap map-function "c:c;c:b" "remove-parens-forward")))
 
-  (define keymap (make-object keymap%))
+  (define keymap (make-object keymap:aug-keymap%))
   (setup-keymap keymap)
   (define (get-keymap) keymap)