From 1c935b93fcff6c314a58054b133ae298bda55346 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Mon, 2 Nov 1998 22:20:03 +0000
Subject: [PATCH] ...

original commit: 015c7c88b35b1759af9912048010a9e7a04a09c0
---
 collects/framework/editor.ss                  | 26 ++++++--
 collects/framework/framework.ss               | 12 ++++
 collects/framework/keys.ss                    | 10 +--
 .../tests/framework/framework-test-engine.ss  | 65 +++++++++----------
 4 files changed, 65 insertions(+), 48 deletions(-)
 create mode 100644 collects/framework/framework.ss

diff --git a/collects/framework/editor.ss b/collects/framework/editor.ss
index 8bb1f992..3678bdc6 100644
--- a/collects/framework/editor.ss
+++ b/collects/framework/editor.ss
@@ -9,6 +9,8 @@
 	  [text : framework:text^]
 	  [pasteboard : framework:pasteboard^])
   
+  (rename [-keymap<%> keymap<%>])
+
   (define basic<%>
     (interface (editor<%>)
       editing-this-file?
@@ -24,7 +26,6 @@
       (inherit get-filename save-file
 	       refresh-delayed? 
 	       get-canvas
-	       get-keymap
 	       get-max-width get-admin set-filename)
       (rename [super-set-modified set-modified]
 	      [super-on-focus on-focus]
@@ -140,9 +141,28 @@
 	(apply super-init args)
 	(auto-wrap (default-auto-wrap?)))))
   
+  (define -keymap<%> (interface (basic<%>)))
+  (define keymap-mixin
+    (mixin (basic<%>) (-keymap<%>) args
+      (public
+	[get-keymaps
+	 (lambda ()
+	   (list (keymap:get-global)))])
+      (inherit get-keymap)
+      (sequence
+	(apply super-init args)
+	(let ([keymap (get-keymap)])
+	  (keymap:set-keymap-error-handler keymap)
+	  (keymap:set-keymap-implied-shifts keymap)
+	  (add-editor-keymap-functions keymap)
+	  (add-text-keymap-functions keymap)
+	  (add-pasteboard-keymap-functions keymap)
+	  (for-each (lambda (k)
+		      (send keymap chain-to-keymap k #f))
+		    (get-keymaps))))))
 
   (define file<%> (interface (basic<%>)))
-  (define file-mixin
+  (define file-mixin ;; wx - should come from -keymap<%>
     (mixin (basic<%>) (file<%>) args
       (inherit get-keymap  
 	       get-filename lock get-style-list 
@@ -178,8 +198,6 @@
       (sequence
 	(apply super-init args)
 	(let ([keymap (get-keymap)])
-	  (keymap:set-keymap-error-handler keymap)
-	  (keymap:set-keymap-implied-shifts keymap)
 	  (send keymap chain-to-keymap (keymap:get-file) #f)))))
   
   (define backup-autosave<%>
diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss
new file mode 100644
index 00000000..fe17c951
--- /dev/null
+++ b/collects/framework/framework.ss
@@ -0,0 +1,12 @@
+(read-case-sensitive #t)
+(compile-allow-cond-fallthrough #t)
+(compile-allow-set!-undefined #t)
+(require-library "mred-interfaces.ss" "framework")
+(require-library "sig.ss" "framework")
+(invoke-unit/sig
+ (compound-unit/sig
+   (import)
+   (link [M : mred-interfaces^ (mred-interfaces@)]
+	 [C : mzlib:core^ ((require-library "corer.ss"))]
+	 [F : framework^ ((require-library "frameworkr.ss" "framework") C M)])
+   (export)))
diff --git a/collects/framework/keys.ss b/collects/framework/keys.ss
index 2a14d6e7..5bcda9a5 100644
--- a/collects/framework/keys.ss
+++ b/collects/framework/keys.ss
@@ -12,10 +12,9 @@
   ;  are not normally thought of as shifted. It will have to be
   ;  changed for different keyboards.
   (define shifted-key-list
-    '("?" ":" "~" "\""
+    '("?" ":" "~" "\"" "|"
       "<" ">" "{" "}" "[" "]" "(" ")"
-      "!" "@" "#" "$" "%" "^" "&" "*" "_" "+"
-      "|"))
+      "!" "@" "#" "$" "%" "^" "&" "*" "_" "+"))
   
   (define keyerr
     (lambda (str)
@@ -553,11 +552,6 @@
 	       [add-m (lambda (name func)
 			(send kmap add-mouse-function name func))])
 	  
-	  ; Standards
-	  (add-editor-keymap-functions kmap)
-	  (add-text-keymap-functions kmap)
-	  (add-pasteboard-keymap-functions kmap)
-	  
 	  ; Map names to keyboard functions
 	  (add "toggle-overwrite" toggle-overwrite)
 	  
diff --git a/collects/tests/framework/framework-test-engine.ss b/collects/tests/framework/framework-test-engine.ss
index aaf8a68c..bee29fab 100644
--- a/collects/tests/framework/framework-test-engine.ss
+++ b/collects/tests/framework/framework-test-engine.ss
@@ -1,37 +1,30 @@
-(printf "mred:creating thread~n")
 (thread
- (with-handlers ([(lambda (x) #t)
-		  (lambda (exn)
-		    (fprintf (current-error-port) "mred: ")
-		    (raise exn))])
-   (letrec ([restart
-	     (lambda ()
-	       (printf "mred:initializing loop~n")
-	       (let*-values ([(in out) (tcp-connect "localhost" (load-relative "receive-sexps-port.ss"))]
-			     [(continue) (make-semaphore 0)]
-			     [(error) #f]
-			     [(answer) (void)])
-		 (printf "mred:made connection~n")
-		 (let loop ()
-		   (let ([sexp (read in)])
-		     (if (eof-object? sexp)
-			 (begin
-			   (close-input-port in)
-			   (close-output-port out)
-			   (exit))
-			 (begin
-			   (queue-callback (lambda ()
-					     (set! error #f)
-					     (with-handlers ([(lambda (x) #t)
-							      (lambda (exn)
-								(set! error exn))])
-					       (set! answer (eval sexp)))
-					     (semaphore-post continue)))
-			   (semaphore-wait continue)
-			   (write
-			    (if error
-				(list 'error (exn-message error))
-				(list 'normal answer))
-			    out)
-			   (loop)))))))])
-     restart)))
+ (letrec ([restart
+	   (lambda ()
+	     (let*-values ([(in out) (tcp-connect "localhost" (load-relative "receive-sexps-port.ss"))]
+			   [(continue) (make-semaphore 0)]
+			   [(error) #f]
+			   [(answer) (void)])
+	       (let loop ()
+		 (let ([sexp (read in)])
+		   (if (eof-object? sexp)
+		       (begin
+			 (close-input-port in)
+			 (close-output-port out)
+			 (exit))
+		       (begin
+			 (queue-callback (lambda ()
+					   (set! error #f)
+					   (with-handlers ([(lambda (x) #t)
+							    (lambda (exn)
+							      (set! error exn))])
+					     (set! answer (eval sexp)))
+					   (semaphore-post continue)))
+			 (semaphore-wait continue)
+			 (write
+			  (if error
+			      (list 'error (exn-message error))
+			      (list 'normal answer))
+			  out)
+			 (loop)))))))])
+   restart))