original commit: 015c7c88b35b1759af9912048010a9e7a04a09c0
This commit is contained in:
Robby Findler 1998-11-02 22:20:03 +00:00
parent 96ad62b6ee
commit 1c935b93fc
4 changed files with 65 additions and 48 deletions

View File

@ -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<%>

View File

@ -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)))

View File

@ -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)

View File

@ -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))